pax_global_header00006660000000000000000000000064120176732270014521gustar00rootroot0000000000000052 comment=4b90b7895d6c4f173434a57926de242138be49f8 slicot-5.0+20101122/000077500000000000000000000000001201767322700135465ustar00rootroot00000000000000slicot-5.0+20101122/Installation.txt000077500000000000000000000123561201767322700167620ustar00rootroot00000000000000SLICOT Software Installation and Updating ----------------------------------------- The next sections describe how to install/update the SLICOT Library, and how to run the example programs. SLICOT Library Installation/Updating The essential source code and documentation for the SLICOT software is distributed via an archive file, slicot.tar.gz or slicotPC.zip, for Unix or Windows platforms, respectively. After decompressing any of these files, the SLICOT Library root directory, slicot, and several filled-in subdirectories (benchmark_data, doc, examples, examples77, src, and src_aux), will be created. The distribution files mentioned above do not contain any object or executable files. They can be built using the information given in this file. Prebuilt libraries and MATLAB executables for some often used platforms are available on the SLICOT Web site. SLICOT routines make calls to subprograms from the state-of-the-art packages LAPACK (Linear Algebra Package) and BLAS (Basic Linear Algebra Subprograms). Fortran source code and prebuilt, Fortran-based LAPACK and BLAS libraries are freely downloadable from the netlib (a system for the distribution of mathematical software through Internet). However, for maximum efficiency it is recommended to use machine-specific, optimized versions whenever possible. Template make files are provided to help building the SLICOT Library object file, and to link and run the available example programs calling the SLICOT Library routines. In order to use these make files on a specific Unix or Windows platform, some changes might be needed in the files make.inc and/or makefile stored in the SLICOT root directory, slicot. Denote by the path to the slicot directory, which can be, e.g., c:\slicot, on Windows platforms. (The last (sub)directory name in is slicot.) The changes in make.inc might define the specific machine (platform) identifier, the compiler, linker, and archiver flags, and the location and names of the LAPACK and BLAS libraries, which the program files should be linked to. Details are given in the file make.inc. Changes in makefile might be needed for using a Fortran 77 compiler, since a Fortran 90/95 compiler is assumed by default to build the executable example programs. (The SLICOT routines themselves are written in Fortran 77.) Specifically, for a standard Fortran 77 compiler, it is necessary to replace the string "examples" by "examples77" in the file makefile. After performing the necessary changes, as suggested in the comments of the make files, the other needed SLICOT-related files can be generated automatically with the command make # or nmake, for Windows platforms issued from the directory slicot of . The first execution of (n)make will create the following files - the SLICOT Library object files *.o (for Unix machines), or *.obj (for Windows machines), in the subdirectory src of slicot; - the library file slicot.a or slicot.lib, respectively, in the directory slicot; - the auxiliary library file lpkaux.a or lpkaux.lib, respectively, in the directory slicot; - the example programs object and executable files, in the subdirectory examples(77); - the files *.exa, with the results computed on the local machine, with the same name as for the files with data (*.dat) and reference results (*.res), also in the subdirectory examples(77). The subsequent executions of (n)make will update the files if changes have been performed. The files *.exa, with the computed results may be compared with the reference results. Several types of differences could be noticed, including possible sign changes for some elements, or even different values in some columns and/or rows of the computed matrices. For instance, the matrices of similarity or equivalence transformations could differ from a platform/compiler to another. This does not usually mean that the computed results are wrong. More details for executing other tasks, e.g., cleaning the subdirectories src and examples(77), are given in the files makefile included in directory slicot and in the subdirectories src and examples(77). The auxiliary library lpkaux contains few LAPACK and BLAS object files for routines which slightly differ from the standard distribution. The currently included files are dcabs1, dhgeqz, and dtgsy2. Other files might be included, as specified in the Release.Notes or Release.History files. The file dcabs1 is a copy of the BLAS routine which might be missing in some distributions. To generate the object code for dcabs1, the file makefile in the subdirectory src_aux should be modified accordingly (see the included comments). The file dhgeqz is the David Day's slightly modified version of the corresponding LAPACK routine. Without that modification, trivial examples have been encountered on which the convergence of the QZ algorithm was not achieved. In addition, an error in the LAPACK distribution has been removed. Another error in the LAPACK distribution file dtgsy2 has been removed. The first command-line invocation of (n)make from the SLICOT root directory compiles the source files in subdirectory src_aux, and automatically builds the object library file lpkaux.a or lpkaux.lib, and store it in the directory slicot. ----- Vasile Sima (vsima@ici.ro), September 26, 2009 slicot-5.0+20101122/benchmark_data/000077500000000000000000000000001201767322700164715ustar00rootroot00000000000000slicot-5.0+20101122/benchmark_data/BB01103.dat000077500000000000000000000007541201767322700200440ustar00rootroot00000000000000 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.890D+00 3.900D-01 -5.530D+00 0.000D+00 -3.400D-02 -2.980D+00 2.430D+00 3.400D-02 -1.100D-03 -9.900D-01 -2.100D-01 0.000D+00 0.000D+00 3.600D-01 -1.600D+00 -9.500D-01 -3.200D-02 3.000D-02 0.000D+00 2.313D+00 2.727D+00 6.880D-01 2.300D-02 2.727D+00 4.271D+00 1.148D+00 3.230D-01 6.880D-01 1.148D+00 3.130D-01 1.020D-01 2.300D-02 3.230D-01 1.020D-01 8.300D-02 slicot-5.0+20101122/benchmark_data/BB01104.dat000077500000000000000000000033111201767322700200350ustar00rootroot00000000000000 -9.910D-01 5.290D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.220D-01 -1.051D+00 5.960D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.220D-01 -1.118D+00 5.960D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.220D-01 -1.548D+00 7.180D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.640D+00 7.990D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.721D+00 9.010D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.823D+00 1.021D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.943D+00 3.840D-03 -2.880D-03 4.000D-03 -3.040D-03 3.760D-02 -2.800D-03 3.080D-03 -2.320D-03 2.360D-03 -3.320D-03 2.880D-03 -3.820D-03 3.080D-03 -4.120D-03 3.000D-03 -3.960D-03 1.000D+00 0.000D+00 0.000D+00 0.000D+00 5.000D-01 0.000D+00 0.000D+00 1.000D-01 0.000D+00 1.000D+00 0.000D+00 0.000D+00 1.000D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 5.000D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.000D-01 1.000D-01 0.000D+00 0.000D+00 1.000D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.000D-01 0.000D+00 0.000D+00 1.000D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D-01 0.000D+00 1.000D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D-01 slicot-5.0+20101122/benchmark_data/BB01105.dat000077500000000000000000000024401201767322700200400ustar00rootroot00000000000000 -4.019D+00 5.120D+00 0.000D+00 0.000D+00 -2.082D+00 0.000D+00 0.000D+00 0.000D+00 8.700D-01 -3.460D-01 9.860D-01 0.000D+00 0.000D+00 -2.340D+00 0.000D+00 0.000D+00 0.000D+00 9.700D-01 -7.909D+00 1.5407D+01 -4.069D+00 0.000D+00 -6.450D+00 0.000D+00 0.000D+00 0.000D+00 2.680D+00 -2.1816D+01 3.5606D+01 -3.390D-01 -3.870D+00 -1.780D+01 0.000D+00 0.000D+00 0.000D+00 7.390D+00 -6.0196D+01 9.8188D+01 -7.907D+00 3.400D-01 -5.3008D+01 0.000D+00 0.000D+00 0.000D+00 2.040D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.400D+01 -1.472D+02 0.000D+00 5.320D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.400D+01 -1.472D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.280D+01 0.000D+00 -3.160D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.280D+01 0.000D+00 0.000D+00 1.880D+01 -3.160D+01 1.000D-02 -1.100D-02 -1.510D-01 3.000D-03 -2.100D-02 0.000D+00 9.000D-03 -5.900D-02 0.000D+00 2.400D-02 -1.620D-01 0.000D+00 6.800D-02 -4.450D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BB01106.dat000077500000000000000000000322211201767322700200410ustar00rootroot00000000000000 -4.328D+00 1.714D-01 5.376D+00 4.016D+02 -7.246D+02 -1.933D+00 1.020D+00 -9.820D-01 9.990D-01 1.521D+00 -4.062D+00 9.567D+00 1.008D+01 -6.017D-01 -1.312D-01 9.602D-02 -4.570D-02 0.000D+00 -4.516D+02 0.000D+00 0.000D+00 -1.058D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.402D-01 -5.643D+00 1.275D+02 -2.335D+02 -4.343D+02 2.659D+01 2.040D+00 -2.592D+00 1.132D+01 1.090D+01 -4.071D+00 -5.739D-02 -6.063D-01 -7.488D-02 -5.936D-01 -9.602D-02 1.114D-01 0.000D+00 -5.461D+02 0.000D+00 0.000D+00 -6.575D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.038D+00 6.073D+00 -1.650D+02 -4.483D+00 1.049D+03 -8.245D+01 -5.314D+00 5.097D+00 -9.389D-03 1.352D-01 5.638D+00 2.246D-02 1.797D-01 2.407D-02 1.100D+00 2.743D-02 2.153D-01 0.000D+00 1.362D+03 0.000D+00 0.000D+00 1.346D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.304D-01 -1.086D-01 1.313D+02 -5.783D+02 1.020D+02 -9.240D+00 -1.146D+00 -2.408D+00 -3.081D+00 -4.529D+00 5.707D+00 -2.346D-01 -2.111D+00 -2.460D-01 -4.686D-01 -3.223D-01 3.262D-01 0.000D+00 2.080D+02 0.000D+00 0.000D+00 -2.888D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.476D-03 -1.563D-02 5.602D-02 1.573D+00 -1.005D+01 1.952D-01 -8.804D-03 -2.110D-02 2.090D-03 -5.256D-02 -4.077D-02 -9.182D-03 -5.178D-02 3.425D-02 4.995D-03 -1.256D-02 9.948D-03 0.000D+00 -9.839D+01 0.000D+00 0.000D+00 5.069D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.350D-01 -1.249D-02 -3.567D-02 -6.074D-01 3.765D+01 -1.979D+01 -1.813D-01 -2.952D-02 -1.953D-02 -1.622D-01 -6.439D-03 -2.346D-02 -2.201D-01 -2.514D-02 -3.749D-03 -3.351D-02 2.728D-02 0.000D+00 7.162D+01 0.000D+00 0.000D+00 9.608D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.768D-01 -1.264D-02 -9.683D-02 -3.567D-01 8.024D+01 -8.239D-02 -2.047D+01 -3.928D-02 1.878D-02 -2.129D-01 -9.337D-03 -3.144D-02 -2.919D-01 -3.370D-02 8.873D-02 -4.458D-02 1.716D-02 0.000D+00 7.171D+01 0.000D+00 0.000D+00 8.571D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -9.696D-02 8.666D-01 1.687D+01 1.051D+00 -1.023D+02 2.966D+01 5.943D-01 -1.997D+01 2.253D-02 1.701D-01 8.371D-03 2.645D-02 2.560D-01 2.835D-02 -3.749D-02 3.635D-02 -7.741D-02 0.000D+00 -1.412D+02 0.000D+00 0.000D+00 -8.215D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.785D-03 -1.636D-02 1.847D-01 2.169D-01 -8.420D+00 7.003D-01 5.666D-02 6.623D+00 -4.999D+01 6.760D-02 3.946D+01 4.991D-03 8.983D-02 5.349D-03 0.000D+00 1.372D-02 3.855D-02 0.000D+00 -7.710D+00 0.000D+00 0.000D+00 -4.371D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.298D-04 -2.430D-04 2.718D-03 3.214D-03 -1.246D-01 1.037D-02 8.395D-04 9.812D-02 -6.666D-01 -6.657D-01 5.847D-01 6.654D-05 1.347D-03 7.131D-05 0.000D+00 2.057D-04 5.707D-04 0.000D+00 -1.144D-01 0.000D+00 0.000D+00 -6.359D-04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.207D+00 -6.717D+00 2.626D+01 1.249D+01 -1.269D+03 1.030D+02 7.480D+00 3.684D+01 2.854D-01 2.332D+00 -4.765D+01 3.406D-01 3.065D+00 3.624D-01 -4.343D-01 4.681D-01 5.727D+00 0.000D+00 -1.745D+03 0.000D+00 0.000D+00 -8.940D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.730D-02 -4.539D-01 -5.272D+01 1.988D+02 -2.809D+01 2.243D+00 1.794D-01 9.750D+00 -9.627D+00 -9.557D+00 3.848D+01 -5.001D+01 1.011D-01 1.203D-02 -4.686D-02 1.715D-02 1.392D-01 0.000D+00 -2.430D+01 0.000D+00 0.000D+00 -2.736D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.206D-03 -2.017D-02 -2.343D+00 8.835D+00 -1.248D+00 9.975D-02 8.059D-03 4.333D-01 -4.278D-01 -4.245D-01 1.710D+00 -2.000D+00 -1.996D+00 5.349D-04 -1.999D-03 7.544D-04 6.172D-03 0.000D+00 -1.082D+00 0.000D+00 0.000D+00 -1.183D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.613D-01 -2.469D-01 -2.405D+01 2.338D+01 1.483D+02 1.638D+00 1.385D-01 4.488D+00 -4.414D+00 -4.354D+00 1.766D+01 -3.113D+00 -3.018D+00 -1.977D+01 -4.999D-02 1.509D-02 6.777D-02 0.000D+00 1.660D+01 0.000D+00 0.000D+00 3.980D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.244D-02 3.020D-02 -1.198D-01 -4.821D-02 5.575D+00 -4.525D-01 1.981D+01 1.249D-01 -1.127D-03 -6.760D-03 1.835D-02 -9.981D-04 -1.347D-02 -1.070D-03 -2.000D+01 -2.057D-03 1.880D-03 0.000D+00 9.147D+00 0.000D+00 0.000D+00 -8.241D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.653D+00 1.831D+00 -3.822D+00 1.134D+02 3.414D+02 -2.734D+01 -2.040D+00 -6.166D-01 5.004D-01 -1.437D-01 -2.416D+00 -1.073D-01 -1.078D+00 3.053D+01 1.989D+01 -5.016D+01 1.677D-01 0.000D+00 4.358D+02 0.000D+00 0.000D+00 -5.994D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.000D+02 -6.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.600D+03 -7.080D+02 -1.0672D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.200D+04 -5.240D+03 -1.500D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.330D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.330D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.450D-01 6.450D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.940D-01 -8.940D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.060D-01 -1.860D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.000D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.600D+03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.200D+04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 4.865D-01 -6.741D-01 5.392D+00 9.542D+01 2.403D+01 1.052D+01 8.190D-01 -4.492D-01 5.195D-01 8.437D-01 -1.863D+00 5.709D-02 4.815D-01 3.428D+00 2.161D+00 7.681D-02 -6.777D-02 0.000D+00 -4.205D+02 0.000D+00 0.000D+00 3.297D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.383D-02 2.789D-06 0.000D+00 0.000D+00 -1.081D-02 -5.545D-05 4.722D-05 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.282D-04 0.000D+00 3.353D-01 0.000D+00 0.000D+00 6.804D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 7.418D-05 5.496D-06 4.790D-06 1.478D-04 -1.504D-02 -6.503D-05 8.820D-05 4.999D-06 3.434D-06 2.727D-05 1.128D-06 4.002D-06 3.673D-05 4.290D-06 -4.958D-06 5.609D-06 1.030D-06 0.000D+00 -1.193D-02 0.000D+00 0.000D+00 -5.806D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.538D-05 1.201D-04 -2.579D-03 -1.609D-04 1.618D-02 -1.071D-03 -9.561D-05 -5.503D-06 -3.732D-06 -2.996D-05 -1.234D-06 -4.380D-06 -4.024D-05 -4.721D-06 5.324D-06 -6.103D-06 8.109D-06 0.000D+00 2.328D-02 0.000D+00 0.000D+00 1.178D-04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BB012091.dat000077500000000000000000000244141201767322700201330ustar00rootroot00000000000000 0.1015D+00 -0.1977D+02 0.1977D+02 0.1015D+00 -0.23202D-01 -0.92543D-01 0.92543D-01 -0.23202D-01 -0.3165D+00 -0.1433D+02 0.1433D+02 -0.3165D+00 -0.3892D+00 -0.2229D+02 0.2229D+02 -0.3892D+00 -0.9883D+00 -0.3616D+02 0.3616D+02 -0.9883D+00 -0.1342D+01 -0.2547D+01 0.2457D+01 -0.1342D+01 -0.2312D+01 -0.2151D+02 0.2151D+02 -0.2312D+01 -0.2792D+01 -0.2671D+02 0.2671D+02 -0.2792D+01 -0.2796D+01 -0.6379D+02 0.6379D+02 -0.2796D+01 -0.3332D+01 -0.5637D+02 0.5637D+02 -0.3332D+01 -0.3418D+01 -0.8867D+02 0.8867D+02 -0.3418D+01 -0.4441D+01 -0.6945D+02 0.6945D+02 -0.4441D+01 -0.5108D+01 -0.5339D+02 0.5339D+02 -0.5108D+01 -0.5199D+01 -0.5064D+02 0.5064D+02 -0.5199D+01 -0.5670D+01 -0.9296D+02 0.9296D+02 -0.5670D+01 -0.6197D+01 -0.4000D+02 0.4000D+02 -0.6197D+01 -0.8177D+01 -0.1661D+02 0.1661D+02 -0.8177D+01 -0.8221D+01 -0.1391D+03 0.1391D+03 -0.8221D+01 -0.1035D+02 -0.1630D+03 0.1630D+03 -0.1035D+02 -0.1172D+02 -0.1093D+03 0.1093D+03 -0.1172D+02 -0.1179D+02 -0.3046D+03 0.3046D+03 -0.1179D+02 -0.3327D+02 0.000D+00 0.000D+00 -0.2212D+03 -0.197D+04 0.6796D+01 -0.1334D+00 -0.1429D+04 0.1803D+02 -0.1517D+00 0.000D+00 -0.3158D+01 0.000D+00 0.000D+00 -0.2665D+04 0.7196D+01 -0.1568D+00 -0.2222D+04 -0.2684D+01 -0.50292D-01 0.000D+00 0.1779D+01 0.000D+00 0.000D+00 0.5869D+03 0.17334D-02 -0.43119D-04 0.119D+03 0.48611D-03 -7.4279D-06 0.000D+00 0.53132D-02 0.000D+00 0.000D+00 -0.5011D+03 0.41488D-02 -0.80848D-04 -0.1059D+03 0.10274D-02 -0.11816D-04 0.000D+00 0.80111D-02 0.000D+00 0.000D+00 0.1345D+03 -0.2690D+00 0.49694D-02 -0.1468D+03 -0.7097D+00 0.12317-02 0.000D+00 0.1066D+00 0.000D+00 0.000D+00 -0.1645D+03 0.4627D+00 -0.84320D-02 0.1960D+03 0.1345D+01 -0.39645D-02 0.000D+00 -0.4078D+00 0.000D+00 0.000D+00 0.6085D+03 -0.1835D+01 0.36978D-01 0.1751D+03 -0.1082D+01 0.11391D-01 0.000D+00 0.1001D+00 0.000D+00 0.000D+00 -0.7754D+02 0.1595D+00 -0.20525D-02 0.9616D+01 0.6370D+00 -0.28823D-02 0.000D+00 -0.1571D+00 0.000D+00 0.000D+00 -0.1117D+04 0.4615D+01 -0.84286D-01 -0.3414D+02 0.6425D+01 -0.49071D-01 0.000D+00 -0.1060D+01 0.000D+00 0.000D+00 0.1790D+04 -0.3752D+01 0.71871D-01 -0.2227D+03 0.1899D+01 -0.15192D-01 0.000D+00 0.4854D+00 0.000D+00 0.000D+00 -0.13858D+05 0.5550D+00 -0.12727D-01 -0.2014D+04 -0.50439D-01 0.10263D-02 0.000D+00 -0.2733D+01 0.000D+00 0.000D+00 0.15010D+05 -0.3138D+01 0.65016D-01 0.2668D+04 -0.1060D+01 0.11647D-01 0.000D+00 0.2067D+01 0.000D+00 0.000D+00 -0.21697D+05 0.6146D+02 -0.1286D+01 -0.3652D+04 0.5074D+01 -0.1277D+00 0.000D+00 0.3001D+01 0.000D+00 0.000D+00 0.19966D+05 -0.5356D+02 0.1121D+01 0.2881D+04 -0.2677D+02 0.2540D+00 0.000D+00 0.3544D+01 0.000D+00 0.000D+00 -0.2861D+04 0.1314D+02 -0.2426D+00 -0.1080D+04 0.4849D+02 -0.3712D+00 0.000D+00 -0.7199D+01 0.000D+00 0.000D+00 0.6583D+04 -0.1932D+02 0.3841D+00 -0.3883D+04 -0.1293D+02 0.10825D-01 0.000D+00 0.7207D+01 0.000D+00 0.000D+00 -0.2212D+04 -0.1228D+02 0.1229D+00 -0.1647D+04 -0.5130D+01 0.20187D-01 0.000D+00 0.6186D+00 0.000D+00 0.000D+00 0.6321D+04 -0.2717D+02 0.2049D+00 -0.1045D+04 -0.1559D+02 0.64588D-01 0.000D+00 0.1076D+01 0.000D+00 0.000D+00 0.13964D+05 -0.1724D+02 0.35851D-01 0.5620D+03 -0.2548D+02 0.1072D+00 0.000D+00 0.2821D+01 0.000D+00 0.000D+00 0.2382D+04 -0.2008D+02 0.3605D+00 0.9026D+03 -0.1623D+01 0.77575D-01 0.000D+00 -0.7866D+00 0.000D+00 0.000D+00 -0.3037D+03 0.2624D+01 -0.1208D+00 0.1129D+04 0.4399D+01 -0.27240D-01 0.000D+00 -0.1111D+00 0.000D+00 0.000D+00 0.5428D+03 0.5789D+00 0.1194D+00 -0.1258D+04 -0.6993D+01 0.29297D-01 0.000D+00 0.1509D+01 0.000D+00 0.000D+00 -0.5271D+03 -0.3601D+02 0.3072D+00 -0.1267D+04 0.7583D+01 -0.65626D-02 0.000D+00 -0.3659D+00 0.000D+00 0.000D+00 0.2658D+04 0.3812D+01 -0.37101D-01 -0.4911D+02 -0.4347D+01 -0.84969D-02 0.000D+00 0.8635D+00 0.000D+00 0.000D+00 0.25341D+05 -0.3645D+02 0.4514D+00 0.4360D+04 -0.1313D+03 0.8394D+00 0.000D+00 0.7433D+01 0.000D+00 0.000D+00 0.6538D+04 -0.2856D+02 0.3244D+00 0.3790D+04 0.9071D+02 -0.3495D+00 0.000D+00 -0.1536D+02 0.000D+00 0.000D+00 0.42048D+05 -0.5943D+02 0.7558D+00 0.2501D+04 -0.1739D+02 0.1113D+00 0.000D+00 0.4570D+01 0.000D+00 0.000D+00 0.2106D+03 -0.3951D+02 0.5076D+00 -0.4704D+03 -0.1875D+02 0.1395D+00 0.000D+00 -0.2771D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.1251D+01 0.000D+00 0.000D+00 0.9942D+03 0.1357D+02 -0.21971D-01 0.8284D+03 0.1290D+02 -0.36967D-01 0.000D+00 -0.5031D+00 0.000D+00 0.000D+00 0.7692D+03 0.1060D+02 -0.92043D-01 0.810D+03 0.1907D+02 -0.81012D-01 0.000D+00 -0.4524D+00 0.000D+00 0.000D+00 0.42702D+05 -0.1207D+03 0.1940D+01 -0.3077D+04 0.3590D+02 -0.2467D+00 0.000D+00 -0.1592D+01 0.000D+00 0.000D+00 -0.76982D+05 0.1406D+03 -0.2796D+01 -0.3483D+03 -0.3856D+02 0.1981D+00 0.000D+00 0.1956D+01 0.000D+00 0.000D+00 -0.2888D+03 -0.9428D+00 0.23831D-01 -0.1499D+04 0.9758D+00 -0.41943D-01 0.000D+00 -0.5981D+01 0.000D+00 0.000D+00 -0.2237D+04 0.8455D+01 -0.1565D+00 -0.6578D+04 0.4950D+02 -0.4980D+00 0.000D+00 -0.1088D+02 0.000D+00 0.000D+00 -0.16942D+05 0.9443D+02 -0.1144D+01 -0.6089D+02 0.2221D+00 -0.11955D-01 0.000D+00 -0.1121D+01 0.000D+00 0.000D+00 -0.12513D+05 0.6802D+02 -0.6821D+00 -0.2937D+02 0.4639D+00 -0.99611D-02 0.000D+00 0.1532D+00 0.000D+00 0.000D+00 0.5748D+04 -0.3578D+02 0.2067D+00 -0.3931D+02 -0.6830D+00 0.78189D-02 0.000D+00 -0.4254D+00 0.000D+00 0.000D+00 -0.14657D+05 0.2168D+03 -0.6615D+00 0.1234D+03 0.9043D+01 -0.87434D-01 0.000D+00 -0.7886D+00 0.000D+00 0.000D+00 -0.4089D+04 -0.2581D+03 -0.1059D+01 0.3303D+02 -0.2040D+01 0.23536D-01 0.000D+00 -0.1053D+00 0.000D+00 0.000D+00 0.7940D+04 0.309D+03 0.1175D+01 0.6104D+02 0.2311D+01 -0.28729D-01 0.000D+00 -0.2007D+01 0.000D+00 0.000D+00 0.9582D+04 0.3730D+02 -0.31126D-01 0.1409D+03 0.2627D+01 -0.18542D-01 0.000D+00 0.1886D+00 0.000D+00 0.000D+00 0.9474D+04 0.4140D+02 -0.50827D-01 0.1563D+03 0.3098D+01 -0.22171D-01 0.000D+00 0.92049D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -.1707D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.3783D+02 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.800D+06 -0.608D+05 -0.1060D+04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.160D+08 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.800D+06 -0.608D+05 -0.106D+04 0.000D+00 0.000D+00 0.000D+00 -0.160D+08 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.2668D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 -0.1033D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.200D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.200D+02 -2.804D+02 -1.892D+02 5.494D+01 6.424D+01 1.512D+02 9.386D+01 1.599D+02 7.045D+01 -1.180D+02 -2.986D+01 1.028D+02 1.018D+02 6.202D+00 -1.980D+01 -2.041D+02 -1.685D+02 3.807D+01 1.706D+01 2.375D+02 2.533D+02 7.799D+00 9.762D+01 -2.915D+01 5.759D+00 -3.332D+01 -7.012D+00 -1.035D+02 -1.396D+02 -1.590D+02 -3.260D+02 2.870D+02 1.471D+01 -1.149D+01 9.388D+01 2.032D+02 -1.189D+00 1.220D+00 1.539D+00 8.601D-01 3.222D+00 6.416D+00 6.052D-01 -5.647D-01 -9.782D+01 -1.384D+00 -1.0116D+04 -9.214D+03 1.9756D+04 2.1545D+04 1.3993D+04 1.7694D+04 -2.984D+03 -3.842D+03 -1.7279D+04 1.314D+03 3.2923D+04 3.3817D+04 -1.082D+03 3.076D+03 -3.8871D+04 -3.6494D+04 -7.038D+03 1.1182D+04 8.002D+03 1.035D+04 -5.7674D+04 -5.852D+04 -9.678D+03 -1.7572D+04 -4.136D+03 -4.930D+02 1.527D+02 -2.391D+03 -5.4007D+04 1.4065D+04 -1.8204D+04 -4.219D+03 -1.617D+03 4.2055D+04 3.361D+04 9.583D+01 -5.303D+02 -4.239D+02 -8.047D+01 5.805D+02 6.674D+02 -2.059D+01 2.840D+01 -3.2517D+04 -1.345D+03 -3.5918D+04 -1.8298D+04 1.444D+03 2.675D+03 1.6733D+04 7.989D+03 3.4725D+04 1.1489D+04 3.528D+03 9.170D+03 3.849D+03 3.825D+03 -3.369D+03 -1.0423D+04 -4.762D+03 -1.033D+03 -8.833D-01 4.619D+03 3.448D+03 1.303D+03 -1.6288D+04 9.174D+02 -6.520D+03 -4.420D+03 1.3953D+04 1.0935D+04 -1.2971D+04 2.265D+03 -6.697D+03 -6.6463D+04 5.9803D+04 -4.749D+03 -3.525D+03 -6.148D+03 2.489D+04 1.376D+02 -1.595D+03 -2.912D+03 -2.036D+02 2.433D+03 3.134D+03 -1.706D+02 2.024D+02 -1.4519D+04 -6.912D+02 -1.008D+00 -5.628D+00 2.226D+01 2.473D+01 5.633D+00 1.759D+01 6.685D+00 -1.131D+00 -1.783D+01 -4.323D+00 3.701D+01 3.872D+01 -4.403D+00 -3.027D+00 -2.742D+01 -2.376D+01 -1.345D+01 2.659D+00 -4.980D+01 -4.830D+01 -3.752D+01 -3.655D+01 3.951D+00 -4.938D+00 6.345D+00 5.479D+00 2.588D+01 3.474D+01 -6.223D+01 -1.069D+01 1.005D+01 -1.666D+01 -2.834D+00 5.584D+01 2.873D+01 2.784D-01 -1.598D+00 -2.559D+00 -3.003D-01 1.781D+00 2.065D+00 -1.941D-01 2.183D-01 -3.576D+01 -1.258D+00 8.616D+03 -5.767D+02 1.146D+03 1.214D+03 -8.700D+02 3.613D+03 -3.028D+03 1.084D+03 8.362D+03 5.560D+03 1.935D+03 2.152D+03 8.302D+02 -8.823D+02 1.1555D+04 9.656D+03 6.609D+02 2.046D+03 8.408D+03 7.455D+03 -6.012D+03 -5.724D+03 -3.113D+03 -2.967D+03 1.288D+03 5.832D+02 -6.625D+03 -5.544D+03 -2.987D+03 2.461D+03 -3.217D+03 2.832D+03 3.242D+02 7.562D+03 -1.2172D+04 9.422D+00 -2.731D+01 5.400D-01 -7.739D-01 1.479D+01 5.506D+00 -2.632D+00 2.610D+00 1.184D+03 -3.855D+01 -3.685D+03 1.359D+03 5.464D+02 6.059D+02 7.167D+01 -1.539D+03 2.550D+03 -5.998D+02 2.060D+03 1.803D+03 7.868D+02 9.115D+02 -8.997D+02 -5.404D+02 -1.427D+03 -1.640D+03 -6.931D+02 3.405D+03 1.955D+03 5.308D+02 -1.239D+03 -1.711D+03 -5.337D+03 -5.925D+03 7.784D+03 6.242D+03 -8.377D+03 -2.130D+03 -2.052D+03 8.424D+03 -8.033D+03 1.596D+02 -1.013D+03 -4.374D+03 9.713D+03 -4.164D+01 -7.796D+00 2.011D+01 2.514D+01 5.685D+01 -2.029D+02 1.613D+00 1.493D+00 -7.454D+03 -4.712D+02 slicot-5.0+20101122/benchmark_data/BB012092.dat000077500000000000000000000206251201767322700201340ustar00rootroot00000000000000 0.1015D+00 -0.1977D+02 0.1977D+02 0.1015D+00 -0.23202D-01 -0.92543D-01 0.92543D-01 -0.23202D-01 -0.3165D+00 -0.1433D+02 0.1433D+02 -0.3165D+00 -0.3892D+00 -0.2229D+02 0.2229D+02 -0.3892D+00 -0.9883D+00 -0.3616D+02 0.3616D+02 -0.9883D+00 -0.1342D+01 -0.2547D+01 0.2457D+01 -0.1342D+01 -0.2312D+01 -0.2151D+02 0.2151D+02 -0.2312D+01 -0.2792D+01 -0.2671D+02 0.2671D+02 -0.2792D+01 -0.2796D+01 -0.6379D+02 0.6379D+02 -0.2796D+01 -0.3332D+01 -0.5637D+02 0.5637D+02 -0.3332D+01 -0.3418D+01 -0.8867D+02 0.8867D+02 -0.3418D+01 -0.4441D+01 -0.6945D+02 0.6945D+02 -0.4441D+01 -0.5108D+01 -0.5339D+02 0.5339D+02 -0.5108D+01 -0.5199D+01 -0.5064D+02 0.5064D+02 -0.5199D+01 -0.5670D+01 -0.9296D+02 0.9296D+02 -0.5670D+01 -0.6197D+01 -0.4000D+02 0.4000D+02 -0.6197D+01 -0.8177D+01 -0.1661D+02 0.1661D+02 -0.8177D+01 -0.8221D+01 -0.1391D+03 0.1391D+03 -0.8221D+01 -0.1035D+02 -0.1630D+03 0.1630D+03 -0.1035D+02 -0.1172D+02 -0.1093D+03 0.1093D+03 -0.1172D+02 -0.1179D+02 -0.3046D+03 0.3046D+03 -0.1179D+02 -0.3327D+02 0.000D+00 0.000D+00 -0.2212D+03 -0.197D+04 0.6796D+01 -0.1334D+00 -0.1429D+04 0.1803D+02 -0.1517D+00 0.000D+00 -0.3158D+01 0.000D+00 0.000D+00 -0.2665D+04 0.7196D+01 -0.1568D+00 -0.2222D+04 -0.2684D+01 -0.50292D-01 0.000D+00 0.1779D+01 0.000D+00 0.000D+00 0.5869D+03 0.17334D-02 -0.43119D-04 0.119D+03 0.48611D-03 -7.4279D-06 0.000D+00 0.53132D-02 0.000D+00 0.000D+00 -0.5011D+03 0.41488D-02 -0.80848D-04 -0.1059D+03 0.10274D-02 -0.11816D-04 0.000D+00 0.80111D-02 0.000D+00 0.000D+00 0.1345D+03 -0.2690D+00 0.49694D-02 -0.1468D+03 -0.7097D+00 0.12317-02 0.000D+00 0.1066D+00 0.000D+00 0.000D+00 -0.1645D+03 0.4627D+00 -0.84320D-02 0.1960D+03 0.1345D+01 -0.39645D-02 0.000D+00 -0.4078D+00 0.000D+00 0.000D+00 0.6085D+03 -0.1835D+01 0.36978D-01 0.1751D+03 -0.1082D+01 0.11391D-01 0.000D+00 0.1001D+00 0.000D+00 0.000D+00 -0.7754D+02 0.1595D+00 -0.20525D-02 0.9616D+01 0.6370D+00 -0.28823D-02 0.000D+00 -0.1571D+00 0.000D+00 0.000D+00 -0.1117D+04 0.4615D+01 -0.84286D-01 -0.3414D+02 0.6425D+01 -0.49071D-01 0.000D+00 -0.1060D+01 0.000D+00 0.000D+00 0.1790D+04 -0.3752D+01 0.71871D-01 -0.2227D+03 0.1899D+01 -0.15192D-01 0.000D+00 0.4854D+00 0.000D+00 0.000D+00 -0.13858D+05 0.5550D+00 -0.12727D-01 -0.2014D+04 -0.50439D-01 0.10263D-02 0.000D+00 -0.2733D+01 0.000D+00 0.000D+00 0.15010D+05 -0.3138D+01 0.65016D-01 0.2668D+04 -0.1060D+01 0.11647D-01 0.000D+00 0.2067D+01 0.000D+00 0.000D+00 -0.21697D+05 0.6146D+02 -0.1286D+01 -0.3652D+04 0.5074D+01 -0.1277D+00 0.000D+00 0.3001D+01 0.000D+00 0.000D+00 0.19966D+05 -0.5356D+02 0.1121D+01 0.2881D+04 -0.2677D+02 0.2540D+00 0.000D+00 0.3544D+01 0.000D+00 0.000D+00 -0.2861D+04 0.1314D+02 -0.2426D+00 -0.1080D+04 0.4849D+02 -0.3712D+00 0.000D+00 -0.7199D+01 0.000D+00 0.000D+00 0.6583D+04 -0.1932D+02 0.3841D+00 -0.3883D+04 -0.1293D+02 0.10825D-01 0.000D+00 0.7207D+01 0.000D+00 0.000D+00 -0.2212D+04 -0.1228D+02 0.1229D+00 -0.1647D+04 -0.5130D+01 0.20187D-01 0.000D+00 0.6186D+00 0.000D+00 0.000D+00 0.6321D+04 -0.2717D+02 0.2049D+00 -0.1045D+04 -0.1559D+02 0.64588D-01 0.000D+00 0.1076D+01 0.000D+00 0.000D+00 0.13964D+05 -0.1724D+02 0.35851D-01 0.5620D+03 -0.2548D+02 0.1072D+00 0.000D+00 0.2821D+01 0.000D+00 0.000D+00 0.2382D+04 -0.2008D+02 0.3605D+00 0.9026D+03 -0.1623D+01 0.77575D-01 0.000D+00 -0.7866D+00 0.000D+00 0.000D+00 -0.3037D+03 0.2624D+01 -0.1208D+00 0.1129D+04 0.4399D+01 -0.27240D-01 0.000D+00 -0.1111D+00 0.000D+00 0.000D+00 0.5428D+03 0.5789D+00 0.1194D+00 -0.1258D+04 -0.6993D+01 0.29297D-01 0.000D+00 0.1509D+01 0.000D+00 0.000D+00 -0.5271D+03 -0.3601D+02 0.3072D+00 -0.1267D+04 0.7583D+01 -0.65626D-02 0.000D+00 -0.3659D+00 0.000D+00 0.000D+00 0.2658D+04 0.3812D+01 -0.37101D-01 -0.4911D+02 -0.4347D+01 -0.84969D-02 0.000D+00 0.8635D+00 0.000D+00 0.000D+00 0.25341D+05 -0.3645D+02 0.4514D+00 0.4360D+04 -0.1313D+03 0.8394D+00 0.000D+00 0.7433D+01 0.000D+00 0.000D+00 0.6538D+04 -0.2856D+02 0.3244D+00 0.3790D+04 0.9071D+02 -0.3495D+00 0.000D+00 -0.1536D+02 0.000D+00 0.000D+00 0.42048D+05 -0.5943D+02 0.7558D+00 0.2501D+04 -0.1739D+02 0.1113D+00 0.000D+00 0.4570D+01 0.000D+00 0.000D+00 0.2106D+03 -0.3951D+02 0.5076D+00 -0.4704D+03 -0.1875D+02 0.1395D+00 0.000D+00 -0.2771D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.1251D+01 0.000D+00 0.000D+00 0.9942D+03 0.1357D+02 -0.21971D-01 0.8284D+03 0.1290D+02 -0.36967D-01 0.000D+00 -0.5031D+00 0.000D+00 0.000D+00 0.7692D+03 0.1060D+02 -0.92043D-01 0.810D+03 0.1907D+02 -0.81012D-01 0.000D+00 -0.4524D+00 0.000D+00 0.000D+00 0.42702D+05 -0.1207D+03 0.1940D+01 -0.3077D+04 0.3590D+02 -0.2467D+00 0.000D+00 -0.1592D+01 0.000D+00 0.000D+00 -0.76982D+05 0.1406D+03 -0.2796D+01 -0.3483D+03 -0.3856D+02 0.1981D+00 0.000D+00 0.1956D+01 0.000D+00 0.000D+00 -0.2888D+03 -0.9428D+00 0.23831D-01 -0.1499D+04 0.9758D+00 -0.41943D-01 0.000D+00 -0.5981D+01 0.000D+00 0.000D+00 -0.2237D+04 0.8455D+01 -0.1565D+00 -0.6578D+04 0.4950D+02 -0.4980D+00 0.000D+00 -0.1088D+02 0.000D+00 0.000D+00 -0.16942D+05 0.9443D+02 -0.1144D+01 -0.6089D+02 0.2221D+00 -0.11955D-01 0.000D+00 -0.1121D+01 0.000D+00 0.000D+00 -0.12513D+05 0.6802D+02 -0.6821D+00 -0.2937D+02 0.4639D+00 -0.99611D-02 0.000D+00 0.1532D+00 0.000D+00 0.000D+00 0.5748D+04 -0.3578D+02 0.2067D+00 -0.3931D+02 -0.6830D+00 0.78189D-02 0.000D+00 -0.4254D+00 0.000D+00 0.000D+00 -0.14657D+05 0.2168D+03 -0.6615D+00 0.1234D+03 0.9043D+01 -0.87434D-01 0.000D+00 -0.7886D+00 0.000D+00 0.000D+00 -0.4089D+04 -0.2581D+03 -0.1059D+01 0.3303D+02 -0.2040D+01 0.23536D-01 0.000D+00 -0.1053D+00 0.000D+00 0.000D+00 0.7940D+04 0.309D+03 0.1175D+01 0.6104D+02 0.2311D+01 -0.28729D-01 0.000D+00 -0.2007D+01 0.000D+00 0.000D+00 0.9582D+04 0.3730D+02 -0.31126D-01 0.1409D+03 0.2627D+01 -0.18542D-01 0.000D+00 0.1886D+00 0.000D+00 0.000D+00 0.9474D+04 0.4140D+02 -0.50827D-01 0.1563D+03 0.3098D+01 -0.22171D-01 0.000D+00 0.92049D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -.1707D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.3783D+02 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.800D+06 -0.608D+05 -0.1060D+04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.160D+08 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.800D+06 -0.608D+05 -0.106D+04 0.000D+00 0.000D+00 0.000D+00 -0.160D+08 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.2668D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.100D+01 -0.1033D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.200D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -0.200D+02 0.44247D-04 0.43403D-04 0.49713D-04 0.45556D-04 -0.41311D-05 0.79201D-05 0.72496D-05 -0.67385D-04 -0.18236D-03 0.20657D-04 0.13194D-03 -0.15849D-03 -0.67655D-04 -0.87358D-05 -0.98119D-04 0.31119D-04 -0.57479D-04 0.31600D-03 -0.57750D-03 0.710D-03 -0.96843D-04 0.29934D-04 0.54014D-03 -0.47620D-03 -0.41630D-05 -0.21609D-03 -0.10541D-03 -0.31883D-04 -0.15062D-03 -0.27714D-03 -0.24361D-03 0.27990D-04 -0.16592D-03 0.12748D-04 -0.20762D-04 -0.12546D-03 -0.44360D-04 -0.10147D-04 0.15343D-03 0.21956D-04 -0.29386D-04 0.65513D-04 0.61813D-04 0.19995D-04 0.89674D-05 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.3592D+02 -0.1246D+02 -0.5332D+00 -0.5659D+00 -0.9664D+00 0.1275D+02 -0.2145D+02 0.6822D+01 0.3388D+02 0.170D+02 -0.1380D+00 -0.8803D+00 0.5465D+01 -0.1614D+01 0.5518D+02 0.3010D+02 -0.4878D+01 0.1436D+02 0.6254D+02 0.5518D+02 -0.1388D+03 -0.1044D+03 0.6831D+01 -0.1178D+02 -0.5504D+02 -0.3066D+02 0.1402D+01 -0.3033D+02 0.4869D+01 -0.7428D+02 0.7414D+02 0.1630D+02 0.3118D+01 0.8728D+01 -0.7453D+02 0.1460D+01 -0.3334D+01 -0.7367D+01 -0.1032D+01 0.2867D+01 0.6583D+01 -0.1361D+01 0.1350D+01 0.1071D+02 -0.2591D+02 0.4852D+02 -0.7932D+01 0.79915D-01 -2.5618D+04 -0.1674D+03 0.2213D+00 0.000D+00 0.1880D+01 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BB01404.dat000077500000000000000000000270141201767322700200460ustar00rootroot00000000000000 2.9550D+00 3.5220D+00 5.7100D-01 5.7480D-01 3.5260D+00 4.6870D+00 1.0930D+01 2.9280D+01 4.0600D+01 6.3200D+01 1.6250D+02 1.4820D+02 1.0950D+02 1.5150D+02 1.3660D+02 9.3210D+01 1.3600D+02 2.1390D+02 1.3590D+02 6.2020D+01 1.3590D+02 2.1390D+02 1.3600D+02 9.3210D+01 1.3660D+02 1.5150D+02 1.0950D+02 1.4820D+02 1.6250D+02 6.3200D+01 4.0600D+01 2.9280D+01 1.4930D+01 1.3900D+01 1.6310D+01 8.1750D+00 1.3920D+01 6.6290D+01 9.3490D+01 5.6390D+01 8.6550D+01 1.4250D+02 1.4250D+02 1.4250D+02 1.2870D+02 1.3550D+03 1.5450D+03 1.1330D+03 1.1450D+03 8.0850D+02 7.0230D+02 1.1610D+03 1.7350D+03 1.0810D+03 1.0790D+03 1.7330D+03 1.1610D+03 7.0230D+02 8.0850D+02 1.1450D+03 1.1330D+03 1.5450D+03 1.3550D+03 1.2930D+02 1.4330D+02 1.4290D+02 1.4290D+02 9.1940D+01 2.0530D+01 1.5440D+01 5.1350D+01 7.7030D+01 5.6390D+01 8.6550D+01 1.4250D+02 1.4250D+02 1.4250D+02 1.2870D+02 1.3550D+03 1.5450D+03 1.1330D+03 1.1450D+03 8.0850D+02 7.0230D+02 1.1610D+03 1.7350D+03 1.0810D+03 1.0790D+03 1.7330D+03 1.1610D+03 7.0230D+02 8.0850D+02 1.1450D+03 1.1330D+03 1.5450D+03 1.3550D+03 1.2930D+02 1.4330D+02 1.4290D+02 1.4290D+02 9.1940D+01 2.0530D+01 1.5440D+01 5.1350D+01 7.7030D+01 5.6390D+01 8.6550D+01 1.4250D+02 1.4250D+02 1.4250D+02 1.2870D+02 1.3550D+03 1.5450D+03 1.1330D+03 1.1450D+03 8.0850D+02 7.0230D+02 1.1610D+03 1.7350D+03 1.0810D+03 1.0790D+03 1.7330D+03 1.0800D+03 6.2140D+02 8.0850D+02 1.1450D+03 1.1330D+03 1.5450D+03 1.3550D+03 1.2930D+02 1.4330D+02 1.4290D+02 1.4290D+02 9.1940D+01 2.0530D+01 1.5440D+01 5.1350D+01 7.7030D+01 5.3430D+01 2.8930D+01 2.8700D+01 1.2170D+01 1.0490D+01 2.0910D+01 1.4170D+01 1.8100D+01 1.9340D+02 3.5800D+02 3.6550D+02 2.1500D+02 5.7920D+01 5.8830D+01 5.8710D+01 5.2240D+02 1.1110D+03 1.2360D+03 1.2360D+03 1.2360D+03 1.2360D+03 1.2360D+03 1.2360D+03 1.2360D+03 1.2360D+03 1.2360D+03 1.1110D+03 5.3110D+02 7.5980D+01 5.2150D+01 7.8270D+01 7.3890D+01 1.3490D+01 2.3640D+01 1.9960D+01 1.5250D+01 2.5600D+01 2.0250D+01 1.7600D+01 1.4670D+01 1.3860D+01 1.6420D+01 1.0730D+01 1.9540D+02 1.9510D+02 4.5050D+00 4.5050D+00 2.0150D+02 2.0180D+02 1.0770D+01 2.2210D+01 2.0810D+01 9.8920D+00 5.9760D+00 2.2660D+01 4.7660D+01 5.8400D+01 5.8400D+01 5.8400D+01 4.6450D+01 1.8090D+01 2.7010D+00 2.6630D+00 1.1830D+00 3.7580D-01 3.7890D-01 1.0910D+00 2.8540D+00 2.6890D+00 1.1020D+00 3.9100D+00 6.7180D+00 3.3590D+00 1.9238D+02 3.6315D+01 4.7517D+01 1.6335D+02 1.5109D+02 4.3267D+01 1.8937D+02 3.7326D+01 1.7896D+01 1.7413D+02 6.7660D+00 1.5201D+02 1.9613D+02 1.6710D+02 4.8820D+01 1.9540D+02 1.9285D+02 4.6122D+01 2.6812D+01 1.5125D+02 6.8707D+00 2.2951D+01 1.6795D+02 1.8293D+02 1.7276D+02 1.4878D+01 4.9082D+01 1.8801D+02 1.8919D+02 1.8591D+02 1.6766D+02 1.5213D+01 3.5992D+01 1.8050D+02 1.6060D+02 8.4097D+00 1.2996D+01 1.6170D+02 1.8851D+02 1.7533D+02 2.7095D+01 1.8518D+02 1.9239D+02 1.1417D+01 3.5198D+01 6.6343D+00 1.9885D+02 3.3450D+01 2.6675D+01 4.3575D+01 1.6747D+02 1.9831D+02 2.6289D+01 1.6667D+02 1.7021D+02 1.5372D+02 9.0594D+00 1.7020D+02 1.7937D+02 2.5006D+01 4.1631D+01 1.7030D+02 1.6682D+02 1.9183D+02 1.9064D+02 2.3481D+01 1.7817D+02 1.9702D+02 1.9335D+02 1.8920D-01 3.0443D+01 3.0077D+01 3.5862D+01 1.9506D+01 1.9847D+02 1.5119D+01 1.8239D+02 4.6140D+01 1.5540D+02 1.8506D+02 1.7753D+02 1.8612D+02 1.7412D+02 1.9733D+02 2.6134D+01 9.9049D+00 1.2642D+01 1.8329D+02 2.4384D+01 1.7840D+02 2.5351D+01 1.9118D+02 1.7983D+02 1.9718D+02 1.7521D+01 1.6172D+02 1.5284D+02 1.6681D+02 1.5863D+02 1.6305D+02 1.5817D+02 2.1338D+01 1.7823D+02 1.6406D+02 5.4544D+00 4.5576D+00 6.2370D-02 4.3802D+00 3.1098D+01 1.7249D+02 2.8568D+01 6.6547D+00 5.8487D+00 1.3915D+01 1.8036D+02 1.6810D+02 1.5310D+02 4.1672D+01 2.7644D+01 1.7064D+01 1.6678D+02 1.9801D+02 1.5956D+01 4.2715D+01 1.5400D+02 1.0345D+01 3.8248D+00 4.3148D+01 1.9073D+02 3.2006D+01 8.3148D+00 1.7662D+02 6.4585D+00 2.8963D+01 1.8543D+02 4.2003D+01 1.9418D+02 4.2220D+00 4.2741D+01 1.5159D+02 1.7658D+02 1.9738D+02 2.3626D+01 1.5592D+02 4.5147D+01 8.0555D+00 2.6912D+01 1.5229D+02 1.8645D+02 1.3804D+01 1.8003D+02 4.7601D+01 7.9650D-01 4.4751D+00 4.7443D+01 1.6274D+02 1.2855D+01 1.6873D+02 1.9893D+02 1.5587D+02 1.6137D+02 1.8996D+02 4.7426D+01 2.7964D+01 1.8297D+02 3.9547D+01 1.0834D+01 1.8350D+02 4.9398D+01 3.6386D+01 7.3201D+00 1.7057D+02 6.3739D+00 4.0509D+00 1.5037D+02 1.6899D+02 1.9244D+02 3.9725D+01 2.0234D+01 4.5742D+01 1.3059D+01 4.1785D+01 1.6869D+02 1.7463D+02 1.2709D+01 4.2516D+01 3.4237D+01 1.5519D+02 1.9222D+02 1.8793D+02 1.6793D+02 1.9464D+02 1.6068D+02 3.7760D+01 2.4005D+01 1.1795D+01 3.1123D+01 1.7377D+02 1.5560D-01 1.6782D+02 1.9981D+02 1.6626D+02 1.5660D+02 4.5001D+01 1.2195D+01 1.5192D+02 1.9770D+02 1.9470D+02 3.2964D+01 1.9621D+02 1.5796D+02 1.1174D+00 2.6801D+00 2.7096D+00 1.2350D+00 2.9470D+00 2.6230D+00 2.7711D+00 1.2201D+00 2.5364D+00 2.9768D+00 2.9783D+00 2.7861D+00 2.5543D+00 2.8597D+00 1.4500D+00 1.0907D+00 1.3592D+00 2.9970D+00 1.4492D+00 1.1918D+00 2.8851D+00 2.5735D+00 2.7799D+00 1.0970D+00 1.2393D+00 1.2415D+00 1.3658D+00 2.5831D+00 2.7609D+00 1.0859D+00 1.1270D+00 1.2696D+00 2.8901D+00 2.6439D+00 1.0347D+00 1.4846D+00 1.1322D+00 1.0912D+00 1.2275D+00 2.7355D+00 2.8856D+00 2.8081D+00 1.1063D+00 2.8387D+00 1.3266D+00 1.2365D+00 2.9889D+00 2.9255D+00 2.6296D+00 1.4455D+00 1.2367D+00 1.0633D+00 2.8015D+00 2.6669D+00 2.9680D+00 2.8141D+00 2.9371D+00 1.0517D+00 2.6601D+00 2.7449D+00 1.0258D+00 1.4307D+00 2.9317D+00 1.1359D+00 1.3285D+00 2.8134D+00 1.3040D+00 1.3049D+00 2.6290D+00 2.8316D+00 2.9673D+00 1.2211D+00 2.5416D+00 1.0901D+00 2.6388D+00 1.4560D+00 1.3363D+00 1.0081D+00 1.3459D+00 1.0743D+00 1.0016D+00 1.3541D+00 2.9660D+00 1.3737D+00 1.2595D+00 2.7387D+00 2.8745D+00 1.4971D+00 2.8246D+00 1.1113D+00 2.6093D+00 1.4248D+00 2.7140D+00 1.0152D+00 1.1875D+00 2.7333D+00 2.5131D+00 2.9279D+00 1.2667D+00 1.0718D+00 2.7685D+00 1.4374D+00 1.1874D+00 1.4937D+00 1.4818D+00 1.3820D+00 2.9445D+00 2.6594D+00 1.3545D+00 1.4864D+00 1.4257D+00 2.7693D+00 2.9487D+00 2.6158D+00 2.7605D+00 1.3918D+00 2.8155D+00 1.0879D+00 2.7937D+00 1.1873D+00 2.7189D+00 2.9178D+00 1.2006D+00 2.9836D+00 1.0986D+00 1.0130D+00 1.4041D+00 1.3504D+00 1.2546D+00 1.4850D+00 2.7999D+00 2.7611D+00 2.8130D+00 1.3885D+00 1.4319D+00 1.3827D+00 2.8198D+00 1.0304D+00 2.9609D+00 2.9144D+00 1.3731D+00 1.3285D+00 1.0274D+00 2.7656D+00 2.8193D+00 2.9153D+00 1.2339D+00 2.5363D+00 1.0626D+00 2.7146D+00 2.9224D+00 2.6348D+00 2.5823D+00 1.4515D+00 2.7762D+00 1.0200D+00 1.2205D+00 2.6964D+00 1.1805D+00 1.1392D+00 1.3832D+00 1.0066D+00 2.7906D+00 2.8989D+00 1.4231D+00 1.1972D+00 1.3212D+00 2.6349D+00 1.4823D+00 1.4615D+00 2.9703D+00 2.7019D+00 1.3364D+00 1.3257D+00 1.2995D+00 1.2982D+00 2.5427D+00 2.7056D+00 2.9918D+00 2.5784D+00 1.2453D+00 1.1891D+00 2.5660D+00 1.3947D+00 1.3114D+00 1.4196D+00 2.5289D+00 1.4400D+00 2.6184D+00 2.5096D+00 1.0799D+00 1.0875D+00 2.5014D+00 1.2124D+00 2.9088D+00 1.3743D+00 1.3992D+00 2.6545D+00 2.8616D+00 2.7189D+00 1.1648D+00 2.9727D+00 2.7438D+00 2.9488D+00 1.4140D+00 1.1471D+00 1.0455D+00 1.4344D+00 2.9155D+00 1.1845D+00 3.8230D+09 5.0550D+08 7.5320D+10 5.0010D+08 1.8880D+09 1.0960D+09 6.4730D+09 7.6840D+09 7.4120D+09 2.1430D+10 2.1330D+10 4.0640D+10 3.8010D+10 2.3310D+10 3.7550D+10 5.6830D+10 2.1700D+10 2.1480D+10 2.7780D+10 2.7780D+10 2.1480D+10 2.1700D+10 5.6830D+10 3.7550D+10 2.3310D+10 3.8010D+10 4.0640D+10 2.1330D+10 2.1430D+10 7.4120D+09 7.6840D+09 1.6030D+10 2.9380D+10 3.4270D+09 3.4720D+09 7.4930D+11 2.0610D+09 1.0800D+10 7.7840D+09 2.4630D+09 1.0040D+10 1.0740D+10 1.1270D+10 1.1270D+10 7.4090D+10 8.0430D+10 4.4560D+10 1.5910D+11 1.1590D+11 2.2600D+11 2.8050D+11 9.0800D+10 1.3200D+11 6.2130D+10 1.3200D+11 9.0800D+10 2.8050D+11 2.2600D+11 1.1590D+11 1.5910D+11 4.4560D+10 8.0430D+10 7.4090D+10 1.1170D+10 1.1230D+10 1.0710D+10 1.0010D+10 1.3900D+09 7.4930D+11 1.8500D+09 1.0760D+10 7.7840D+09 2.4630D+09 1.0040D+10 1.0740D+10 1.1270D+10 1.1270D+10 7.4090D+10 8.0430D+10 4.4560D+10 1.5910D+11 1.1590D+11 2.2600D+11 2.8050D+11 9.0800D+10 1.3200D+11 6.2130D+10 1.3200D+11 9.0800D+10 2.8050D+11 2.2600D+11 1.1590D+11 1.5910D+11 4.4560D+10 8.0430D+10 7.4090D+10 1.1170D+10 1.1230D+10 1.0710D+10 1.0010D+10 1.3900D+09 7.4930D+11 1.8500D+09 1.0760D+10 7.7840D+09 2.4630D+09 1.0040D+10 1.0740D+10 1.1270D+10 1.1270D+10 7.4090D+10 8.0430D+10 4.4560D+10 1.5910D+11 1.1590D+11 2.2600D+11 2.8050D+11 9.0800D+10 1.3200D+11 6.2130D+10 1.3200D+11 9.0800D+10 5.9210D+11 2.2600D+11 1.1590D+11 1.5910D+11 4.4560D+10 8.0430D+10 7.4090D+10 1.1170D+10 1.1230D+10 1.0710D+10 1.0010D+10 1.3900D+09 7.4930D+11 1.8500D+09 1.0760D+10 7.8800D+09 2.3340D+09 3.2290D+09 2.3780D+09 7.5850D+11 2.7580D+09 2.7580D+09 1.0270D+10 3.4830D+09 8.6900D+09 8.6900D+09 8.3510D+09 1.8540D+10 9.6190D+09 9.6190D+09 9.6580D+09 1.3790D+11 1.5710D+10 1.5710D+10 1.5710D+10 1.5710D+10 1.5710D+10 1.5710D+10 1.5710D+10 1.5710D+10 1.5710D+10 1.5710D+10 1.3790D+11 7.4480D+09 7.4480D+09 1.5730D+10 9.6950D+09 5.0360D+09 1.0060D+10 1.4130D+09 7.4050D+11 1.8510D+09 1.6340D+10 1.7200D+10 4.0690D+09 4.7160D+09 4.7160D+09 4.2200D+09 3.6810D+10 5.4540D+09 3.6810D+10 9.5120D+09 3.6810D+10 5.4540D+09 3.6810D+10 4.2200D+09 3.0270D+09 1.4630D+10 5.8490D+09 9.9690D+08 1.7970D+09 8.6870D+08 8.6870D+08 8.6870D+08 8.6870D+08 1.3720D+09 4.9440D+08 5.3780D+08 3.5650D+08 5.2500D+08 6.2470D+10 5.2060D+08 4.0390D+08 1.1870D+09 3.0910D+08 3.0910D+08 2.3870D+08 2.3870D+08 slicot-5.0+20101122/benchmark_data/BB02105.dat000077500000000000000000000003601201767322700200400ustar00rootroot00000000000000 .998D+00 .670D-01 .000D+00 .000D+00 -.670D-01 .998D+00 .000D+00 .000D+00 .000D+00 .000D+00 .998D+00 .153D+00 .000D+00 .000D+00 -.153D+00 .998D+00 .330D-02 .200D-01 .100D+00 -.700D-03 .400D-01 .730D-02 -.280D-02 .100D+00 slicot-5.0+20101122/benchmark_data/BB02106.dat000077500000000000000000000004401201767322700200400ustar00rootroot00000000000000 .98475D+00 -.79903D-01 .90540D-03 -.10765D-02 .41588D-01 .99899D+00 -.35855D-01 .12684D-01 -.54662D+00 .44916D-01 -.32991D+00 .19318D+00 .26624D+01 -.10045D+00 -.92455D+00 -.26325D+00 .37112D-02 .73610D-03 -.87051D-01 .93411D-05 -.119844D+01 -.41378D-03 -.31927D+01 .92535D-03 slicot-5.0+20101122/benchmark_data/BB02107.dat000077500000000000000000000005531201767322700200460ustar00rootroot00000000000000-.6000D+00 -.2200D+01 -.3600D+01 -.5400018D+01 .1000D+01 .6000D+00 .8000D+00 .3399982D+01 .0000D+00 .1000D+01 .1800D+01 .3799982D+01 .0000D+00 .0000D+00 .0000D+00 -.999982D+00 .1000D+01 -.1000D+01 -.1000D+01 -.1000D+01 .0000D+00 .1000D+01 -.1000D+01 -.1000D+01 .0000D+00 .0000D+00 .1000D+01 -.1000D+01 .0000D+00 .0000D+00 .0000D+00 .1000D+01 slicot-5.0+20101122/benchmark_data/BB02108.dat000077500000000000000000000006441201767322700200500ustar00rootroot00000000000000 .95407D+00 .19643D-01 .35970D-02 .67300D-03 .19000D-03 .40849D+00 .41317D+00 .16084D+00 .44679D-01 .11971D-01 .12217D+00 .26326D+00 .36149D+00 .15930D+00 .12383D+00 .41118D-01 .12858D+00 .27209D+00 .21442D+00 .40976D+00 .13050D-02 .58080D-02 .18750D-01 .36162D-01 .94280D+00 .43400D-03 -.12200D-03 .26606D-01 -.10453D-01 .37530D-01 -.55100D-01 .36076D-01 -.66000D-01 .46170D-02 -.91480D-02 slicot-5.0+20101122/benchmark_data/BB02110.dat000077500000000000000000000022461201767322700200410ustar00rootroot00000000000000 8.701D-1 1.350D-1 1.159D-2 5.014D-4 -3.722D-2 3.484D-4 0.000D0 4.242D-3 7.249D-3 7.655D-2 8.974D-1 1.272D-2 5.504D-4 -4.016D-2 3.743D-4 0.000D0 4.530D-3 7.499D-3 -1.272D-1 3.575D-1 8.170D-1 1.455D-3 -1.028D-1 9.870D-4 0.000D0 1.185D-2 1.872D-2 -3.635D-1 6.339D-1 7.491D-2 7.966D-1 -2.735D-1 2.653D-3 0.000D0 3.172D-2 4.882D-2 -9.600D-1 1.6459D0 -1.289D-1 -5.597D-3 7.142D-2 7.108D-3 0.000D0 8.452D-2 1.259D-1 -6.644D-1 1.1296D-1 -8.889D-2 -3.854D-3 8.447D-2 1.360D-2 0.000D0 1.443D-1 1.016D-1 -4.102D-1 6.930D-1 -5.471D-2 -2.371D-3 6.649D-2 1.249D-2 1.063D-4 9.997D-2 6.967D-2 -1.799D-1 3.017D-1 -2.393D-2 -1.035D-3 6.059D-2 2.216D-2 0.000D0 2.139D-1 3.554D-2 -3.451D-1 5.804D-1 -4.596D-2 -1.989D-3 1.056D-1 1.986D-2 0.000D0 2.191D-1 2.152D-1 4.760D-4 -5.701D-5 -8.368D-3 8.790D-5 -4.773D-4 -2.730D-4 1.482D-4 -1.312D-3 8.876D-4 3.892D-4 -3.513D-3 2.480D-3 1.034D-3 -9.275D-3 6.680D-3 7.203D-4 -6.159D-3 3.834D-3 4.454D-4 -3.683D-3 2.029D-3 1.971D-4 -1.554D-3 6.937D-4 3.773D-4 -3.028D-3 1.469D-3 slicot-5.0+20101122/benchmark_data/BB02111.dat000077500000000000000000000026331201767322700200420ustar00rootroot00000000000000.0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .2220D+00 .7780D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .4000D+00 .0000D+00 .6000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1372D+01 -.470000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.1500D+02 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.7000D+01 .5357D+01 .3943D+01 .0000D+00 .1000D+01 .1000D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0980D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 slicot-5.0+20101122/benchmark_data/BB02113.dat000077500000000000000000000147241201767322700200500ustar00rootroot00000000000000.0000D+00 -.4607D+00 .0000D+00 .0045D+00 .0000D+00 .1304D+00 .0000D+00 .0731D+00 .0000D+00 .0608D+00 .0000D+00 .0178D+00 .0000D+00 .0067D+00 .0000D+00 -.0090D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .14269D+01 .0000D+00 .0034D+00 .0000D+00 -.1702D+00 .0000D+00 -.0728D+00 .0000D+00 -.0527D+00 .0000D+00 -.0595D+00 .0000D+00 .0011D+00 .0000D+00 .0065D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0179D+00 .0000D+00 -.1242D+00 .0000D+00 -.1065D+00 .0000D+00 -.0351D+00 .0000D+00 -.0603D+00 .0000D+00 -.0939D+00 .0000D+00 .0004D+00 .0000D+00 .0693D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.0090D+00 .1000D+01 .10126D+01 .0000D+00 .2113D+00 .0000D+00 .0411D+00 .0000D+00 .0543D+00 .0000D+00 .0521D+00 .0000D+00 .0013D+00 .0000D+00 -.0728D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0406D+00 .0000D+00 -.2096D+00 .0000D+00 -.0777D+00 .0000D+00 .0492D+00 .0000D+00 -.0334D+00 .0000D+00 -.0421D+00 .0000D+00 -.0082D+00 .0000D+00 -.1448D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.0431D+00 .0000D+00 .1458D+00 .1000D+01 .11320D+01 .0000D+00 -.0392D+00 .0000D+00 .0343D+00 .0000D+00 .0290D+00 .0000D+00 .0002D+00 .0000D+00 .1535D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1253D+00 .0000D+00 .1610D+00 .0000D+00 .0953D+00 .0000D+00 -.6278D+00 .0000D+00 -.0066D+00 .0000D+00 .0144D+00 .0000D+00 .0047D+00 .0000D+00 .1116D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.1222D+00 .0000D+00 -.2340D+00 .0000D+00 -.0159D+00 .1000D+01 .15797D+01 .0000D+00 .0551D+00 .0000D+00 -.0192D+00 .0000D+00 -.0004D+00 .0000D+00 -.1173D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0086D+00 .0000D+00 -.1020D+00 .0000D+00 -.1038D+00 .0000D+00 .0057D+00 .0000D+00 .1812D+00 .0000D+00 -.0301D+00 .0000D+00 .0048D+00 .0000D+00 -.0517D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.0094D+00 .0000D+00 .1284D+00 .0000D+00 .0851D+00 .0000D+00 -.0079D+00 .1000D+01 .7771D+00 .0000D+00 .0253D+00 .0000D+00 .0081D+00 .0000D+00 .0529D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0095D+00 .0000D+00 -.0669D+00 .0000D+00 -.0342D+00 .0000D+00 .0658D+00 .0000D+00 -.0341D+00 .0000D+00 .2095D+00 .0000D+00 .0107D+00 .0000D+00 .0923D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0237D+00 .0000D+00 .0813D+00 .0000D+00 .0268D+00 .0000D+00 -.0848D+00 .0000D+00 .0164D+00 .1000D+01 .6173D+00 .0000D+00 -.0138D+00 .0000D+00 -.0945D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0189D+00 .0000D+00 -.3275D+00 .0000D+00 -.1496D+00 .0000D+00 .0689D+00 .0000D+00 -.1201D+00 .0000D+00 .1359D+00 .0000D+00 .3119D+00 .0000D+00 -.0085D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.0059D+00 .0000D+00 .2417D+00 .0000D+00 .1944D+00 .0000D+00 -.0739D+00 .0000D+00 .3157D+00 .0000D+00 .1776D+00 .1000D+01 .3995D+00 .0000D+00 .0516D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.0373D+00 .0000D+00 .0986D+00 .0000D+00 -.1332D+00 .0000D+00 .0657D+00 .0000D+00 -.0546D+00 .0000D+00 .0440D+00 .0000D+00 -.0111D+00 .0000D+00 -.0391D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0610D+00 .0000D+00 -.0931D+00 .0000D+00 .1297D+00 .0000D+00 -.0714D+00 .0000D+00 .0254D+00 .0000D+00 -.0848D+00 .0000D+00 .0055D+00 .1000D+01 0.10233D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.1228D+00 .0000D+00 .20351D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .1000D+01 .8965D+00 .0000D+00 .30747D+01 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 -.0041D+00 .0000D+00 .2600D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0000D+00 .0042D+00 .1000D+01 .1704D+00 -.0026D+00 .1205D+00 -.0022D+00 -.0603D+00 .0091D+00 -.0362D+00 .0010D+00 -.0096D+00 .0038D+00 -.0378D+00 .0004D+00 .0019D+00 -.0025D+00 .0800D+00 -.0014D+00 -.0647D+00 .0188D+00 .0001D+00 -.0011D+00 .0399D+00 .0034D+00 -.0165D+00 .0057D+00 .0087D+00 -.0014D+00 .0547D+00 -.0205D+00 -.0001D+00 .0070D+00 -.0005D+00 -.0004D+00 .0105D+00 .0056D+00 -.0131D+00 -.0014D+00 .0023D+00 -.0086D+00 .0656D+00 .0191D+00 -.0307D+00 -.0617D+00 .0095D+00 -.0101D+00 .2088D+00 -.0095D+00 -.0300D+00 .0038D+00 .0086D+00 -.0033D+00 -.0021D+00 -.0294D+00 -.0086D+00 .0035D+00 -.0007D+00 .0013D+00 .0050D+00 .0187D+00 -.0022D+00 -.0013D+00 .0002D+00 .0081D+00 .0446D+00 -.0092D+00 .0964D+00 .0258D+00 -.0081D+00 .0244D+00 .1400D+00 .0039D+00 -.5574D+00 -.0419D+00 .0152D+00 .0147D+00 -.1752D+00 -.0013D+00 -.12201D+01 -.0057D+00 -.0014D+00 .0103D+00 .2547D+00 .0006D+00 .19353D+01 -.0402D+00 .0117D+00 .0008D+00 .1287D+00 .0077D+00 -.1102D+00 .0106D+00 .0075D+00 .0006D+00 .0210D+00 .0002D+00 .0126D+00 .0066D+00 .0004D+00 .0000D+00 .0901D+00 -.0152D+00 .0000D+00 -.2026D+00 .0000D+00 .0000D+00 .0810D+00 .0026D+00 .0000D+00 -.0255D+00 .0000D+00 .0000D+00 .0544D+00 .0011D+00 .0000D+00 -.0037D+00 .0000D+00 .0000D+00 -.0668D+00 -.0035D+00 .0000D+00 .0039D+00 .0000D+00 .000D+00 .100D+01 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .100D+01 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .100D+01 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .100D+01 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .100D+01 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .000D+00 .100D+01 .000D+00 .000D+00 .200D+01 .100D+01 .300D+01 .300D+01 .400D+01 .100D+01 .100D+00 .100D+00 .100D+02 .100D+00 .100D+02 .100D+01 slicot-5.0+20101122/benchmark_data/BD01103.dat000077500000000000000000000004501201767322700200370ustar00rootroot00000000000000 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.890D+00 3.900D-01 -5.530D+00 0.000D+00 -3.400D-02 -2.980D+00 2.430D+00 3.400D-02 -1.100D-03 -9.900D-01 -2.100D-01 0.000D+00 0.000D+00 3.600D-01 -1.600D+00 -9.500D-01 -3.200D-02 3.000D-02 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01104.dat000077500000000000000000000017111201767322700200410ustar00rootroot00000000000000 -9.910D-01 5.290D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.220D-01 -1.051D+00 5.960D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.220D-01 -1.118D+00 5.960D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.220D-01 -1.548D+00 7.180D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.640D+00 7.990D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.721D+00 9.010D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.823D+00 1.021D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.220D-01 -1.943D+00 3.840D-03 -2.880D-03 4.000D-03 -3.040D-03 3.760D-02 -2.800D-03 3.080D-03 -2.320D-03 2.360D-03 -3.320D-03 2.880D-03 -3.820D-03 3.080D-03 -4.120D-03 3.000D-03 -3.960D-03 slicot-5.0+20101122/benchmark_data/BD01105.dat000077500000000000000000000024401201767322700200420ustar00rootroot00000000000000 -4.019D+00 5.120D+00 0.000D+00 0.000D+00 -2.082D+00 0.000D+00 0.000D+00 0.000D+00 8.700D-01 -3.460D-01 9.860D-01 0.000D+00 0.000D+00 -2.340D+00 0.000D+00 0.000D+00 0.000D+00 9.700D-01 -7.909D+00 1.5407D+01 -4.069D+00 0.000D+00 -6.450D+00 0.000D+00 0.000D+00 0.000D+00 2.680D+00 -2.1816D+01 3.5606D+01 -3.390D-01 -3.870D+00 -1.780D+01 0.000D+00 0.000D+00 0.000D+00 7.390D+00 -6.0196D+01 9.8188D+01 -7.907D+00 3.400D-01 -5.3008D+01 0.000D+00 0.000D+00 0.000D+00 2.040D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.400D+01 -1.472D+02 0.000D+00 5.320D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.400D+01 -1.472D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.280D+01 0.000D+00 -3.160D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.280D+01 0.000D+00 0.000D+00 1.880D+01 -3.160D+01 1.000D-02 -1.100D-02 -1.510D-01 3.000D-03 -2.100D-02 0.000D+00 9.000D-03 -5.900D-02 0.000D+00 2.400D-02 -1.620D-01 0.000D+00 6.800D-02 -4.450D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01106.dat000077500000000000000000000322211201767322700200430ustar00rootroot00000000000000 -4.328D+00 1.714D-01 5.376D+00 4.016D+02 -7.246D+02 -1.933D+00 1.020D+00 -9.820D-01 9.990D-01 1.521D+00 -4.062D+00 9.567D+00 1.008D+01 -6.017D-01 -1.312D-01 9.602D-02 -4.570D-02 0.000D+00 -4.516D+02 0.000D+00 0.000D+00 -1.058D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.402D-01 -5.643D+00 1.275D+02 -2.335D+02 -4.343D+02 2.659D+01 2.040D+00 -2.592D+00 1.132D+01 1.090D+01 -4.071D+00 -5.739D-02 -6.063D-01 -7.488D-02 -5.936D-01 -9.602D-02 1.114D-01 0.000D+00 -5.461D+02 0.000D+00 0.000D+00 -6.575D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.038D+00 6.073D+00 -1.650D+02 -4.483D+00 1.049D+03 -8.245D+01 -5.314D+00 5.097D+00 -9.389D-03 1.352D-01 5.638D+00 2.246D-02 1.797D-01 2.407D-02 1.100D+00 2.743D-02 2.153D-01 0.000D+00 1.362D+03 0.000D+00 0.000D+00 1.346D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.304D-01 -1.086D-01 1.313D+02 -5.783D+02 1.020D+02 -9.240D+00 -1.146D+00 -2.408D+00 -3.081D+00 -4.529D+00 5.707D+00 -2.346D-01 -2.111D+00 -2.460D-01 -4.686D-01 -3.223D-01 3.262D-01 0.000D+00 2.080D+02 0.000D+00 0.000D+00 -2.888D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.476D-03 -1.563D-02 5.602D-02 1.573D+00 -1.005D+01 1.952D-01 -8.804D-03 -2.110D-02 2.090D-03 -5.256D-02 -4.077D-02 -9.182D-03 -5.178D-02 3.425D-02 4.995D-03 -1.256D-02 9.948D-03 0.000D+00 -9.839D+01 0.000D+00 0.000D+00 5.069D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.350D-01 -1.249D-02 -3.567D-02 -6.074D-01 3.765D+01 -1.979D+01 -1.813D-01 -2.952D-02 -1.953D-02 -1.622D-01 -6.439D-03 -2.346D-02 -2.201D-01 -2.514D-02 -3.749D-03 -3.351D-02 2.728D-02 0.000D+00 7.162D+01 0.000D+00 0.000D+00 9.608D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.768D-01 -1.264D-02 -9.683D-02 -3.567D-01 8.024D+01 -8.239D-02 -2.047D+01 -3.928D-02 1.878D-02 -2.129D-01 -9.337D-03 -3.144D-02 -2.919D-01 -3.370D-02 8.873D-02 -4.458D-02 1.716D-02 0.000D+00 7.171D+01 0.000D+00 0.000D+00 8.571D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -9.696D-02 8.666D-01 1.687D+01 1.051D+00 -1.023D+02 2.966D+01 5.943D-01 -1.997D+01 2.253D-02 1.701D-01 8.371D-03 2.645D-02 2.560D-01 2.835D-02 -3.749D-02 3.635D-02 -7.741D-02 0.000D+00 -1.412D+02 0.000D+00 0.000D+00 -8.215D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.785D-03 -1.636D-02 1.847D-01 2.169D-01 -8.420D+00 7.003D-01 5.666D-02 6.623D+00 -4.999D+01 6.760D-02 3.946D+01 4.991D-03 8.983D-02 5.349D-03 0.000D+00 1.372D-02 3.855D-02 0.000D+00 -7.710D+00 0.000D+00 0.000D+00 -4.371D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.298D-04 -2.430D-04 2.718D-03 3.214D-03 -1.246D-01 1.037D-02 8.395D-04 9.812D-02 -6.666D-01 -6.657D-01 5.847D-01 6.654D-05 1.347D-03 7.131D-05 0.000D+00 2.057D-04 5.707D-04 0.000D+00 -1.144D-01 0.000D+00 0.000D+00 -6.359D-04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.207D+00 -6.717D+00 2.626D+01 1.249D+01 -1.269D+03 1.030D+02 7.480D+00 3.684D+01 2.854D-01 2.332D+00 -4.765D+01 3.406D-01 3.065D+00 3.624D-01 -4.343D-01 4.681D-01 5.727D+00 0.000D+00 -1.745D+03 0.000D+00 0.000D+00 -8.940D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.730D-02 -4.539D-01 -5.272D+01 1.988D+02 -2.809D+01 2.243D+00 1.794D-01 9.750D+00 -9.627D+00 -9.557D+00 3.848D+01 -5.001D+01 1.011D-01 1.203D-02 -4.686D-02 1.715D-02 1.392D-01 0.000D+00 -2.430D+01 0.000D+00 0.000D+00 -2.736D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.206D-03 -2.017D-02 -2.343D+00 8.835D+00 -1.248D+00 9.975D-02 8.059D-03 4.333D-01 -4.278D-01 -4.245D-01 1.710D+00 -2.000D+00 -1.996D+00 5.349D-04 -1.999D-03 7.544D-04 6.172D-03 0.000D+00 -1.082D+00 0.000D+00 0.000D+00 -1.183D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.613D-01 -2.469D-01 -2.405D+01 2.338D+01 1.483D+02 1.638D+00 1.385D-01 4.488D+00 -4.414D+00 -4.354D+00 1.766D+01 -3.113D+00 -3.018D+00 -1.977D+01 -4.999D-02 1.509D-02 6.777D-02 0.000D+00 1.660D+01 0.000D+00 0.000D+00 3.980D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.244D-02 3.020D-02 -1.198D-01 -4.821D-02 5.575D+00 -4.525D-01 1.981D+01 1.249D-01 -1.127D-03 -6.760D-03 1.835D-02 -9.981D-04 -1.347D-02 -1.070D-03 -2.000D+01 -2.057D-03 1.880D-03 0.000D+00 9.147D+00 0.000D+00 0.000D+00 -8.241D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.653D+00 1.831D+00 -3.822D+00 1.134D+02 3.414D+02 -2.734D+01 -2.040D+00 -6.166D-01 5.004D-01 -1.437D-01 -2.416D+00 -1.073D-01 -1.078D+00 3.053D+01 1.989D+01 -5.016D+01 1.677D-01 0.000D+00 4.358D+02 0.000D+00 0.000D+00 -5.994D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.000D+02 -6.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.600D+03 -7.080D+02 -1.0672D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.200D+04 -5.240D+03 -1.500D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.330D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.330D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.450D-01 6.450D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.940D-01 -8.940D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.060D-01 -1.860D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.000D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.600D+03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.200D+04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 4.865D-01 -6.741D-01 5.392D+00 9.542D+01 2.403D+01 1.052D+01 8.190D-01 -4.492D-01 5.195D-01 8.437D-01 -1.863D+00 5.709D-02 4.815D-01 3.428D+00 2.161D+00 7.681D-02 -6.777D-02 0.000D+00 -4.205D+02 0.000D+00 0.000D+00 3.297D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.383D-02 2.789D-06 0.000D+00 0.000D+00 -1.081D-02 -5.545D-05 4.722D-05 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.282D-04 0.000D+00 3.353D-01 0.000D+00 0.000D+00 6.804D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 7.418D-05 5.496D-06 4.790D-06 1.478D-04 -1.504D-02 -6.503D-05 8.820D-05 4.999D-06 3.434D-06 2.727D-05 1.128D-06 4.002D-06 3.673D-05 4.290D-06 -4.958D-06 5.609D-06 1.030D-06 0.000D+00 -1.193D-02 0.000D+00 0.000D+00 -5.806D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.538D-05 1.201D-04 -2.579D-03 -1.609D-04 1.618D-02 -1.071D-03 -9.561D-05 -5.503D-06 -3.732D-06 -2.996D-05 -1.234D-06 -4.380D-06 -4.024D-05 -4.721D-06 5.324D-06 -6.103D-06 8.109D-06 0.000D+00 2.328D-02 0.000D+00 0.000D+00 1.178D-04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01107.dat000077500000000000000000000034711201767322700200510ustar00rootroot00000000000000 -1.400D-02 4.300D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.500D-03 -1.380D-02 4.600D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.000D-04 0.000D+00 9.500D-03 -1.410D-02 6.300D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.000D-04 0.000D+00 0.000D+00 9.500D-03 -1.580D-02 1.100D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.500D-03 -3.120D-02 1.500D-02 2.200D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.020D-02 -3.520D-02 2.200D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.020D-02 -4.220D-02 2.800D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.020D-02 -4.820D-02 3.700D-02 0.000D+00 2.000D-04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.020D-02 -5.720D-02 4.200D-02 5.000D-04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.020D-02 -4.830D-02 5.000D-04 2.550D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.550D-02 -1.850D-02 0.000D+00 0.000D+00 0.000D+00 5.000D-06 -4.000D-05 2.500D-03 2.000D-06 -2.000D-05 5.000D-03 1.000D-06 -1.000D-05 5.000D-03 0.000D+00 0.000D+00 5.000D-03 0.000D+00 0.000D+00 5.000D-03 -5.000D-06 1.000D-05 5.000D-03 -1.000D-05 3.000D-05 5.000D-03 -4.000D-05 5.000D-06 2.500D-03 -2.000D-05 2.000D-06 2.500D-03 4.600D-04 4.600D-04 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01108.dat000077500000000000000000000024211201767322700200440ustar00rootroot00000000000000 -3.930D+00 -3.150D-03 0.000D+00 0.000D+00 0.000D+00 4.030D-05 0.000D+00 0.000D+00 0.000D+00 3.680D+02 -3.050D+00 3.030D+00 0.000D+00 0.000D+00 -3.770D-03 0.000D+00 0.000D+00 0.000D+00 2.740D+01 7.870D-02 -5.960D-02 0.000D+00 0.000D+00 -2.810D-04 0.000D+00 0.000D+00 0.000D+00 -6.470D-02 -5.200D-05 0.000D+00 -2.550D-01 -3.350D-06 3.600D-07 6.330D-05 1.940D-04 0.000D+00 3.850D+03 1.730D+01 -1.280D+01 -1.260D+04 -2.910D+00 -1.050D-01 1.270D+01 4.310D+01 0.000D+00 2.240D+04 1.800D+01 0.000D+00 -3.560D+01 -1.040D-04 -4.140D-01 9.000D+01 5.690D+01 0.000D+00 0.000D+00 0.000D+00 2.340D-03 0.000D+00 0.000D+00 2.220D-04 -2.030D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.270D+00 1.000D-03 7.860D-05 0.000D+00 -7.170D-02 0.000D+00 -2.200D+00 -1.770D-03 0.000D+00 -8.440D+00 -1.110D-04 1.380D-05 1.490D-03 6.020D-03 -1.000D-10 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.560D+00 0.000D+00 0.000D+00 0.000D+00 -5.130D-06 0.000D+00 8.280D+00 -1.500D+00 3.950D-02 0.000D+00 1.780D+00 0.000D+00 2.330D+00 0.000D+00 0.000D+00 0.000D+00 -2.450D-02 2.840D-03 0.000D+00 2.940D-05 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01109.dat000077500000000000000000001124521201767322700200530ustar00rootroot00000000000000 1.015D-01 -1.977D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.970D+03 6.796D+00 -1.334D-01 -1.429D+03 1.803D+01 -1.517D-01 0.000D+00 -3.158D+00 0.000D+00 0.000D+00 1.977D+01 1.015D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.665D+03 7.196D+00 -1.568D-01 -2.222D+03 -2.684D+00 -5.0292D-02 0.000D+00 1.779D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.3202D-02 -9.2543D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.869D+02 1.7334D-03 -4.3119D-05 1.190D+02 4.8611D-04 -7.4279D-06 0.000D+00 5.3132D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.2543D-02 -2.3202D-02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.011D+02 4.1488D-03 -8.0848D-05 -1.059D+02 1.0274D-03 -1.1816D-05 0.000D+00 8.0111D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.165D-01 -1.433D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.345D+02 -2.690D-01 4.9694D-03 -1.468D+02 -7.097D-01 1.2317D-03 0.000D+00 1.066D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.433D+01 -3.165D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.645D+02 4.627D-01 -8.432D-03 1.960D+02 1.345D+00 -3.9645D-03 0.000D+00 -4.078D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.892D-01 -2.229D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.085D+02 -1.835D+00 3.6978D-02 1.751D+02 -1.082D+00 1.1391D-02 0.000D+00 1.001D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.229D+01 -3.892D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -7.754D+01 1.595D-01 -2.0525D-03 9.616D+00 6.370D-01 -2.8823D-03 0.000D+00 -1.571D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -9.883D-01 -3.616D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.117D+03 4.615D+00 -8.4286D-02 -3.414D+01 6.425D+00 -4.9071D-02 0.000D+00 -1.060D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.616D+01 -9.883D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.790D+03 -3.752D+00 7.1871D-02 -2.227D+02 1.899D+00 -1.5192D-02 0.000D+00 4.854D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.342D+00 -2.547D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.3858D+04 5.550D-01 -1.2727D-02 -2.014D+03 -5.0439D-02 1.0263D-03 0.000D+00 -2.733D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.457D+00 -1.342D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.501D+04 -3.138D+00 6.5016D-02 2.668D+03 -1.060D+00 1.1647D-02 0.000D+00 2.067D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.312D+00 -2.151D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.1697D+04 6.146D+01 -1.286D+00 -3.652D+03 5.074D+00 -1.277D-01 0.000D+00 3.001D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.151D+01 -2.312D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.9966D+04 -5.356D+01 1.121D+00 2.881D+03 -2.677D+01 2.540D-01 0.000D+00 3.544D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.792D+00 -2.671D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.861D+03 1.314D+01 -2.426D-01 -1.080D+03 4.849D+01 -3.712D-01 0.000D+00 -7.199D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.671D+01 -2.792D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.583D+03 -1.932D+01 3.841D-01 -3.883D+03 -1.293D+01 1.0825D-02 0.000D+00 7.207D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.796D+00 -6.379D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.212D+03 -1.228D+01 1.229D-01 -1.647D+03 -5.130D+00 2.0187D-02 0.000D+00 6.186D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.379D+01 -2.796D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.321D+03 -2.717D+01 2.049D-01 -1.045D+03 -1.559D+01 6.4588D-02 0.000D+00 1.076D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.332D+00 -5.637D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.3964D+04 -1.724D+01 3.5851D-02 5.620D+02 -2.548D+01 1.072D-01 0.000D+00 2.821D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.637D+01 -3.332D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.382D+03 -2.008D+01 3.605D-01 9.026D+02 -1.623D+00 7.7575D-02 0.000D+00 -7.866D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.418D+00 -8.867D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.037D+02 2.624D+00 -1.208D-01 1.129D+03 4.399D+00 -2.724D-02 0.000D+00 -1.111D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.867D+01 -3.418D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.428D+02 5.789D-01 1.194D-01 -1.258D+03 -6.993D+00 2.9297D-02 0.000D+00 1.509D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.441D+00 -6.945D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.271D+02 -3.601D+01 3.072D-01 -1.267D+03 7.583D+00 -6.5626D-03 0.000D+00 -3.659D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.945D+01 -4.441D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.658D+03 3.812D+00 -3.7101D-02 -4.911D+01 -4.347D+00 -8.4969D-03 0.000D+00 8.635D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.108D+00 -5.339D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.5341D+04 -3.645D+01 4.514D-01 4.360D+03 -1.313D+02 8.394D-01 0.000D+00 7.433D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.339D+01 -5.108D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 6.538D+03 -2.856D+01 3.244D-01 3.790D+03 9.071D+01 -3.495D-01 0.000D+00 -1.536D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.199D+00 -5.064D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 4.2048D+04 -5.943D+01 7.558D-01 2.501D+03 -1.739D+01 1.113D-01 0.000D+00 4.570D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.064D+01 -5.199D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.106D+02 -3.951D+01 5.076D-01 -4.704D+02 -1.875D+01 1.395D-01 0.000D+00 -2.771D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.301D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.251D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.670D+00 -9.296D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.942D+02 1.357D+01 -2.1971D-02 8.284D+02 1.290D+01 -3.6967D-02 0.000D+00 -5.031D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 9.296D+01 -5.670D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 7.692D+02 1.060D+01 -9.2043D-02 8.100D+02 1.907D+01 -8.1012D-02 0.000D+00 -4.524D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -6.197D+00 -4.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 4.2702D+04 -1.207D+02 1.940D+00 -3.077D+03 3.590D+01 -2.467D-01 0.000D+00 -1.592D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 4.000D+01 -6.197D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -7.6982D+04 1.406D+02 -2.796D+00 -3.483D+02 -3.856D+01 1.981D-01 0.000D+00 1.956D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.177D+00 -1.661D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.888D+02 -9.428D-01 2.3831D-02 -1.499D+03 9.758D-01 -4.1943D-02 0.000D+00 -5.981D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.661D+01 -8.177D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.237D+03 8.455D+00 -1.565D-01 -6.578D+03 4.950D+01 -4.980D-01 0.000D+00 -1.088D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.221D+00 -1.391D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.6942D+04 9.443D+01 -1.144D+00 -6.089D+01 2.221D-01 -1.1955D-02 0.000D+00 -1.121D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.391D+02 -8.221D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.2513D+04 6.802D+01 -6.821D-01 -2.937D+01 4.639D-01 -9.9611D-03 0.000D+00 1.532D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.035D+01 -1.630D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 5.748D+03 -3.578D+01 2.067D-01 -3.931D+01 -6.830D-01 7.8189D-03 0.000D+00 -4.254D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.630D+02 -1.035D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.4657D+04 2.168D+02 -6.615D-01 1.234D+02 9.043D+00 -8.7434D-02 0.000D+00 -7.886D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.172D+01 -1.093D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.089D+03 -2.581D+02 -1.059D+00 3.303D+01 -2.040D+00 2.3536D-02 0.000D+00 -1.053D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.093D+02 -1.172D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 7.940D+03 3.090D+02 1.175D+00 6.104D+01 2.311D+00 -2.8729D-02 0.000D+00 -2.007D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.179D+01 -3.046D+02 0.000D+00 0.000D+00 9.582D+03 3.730D+01 -3.1126D-02 1.409D+02 2.627D+00 -1.8542D-02 0.000D+00 1.886D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.046D+02 -1.179D+01 0.000D+00 0.000D+00 9.474D+03 4.140D+01 -5.0827D-02 1.563D+02 3.098D+00 -2.2171D-02 0.000D+00 9.2049D-03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.327D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.707D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.212D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.783D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.000D+05 -6.080D+04 -1.060D+03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.600D+07 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.000D+05 -6.080D+04 -1.060D+03 0.000D+00 0.000D+00 0.000D+00 -1.600D+07 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.668D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 -1.033D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.000D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.000D+05 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.000D+05 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 4.4247D-05 4.3403D-05 4.9713D-05 4.5556D-05 -4.1311D-06 7.9201D-06 7.2496D-06 -6.7385D-05 -1.8236D-04 2.0657D-05 1.3194D-04 -1.5849D-04 -6.7655D-05 -8.7358D-06 -9.8119D-05 3.1119D-05 -5.7479D-05 3.160D-04 -5.775D-04 7.100D-04 -9.6843D-05 2.9934D-05 5.4014D-04 -4.762D-04 -4.163D-06 -2.1609D-04 -1.0541D-04 -3.1883D-05 -1.5062D-04 -2.7714D-04 -2.4361D-04 2.799D-05 -1.6592D-04 1.2748D-05 -2.0762D-05 -1.2546D-04 -4.436D-05 -1.0147D-05 1.5343D-04 2.1956D-05 -2.9386D-05 6.5513D-05 6.1813D-05 1.9995D-05 8.9674D-06 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.592D+01 -1.246D+01 -5.332D-01 -5.659D-01 -9.664D-01 1.275D+01 -2.145D+01 6.822D+00 3.388D+01 1.700D+01 -1.380D-01 -8.803D-01 5.465D+00 -1.614D+00 5.518D+01 3.010D+01 -4.878D+00 1.436D+01 6.254D+01 5.518D+01 -1.388D+02 -1.044D+02 6.831D+00 -1.178D+01 -5.504D+01 -3.066D+01 1.402D+00 -3.033D+01 4.869D+00 -7.428D+01 7.414D+01 1.630D+01 3.118D+00 8.728D+00 -7.453D+01 1.460D+00 -3.334D+00 -7.367D+00 -1.032D+00 2.867D+00 6.583D+00 -1.361D+00 1.350D+00 1.071D+01 -2.591D+01 4.852D+01 -7.932D+00 7.9915D-02 -2.5618D+04 -1.674D+02 2.213D-01 0.000D+00 1.880D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01110.dat000077500000000000000000000017011201767322700200350ustar00rootroot00000000000000 0.000D+00 8.500D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.500D+01 -1.200D+02 -4.100D+03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 3.300D+01 0.000D+00 -3.300D+01 0.000D+00 -7.000D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.400D+03 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.600D+03 -4.500D+02 -1.100D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 8.100D+01 0.000D+00 -1.000D+00 0.000D+00 -9.000D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.100D+02 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.200D+01 -1.100D+00 -2.200D+01 0.000D+00 0.000D+00 4.600D+00 9.900D+04 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01203.dat000077500000000000000000000017741201767322700200520ustar00rootroot00000000000000 -3.270D-01 -6.394D+01 -1.5596D+02 -1.000D+00 -2.370D-01 3.260D-01 -2.085D+02 9.093D+01 3.910D-01 -1.3029D+02 -1.865D+02 -1.420D+00 -3.370D-01 3.500D-01 -2.7238D+02 7.506D+01 -6.880D-01 -6.1927D+02 -5.529D+02 -2.270D+00 -4.290D-01 6.500D-01 -6.5111D+02 2.8344D+02 -7.380D-01 -6.5157D+02 -6.0418D+02 -2.750D+00 -5.320D-01 6.600D-01 -9.1364D+02 2.505D+02 -8.860D-01 -1.06885D+03 -1.00439D+03 -3.380D+00 -5.820D-01 7.900D-01 -1.92645D+03 4.0296D+02 -1.364D+00 -9.282D+01 -1.2846D+02 -4.680D+00 -8.700D-02 1.360D+00 -1.8426D+02 7.643D+01 -3.330D-01 -1.6324D+02 -1.5332D+02 -6.660D-01 -1.240D-01 2.980D-01 -2.4775D+02 6.377D+01 -3.370D-01 -2.2403D+02 -2.2872D+02 -6.630D-01 -1.120D-01 3.190D-01 -3.7575D+02 1.174D+02 -3.690D-01 -2.5371D+02 -2.4987D+02 -8.000D-01 -1.350D-01 3.300D-01 -5.0059D+02 1.0376D+02 -4.020D-01 -2.772D+02 -4.1935D+02 -8.840D-01 -1.660D-01 3.600D-01 -7.9618D+02 1.7859D+02 slicot-5.0+20101122/benchmark_data/BD012051.dat000077500000000000000000000001451201767322700201240ustar00rootroot00000000000000 0.000D+00 1.000D+00 9.800D+00 0.000D+00 0.000D+00 1.000D+00 1.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD012052.dat000077500000000000000000000006121201767322700201240ustar00rootroot00000000000000 0.000D+00 1.000D+00 0.000D+00 0.000D+00 9.800D+00 0.000D+00 -9.800D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 -9.800D+00 0.000D+00 2.940D+01 0.000D+00 0.000D+00 0.000D+00 1.000D+00 -2.000D+00 0.000D+00 0.000D+00 -2.000D+00 5.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD012053.dat000077500000000000000000000015661201767322700201360ustar00rootroot00000000000000 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 2.940D+01 -1.960D+01 -3.6285D-16 0.000D+00 0.000D+00 0.000D+00 -2.940D+01 3.920D+01 -9.800D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.960D+01 1.960D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.6667D+00 -2.6667D+00 1.000D+00 -2.3333D+00 4.8333D+00 -3.500D+00 6.6667D-01 -2.6667D+00 4.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD012054.dat000077500000000000000000000030061201767322700201260ustar00rootroot00000000000000 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 3.920D+01 -2.940D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.920D+01 5.880D+01 -1.960D+01 -3.6285D-16 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.3521D-15 -2.940D+01 3.920D+01 -9.800D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.960D+01 1.960D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.750D+00 -2.750D+00 1.000D+00 6.4185D-17 -2.500D+00 5.1667D+00 -3.6667D+00 1.000D+00 7.500D-01 -3.0833D+00 4.8333D+00 -3.500D+00 3.5586D-17 6.6667D-01 -2.6667D+00 4.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD012055.dat000077500000000000000000000045521201767322700201360ustar00rootroot00000000000000 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 4.900D+01 -3.920D+01 -4.5686D-15 1.0878D-15 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.900D+01 7.840D+01 -2.940D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -3.663D-14 -3.920D+01 5.880D+01 -1.960D+01 -3.6285D-16 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.224D-14 -1.3056D-14 -2.940D+01 3.920D+01 -9.800D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.960D+01 1.960D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.800D+00 -2.800D+00 1.000D+00 3.116D-16 -2.2755D-16 -2.600D+00 5.350D+00 -3.750D+00 1.000D+00 3.0015D-16 8.000D-01 -3.300D+00 5.1667D+00 -3.6667D+00 1.000D+00 5.1282D-16 7.500D-01 -3.0833D+00 4.8333D+00 -3.500D+00 5.3006D-17 -1.2003D-17 6.6667D-01 -2.6667D+00 4.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD012056.dat000077500000000000000000000066411201767322700201400ustar00rootroot00000000000000 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 5.880D+01 -4.900D+01 2.9028D-15 -1.6328D-15 5.4427D-16 -1.0086D-32 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -5.880D+01 9.800D+01 -3.920D+01 -4.8961D-15 5.4401D-16 2.0127D-32 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.900D+01 7.840D+01 -2.940D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -2.031D-14 2.0491D-14 -3.920D+01 5.880D+01 -1.960D+01 -3.6285D-16 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.1968D-14 -1.5504D-14 5.4401D-15 -2.940D+01 3.920D+01 -9.800D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.1755D-15 -1.6323D-15 2.176D-15 -1.0885D-15 -1.960D+01 1.960D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.8333D+00 -2.8333D+00 1.000D+00 -3.0442D-16 1.2911D-16 -1.0963D-16 -2.6667D+00 5.4667D+00 -3.800D+00 1.000D+00 6.7758D-17 4.2643D-16 8.3333D-01 -3.4333D+00 5.350D+00 -3.750D+00 1.000D+00 -7.5488D-16 -5.5618D-16 8.000D-01 -3.300D+00 5.1667D+00 -3.6667D+00 1.000D+00 4.3692D-16 -9.2492D-16 7.500D-01 -3.0833D+00 4.8333D+00 -3.500D+00 1.1031D-16 -1.6825D-16 2.2085D-17 6.6667D-01 -2.6667D+00 4.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD012057.dat000077500000000000000000000225311201767322700201350ustar00rootroot00000000000000 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 9.800D+01 -8.820D+01 -1.7383D-15 -3.7188D-18 -6.5249D-15 5.4388D-15 1.3084D-31 -1.6316D-15 5.4388D-16 -1.0042D-32 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -9.800D+01 1.764D+02 -7.840D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.088D-14 -8.820D+01 1.568D+02 -6.860D+01 6.5281D-15 -1.088D-14 4.3521D-15 1.4495D-30 -4.8318D-31 8.9449D-48 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.5855D-14 -3.637D-14 -7.840D+01 1.372D+02 -5.880D+01 3.4194D-14 -1.9585D-14 3.2649D-15 -1.0883D-15 2.0172D-32 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.1062D-13 1.0699D-13 -2.5751D-14 -6.860D+01 1.176D+02 -4.900D+01 1.5959D-14 -4.8969D-15 1.6323D-15 4.0225D-32 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.088D-13 -9.7922D-14 1.3056D-14 -7.6177D-15 -5.880D+01 9.800D+01 -3.920D+01 -1.3056D-14 4.3521D-15 -8.0569D-32 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -8.1596D-15 6.5289D-15 -8.1601D-15 -5.4454D-16 3.1009D-14 -4.900D+01 7.840D+01 -2.940D+01 -4.8961D-15 8.0569D-32 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -4.9868D-14 4.2342D-14 3.9892D-15 -1.4506D-15 -1.8859D-14 2.9013D-14 -3.920D+01 5.880D+01 -1.960D+01 3.6285D-16 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 2.720D-14 -2.3256D-14 0.000D+00 0.000D+00 8.1601D-15 -9.5202D-15 -4.3521D-15 -2.940D+01 3.920D+01 -9.800D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 -1.960D+01 1.960D+01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.900D+00 -2.900D+00 1.000D+00 2.1959D-16 -2.8176D-16 4.8626D-16 -1.0559D-16 -2.5389D-16 7.9671D-17 3.8476D-17 -2.800D+00 5.6889D+00 -3.8889D+00 1.000D+00 -8.3224D-16 3.5204D-16 -3.3739D-16 5.2418D-16 8.8172D-17 -2.6452D-16 9.000D-01 -3.6778D+00 5.6528D+00 -3.875D+00 1.000D+00 -2.5226D-15 1.571D-15 -8.8962D-16 -9.7319D-17 2.9196D-16 -5.123D-16 8.8889D-01 -3.6389D+00 5.6071D+00 -3.8571D+00 1.000D+00 -3.6967D-15 1.8224D-15 -2.0082D-16 4.7207D-17 -2.359D-15 3.7146D-15 8.750D-01 -3.5893D+00 5.5476D+00 -3.8333D+00 1.000D+00 -2.3237D-15 4.6098D-16 -5.5013D-16 2.660D-15 -4.0482D-15 2.3538D-15 8.5714D-01 -3.5238D+00 5.4667D+00 -3.800D+00 1.000D+00 2.8896D-16 1.029D-15 -5.623D-16 8.7784D-16 -5.4097D-16 -7.1966D-16 8.3333D-01 -3.4333D+00 5.350D+00 -3.750D+00 1.000D+00 -1.6135D-15 -8.0494D-16 1.1525D-15 -2.2138D-16 3.3885D-16 -1.0433D-15 8.000D-01 -3.300D+00 5.1667D+00 -3.6667D+00 1.000D+00 5.2901D-16 -7.6095D-16 1.7267D-16 -1.0799D-16 4.590D-16 -1.2346D-16 7.500D-01 -3.0833D+00 4.8333D+00 -3.500D+00 -3.7739D-17 1.578D-17 5.5573D-17 -9.0729D-18 -4.6091D-17 7.8485D-17 -2.2627D-16 6.6667D-01 -2.6667D+00 4.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 1.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD01206.dat000077500000000000000000000005671201767322700200540ustar00rootroot00000000000000 -8.950D-01 -2.860D-01 -4.367D+00 -9.180D-01 1.080D-01 -9.180D-01 -7.700D-01 -3.350D-01 -3.394D+00 -1.627D+00 1.700D-01 -1.627D+00 -5.970D-01 -3.720D-01 -3.651D+00 -7.920D-01 1.030D-01 -7.920D-01 -2.980D-01 -2.790D-01 -4.370D+00 -7.730D-01 1.160D-01 -7.730D-01 -4.540D-01 -4.330D-01 -4.005D+00 -8.070D-01 9.700D-02 -8.070D-01 slicot-5.0+20101122/benchmark_data/BD01304.dat000077500000000000000000000261221201767322700200460ustar00rootroot00000000000000 2.955D+00 1.9238D+02 1.1174D+00 3.823D+09 3.522D+00 3.6315D+01 2.6801D+00 5.055D+08 5.710D-01 4.7517D+01 2.7096D+00 7.532D+10 5.748D-01 1.6335D+02 1.235D+00 5.001D+08 3.526D+00 1.5109D+02 2.947D+00 1.888D+09 4.687D+00 4.3267D+01 2.623D+00 1.096D+09 1.093D+01 1.8937D+02 2.7711D+00 6.473D+09 2.928D+01 3.7326D+01 1.2201D+00 7.684D+09 4.060D+01 1.7896D+01 2.5364D+00 7.412D+09 6.320D+01 1.7413D+02 2.9768D+00 2.143D+10 1.625D+02 6.766D+00 2.9783D+00 2.133D+10 1.482D+02 1.5201D+02 2.7861D+00 4.064D+10 1.095D+02 1.9613D+02 2.5543D+00 3.801D+10 1.515D+02 1.671D+02 2.8597D+00 2.331D+10 1.366D+02 4.882D+01 1.450D+00 3.755D+10 9.321D+01 1.954D+02 1.0907D+00 5.683D+10 1.360D+02 1.9285D+02 1.3592D+00 2.170D+10 2.139D+02 4.6122D+01 2.997D+00 2.148D+10 1.359D+02 2.6812D+01 1.4492D+00 2.778D+10 6.202D+01 1.5125D+02 1.1918D+00 2.778D+10 1.359D+02 6.8707D+00 2.8851D+00 2.148D+10 2.139D+02 2.2951D+01 2.5735D+00 2.170D+10 1.360D+02 1.6795D+02 2.7799D+00 5.683D+10 9.321D+01 1.8293D+02 1.097D+00 3.755D+10 1.366D+02 1.7276D+02 1.2393D+00 2.331D+10 1.515D+02 1.4878D+01 1.2415D+00 3.801D+10 1.095D+02 4.9082D+01 1.3658D+00 4.064D+10 1.482D+02 1.8801D+02 2.5831D+00 2.133D+10 1.625D+02 1.8919D+02 2.7609D+00 2.143D+10 6.320D+01 1.8591D+02 1.0859D+00 7.412D+09 4.060D+01 1.6766D+02 1.127D+00 7.684D+09 2.928D+01 1.5213D+01 1.2696D+00 1.603D+10 1.493D+01 3.5992D+01 2.8901D+00 2.938D+10 1.390D+01 1.805D+02 2.6439D+00 3.427D+09 1.631D+01 1.606D+02 1.0347D+00 3.472D+09 8.175D+00 8.4097D+00 1.4846D+00 7.493D+11 1.392D+01 1.2996D+01 1.1322D+00 2.061D+09 6.629D+01 1.617D+02 1.0912D+00 1.080D+10 9.349D+01 1.8851D+02 1.2275D+00 7.784D+09 5.639D+01 1.7533D+02 2.7355D+00 2.463D+09 8.655D+01 2.7095D+01 2.8856D+00 1.004D+10 1.425D+02 1.8518D+02 2.8081D+00 1.074D+10 1.425D+02 1.9239D+02 1.1063D+00 1.127D+10 1.425D+02 1.1417D+01 2.8387D+00 1.127D+10 1.287D+02 3.5198D+01 1.3266D+00 7.409D+10 1.355D+03 6.6343D+00 1.2365D+00 8.043D+10 1.545D+03 1.9885D+02 2.9889D+00 4.456D+10 1.133D+03 3.345D+01 2.9255D+00 1.591D+11 1.145D+03 2.6675D+01 2.6296D+00 1.159D+11 8.085D+02 4.3575D+01 1.4455D+00 2.260D+11 7.023D+02 1.6747D+02 1.2367D+00 2.805D+11 1.161D+03 1.9831D+02 1.0633D+00 9.080D+10 1.735D+03 2.6289D+01 2.8015D+00 1.320D+11 1.081D+03 1.6667D+02 2.6669D+00 6.213D+10 1.079D+03 1.7021D+02 2.968D+00 1.320D+11 1.733D+03 1.5372D+02 2.8141D+00 9.080D+10 1.161D+03 9.0594D+00 2.9371D+00 2.805D+11 7.023D+02 1.702D+02 1.0517D+00 2.260D+11 8.085D+02 1.7937D+02 2.6601D+00 1.159D+11 1.145D+03 2.5006D+01 2.7449D+00 1.591D+11 1.133D+03 4.1631D+01 1.0258D+00 4.456D+10 1.545D+03 1.703D+02 1.4307D+00 8.043D+10 1.355D+03 1.6682D+02 2.9317D+00 7.409D+10 1.293D+02 1.9183D+02 1.1359D+00 1.117D+10 1.433D+02 1.9064D+02 1.3285D+00 1.123D+10 1.429D+02 2.3481D+01 2.8134D+00 1.071D+10 1.429D+02 1.7817D+02 1.304D+00 1.001D+10 9.194D+01 1.9702D+02 1.3049D+00 1.390D+09 2.053D+01 1.9335D+02 2.629D+00 7.493D+11 1.544D+01 1.892D-01 2.8316D+00 1.850D+09 5.135D+01 3.0443D+01 2.9673D+00 1.076D+10 7.703D+01 3.0077D+01 1.2211D+00 7.784D+09 5.639D+01 3.5862D+01 2.5416D+00 2.463D+09 8.655D+01 1.9506D+01 1.0901D+00 1.004D+10 1.425D+02 1.9847D+02 2.6388D+00 1.074D+10 1.425D+02 1.5119D+01 1.456D+00 1.127D+10 1.425D+02 1.8239D+02 1.3363D+00 1.127D+10 1.287D+02 4.614D+01 1.0081D+00 7.409D+10 1.355D+03 1.554D+02 1.3459D+00 8.043D+10 1.545D+03 1.8506D+02 1.0743D+00 4.456D+10 1.133D+03 1.7753D+02 1.0016D+00 1.591D+11 1.145D+03 1.8612D+02 1.3541D+00 1.159D+11 8.085D+02 1.7412D+02 2.966D+00 2.260D+11 7.023D+02 1.9733D+02 1.3737D+00 2.805D+11 1.161D+03 2.6134D+01 1.2595D+00 9.080D+10 1.735D+03 9.9049D+00 2.7387D+00 1.320D+11 1.081D+03 1.2642D+01 2.8745D+00 6.213D+10 1.079D+03 1.8329D+02 1.4971D+00 1.320D+11 1.733D+03 2.4384D+01 2.8246D+00 9.080D+10 1.161D+03 1.784D+02 1.1113D+00 2.805D+11 7.023D+02 2.5351D+01 2.6093D+00 2.260D+11 8.085D+02 1.9118D+02 1.4248D+00 1.159D+11 1.145D+03 1.7983D+02 2.714D+00 1.591D+11 1.133D+03 1.9718D+02 1.0152D+00 4.456D+10 1.545D+03 1.7521D+01 1.1875D+00 8.043D+10 1.355D+03 1.6172D+02 2.7333D+00 7.409D+10 1.293D+02 1.5284D+02 2.5131D+00 1.117D+10 1.433D+02 1.6681D+02 2.9279D+00 1.123D+10 1.429D+02 1.5863D+02 1.2667D+00 1.071D+10 1.429D+02 1.6305D+02 1.0718D+00 1.001D+10 9.194D+01 1.5817D+02 2.7685D+00 1.390D+09 2.053D+01 2.1338D+01 1.4374D+00 7.493D+11 1.544D+01 1.7823D+02 1.1874D+00 1.850D+09 5.135D+01 1.6406D+02 1.4937D+00 1.076D+10 7.703D+01 5.4544D+00 1.4818D+00 7.784D+09 5.639D+01 4.5576D+00 1.382D+00 2.463D+09 8.655D+01 6.237D-02 2.9445D+00 1.004D+10 1.425D+02 4.3802D+00 2.6594D+00 1.074D+10 1.425D+02 3.1098D+01 1.3545D+00 1.127D+10 1.425D+02 1.7249D+02 1.4864D+00 1.127D+10 1.287D+02 2.8568D+01 1.4257D+00 7.409D+10 1.355D+03 6.6547D+00 2.7693D+00 8.043D+10 1.545D+03 5.8487D+00 2.9487D+00 4.456D+10 1.133D+03 1.3915D+01 2.6158D+00 1.591D+11 1.145D+03 1.8036D+02 2.7605D+00 1.159D+11 8.085D+02 1.681D+02 1.3918D+00 2.260D+11 7.023D+02 1.531D+02 2.8155D+00 2.805D+11 1.161D+03 4.1672D+01 1.0879D+00 9.080D+10 1.735D+03 2.7644D+01 2.7937D+00 1.320D+11 1.081D+03 1.7064D+01 1.1873D+00 6.213D+10 1.079D+03 1.6678D+02 2.7189D+00 1.320D+11 1.733D+03 1.9801D+02 2.9178D+00 9.080D+10 1.080D+03 1.5956D+01 1.2006D+00 5.921D+11 6.214D+02 4.2715D+01 2.9836D+00 2.260D+11 8.085D+02 1.540D+02 1.0986D+00 1.159D+11 1.145D+03 1.0345D+01 1.013D+00 1.591D+11 1.133D+03 3.8248D+00 1.4041D+00 4.456D+10 1.545D+03 4.3148D+01 1.3504D+00 8.043D+10 1.355D+03 1.9073D+02 1.2546D+00 7.409D+10 1.293D+02 3.2006D+01 1.485D+00 1.117D+10 1.433D+02 8.3148D+00 2.7999D+00 1.123D+10 1.429D+02 1.7662D+02 2.7611D+00 1.071D+10 1.429D+02 6.4585D+00 2.813D+00 1.001D+10 9.194D+01 2.8963D+01 1.3885D+00 1.390D+09 2.053D+01 1.8543D+02 1.4319D+00 7.493D+11 1.544D+01 4.2003D+01 1.3827D+00 1.850D+09 5.135D+01 1.9418D+02 2.8198D+00 1.076D+10 7.703D+01 4.222D+00 1.0304D+00 7.880D+09 5.343D+01 4.2741D+01 2.9609D+00 2.334D+09 2.893D+01 1.5159D+02 2.9144D+00 3.229D+09 2.870D+01 1.7658D+02 1.3731D+00 2.378D+09 1.217D+01 1.9738D+02 1.3285D+00 7.585D+11 1.049D+01 2.3626D+01 1.0274D+00 2.758D+09 2.091D+01 1.5592D+02 2.7656D+00 2.758D+09 1.417D+01 4.5147D+01 2.8193D+00 1.027D+10 1.810D+01 8.0555D+00 2.9153D+00 3.483D+09 1.934D+02 2.6912D+01 1.2339D+00 8.690D+09 3.580D+02 1.5229D+02 2.5363D+00 8.690D+09 3.655D+02 1.8645D+02 1.0626D+00 8.351D+09 2.150D+02 1.3804D+01 2.7146D+00 1.854D+10 5.792D+01 1.8003D+02 2.9224D+00 9.619D+09 5.883D+01 4.7601D+01 2.6348D+00 9.619D+09 5.871D+01 7.965D-01 2.5823D+00 9.658D+09 5.224D+02 4.4751D+00 1.4515D+00 1.379D+11 1.111D+03 4.7443D+01 2.7762D+00 1.571D+10 1.236D+03 1.6274D+02 1.020D+00 1.571D+10 1.236D+03 1.2855D+01 1.2205D+00 1.571D+10 1.236D+03 1.6873D+02 2.6964D+00 1.571D+10 1.236D+03 1.9893D+02 1.1805D+00 1.571D+10 1.236D+03 1.5587D+02 1.1392D+00 1.571D+10 1.236D+03 1.6137D+02 1.3832D+00 1.571D+10 1.236D+03 1.8996D+02 1.0066D+00 1.571D+10 1.236D+03 4.7426D+01 2.7906D+00 1.571D+10 1.236D+03 2.7964D+01 2.8989D+00 1.571D+10 1.111D+03 1.8297D+02 1.4231D+00 1.379D+11 5.311D+02 3.9547D+01 1.1972D+00 7.448D+09 7.598D+01 1.0834D+01 1.3212D+00 7.448D+09 5.215D+01 1.835D+02 2.6349D+00 1.573D+10 7.827D+01 4.9398D+01 1.4823D+00 9.695D+09 7.389D+01 3.6386D+01 1.4615D+00 5.036D+09 1.349D+01 7.3201D+00 2.9703D+00 1.006D+10 2.364D+01 1.7057D+02 2.7019D+00 1.413D+09 1.996D+01 6.3739D+00 1.3364D+00 7.405D+11 1.525D+01 4.0509D+00 1.3257D+00 1.851D+09 2.560D+01 1.5037D+02 1.2995D+00 1.634D+10 2.025D+01 1.6899D+02 1.2982D+00 1.720D+10 1.760D+01 1.9244D+02 2.5427D+00 4.069D+09 1.467D+01 3.9725D+01 2.7056D+00 4.716D+09 1.386D+01 2.0234D+01 2.9918D+00 4.716D+09 1.642D+01 4.5742D+01 2.5784D+00 4.220D+09 1.073D+01 1.3059D+01 1.2453D+00 3.681D+10 1.954D+02 4.1785D+01 1.1891D+00 5.454D+09 1.951D+02 1.6869D+02 2.566D+00 3.681D+10 4.505D+00 1.7463D+02 1.3947D+00 9.512D+09 4.505D+00 1.2709D+01 1.3114D+00 3.681D+10 2.015D+02 4.2516D+01 1.4196D+00 5.454D+09 2.018D+02 3.4237D+01 2.5289D+00 3.681D+10 1.077D+01 1.5519D+02 1.440D+00 4.220D+09 2.221D+01 1.9222D+02 2.6184D+00 3.027D+09 2.081D+01 1.8793D+02 2.5096D+00 1.463D+10 9.892D+00 1.6793D+02 1.0799D+00 5.849D+09 5.976D+00 1.9464D+02 1.0875D+00 9.969D+08 2.266D+01 1.6068D+02 2.5014D+00 1.797D+09 4.766D+01 3.776D+01 1.2124D+00 8.687D+08 5.840D+01 2.4005D+01 2.9088D+00 8.687D+08 5.840D+01 1.1795D+01 1.3743D+00 8.687D+08 5.840D+01 3.1123D+01 1.3992D+00 8.687D+08 4.645D+01 1.7377D+02 2.6545D+00 1.372D+09 1.809D+01 1.556D-01 2.8616D+00 4.944D+08 2.701D+00 1.6782D+02 2.7189D+00 5.378D+08 2.663D+00 1.9981D+02 1.1648D+00 3.565D+08 1.183D+00 1.6626D+02 2.9727D+00 5.250D+08 3.758D-01 1.566D+02 2.7438D+00 6.247D+10 3.789D-01 4.5001D+01 2.9488D+00 5.206D+08 1.091D+00 1.2195D+01 1.414D+00 4.039D+08 2.854D+00 1.5192D+02 1.1471D+00 1.187D+09 2.689D+00 1.977D+02 1.0455D+00 3.091D+08 1.102D+00 1.947D+02 1.4344D+00 3.091D+08 3.910D+00 3.2964D+01 2.9155D+00 2.387D+08 6.718D+00 1.9621D+02 1.1845D+00 2.387D+08 3.359D+00 1.5796D+02 0.000D+00 0.000D+00 slicot-5.0+20101122/benchmark_data/BD02106.dat000077500000000000000000000003641201767322700200470ustar00rootroot00000000000000 9.98D-1 6.70D-2 0.00D0 0.00D0 -6.70D-2 9.98D-1 0.00D0 0.00D0 0.00D0 0.00D0 9.98D-1 1.53D-1 0.00D0 0.00D0 -1.53D-1 9.98D-1 3.30D-3 2.00D-2 1.00D-1 -7.00D-4 4.00D-2 7.30D-3 -2.80D-3 1.00D-1 slicot-5.0+20101122/benchmark_data/BD02107.dat000077500000000000000000000004501201767322700200440ustar00rootroot00000000000000 9.8475D-1 -7.9903D-2 9.0540D-4 -1.0765D-3 4.1588D-2 9.9899D-1 -3.5855D-2 1.2684D-2 -5.4662D-1 4.4916D-2 -3.2991D-1 1.9318D-1 2.6624D0 -1.0045D-1 -9.2455D-1 -2.6325D-1 3.7112D-3 7.3610D-4 -8.7051D-2 9.3411D-6 -1.19844D0 -4.1378D-4 -3.1927D0 9.2535D-4 slicot-5.0+20101122/benchmark_data/BD02108.dat000077500000000000000000000005141201767322700200460ustar00rootroot00000000000000 -6.0D-01 -2.2D0 -3.6D0 -5.400018D0 1.0D0 6.0D-01 8.0D-01 3.399982D0 0.0D0 1.0D0 1.8D0 3.799982D0 0.0D0 0.0D0 0.0D0 -9.99982D-1 1.0D0 -1.0D0 -1.0D0 -1.0D0 0.0D0 1.0D0 -1.0D0 -1.0D0 0.0D0 0.0D0 1.0D0 -1.0D0 0.0D0 0.0D0 0.0D0 1.0D0 slicot-5.0+20101122/benchmark_data/BD02109.dat000077500000000000000000000006561201767322700200560ustar00rootroot00000000000000 9.5407D-1 1.9643D-2 3.5970D-3 6.7300D-4 1.9000D-4 4.0849D-1 4.1317D-1 1.6084D-1 4.4679D-2 1.1971D-2 1.2217D-1 2.6326D-1 3.6149D-1 1.5930D-1 1.2383D-1 4.1118D-2 1.2858D-1 2.7209D-1 2.1442D-1 4.0976D-1 1.3050D-3 5.8080D-3 1.8750D-2 3.6162D-2 9.4280D-1 4.3400D-4 -1.2200D-4 2.6606D-2 -1.0453D-2 3.7530D-2 -5.5100D-2 3.6076D-2 -6.6000D-2 4.6170D-3 -9.1480D-3 slicot-5.0+20101122/benchmark_data/BD02111.dat000077500000000000000000000022461201767322700200440ustar00rootroot00000000000000 8.701D-1 1.350D-1 1.159D-2 5.014D-4 -3.722D-2 3.484D-4 0.000D0 4.242D-3 7.249D-3 7.655D-2 8.974D-1 1.272D-2 5.504D-4 -4.016D-2 3.743D-4 0.000D0 4.530D-3 7.499D-3 -1.272D-1 3.575D-1 8.170D-1 1.455D-3 -1.028D-1 9.870D-4 0.000D0 1.185D-2 1.872D-2 -3.635D-1 6.339D-1 7.491D-2 7.966D-1 -2.735D-1 2.653D-3 0.000D0 3.172D-2 4.882D-2 -9.600D-1 1.6459D0 -1.289D-1 -5.597D-3 7.142D-2 7.108D-3 0.000D0 8.452D-2 1.259D-1 -6.644D-1 1.1296D-1 -8.889D-2 -3.854D-3 8.447D-2 1.360D-2 0.000D0 1.443D-1 1.016D-1 -4.102D-1 6.930D-1 -5.471D-2 -2.371D-3 6.649D-2 1.249D-2 1.063D-4 9.997D-2 6.967D-2 -1.799D-1 3.017D-1 -2.393D-2 -1.035D-3 6.059D-2 2.216D-2 0.000D0 2.139D-1 3.554D-2 -3.451D-1 5.804D-1 -4.596D-2 -1.989D-3 1.056D-1 1.986D-2 0.000D0 2.191D-1 2.152D-1 4.760D-4 -5.701D-5 -8.368D-3 8.790D-5 -4.773D-4 -2.730D-4 1.482D-4 -1.312D-3 8.876D-4 3.892D-4 -3.513D-3 2.480D-3 1.034D-3 -9.275D-3 6.680D-3 7.203D-4 -6.159D-3 3.834D-3 4.454D-4 -3.683D-3 2.029D-3 1.971D-4 -1.554D-3 6.937D-4 3.773D-4 -3.028D-3 1.469D-3 slicot-5.0+20101122/benchmark_data/BD02112.dat000077500000000000000000000002711201767322700200410ustar00rootroot00000000000000 0.000D+00 0.000D+00 0.000D+00 -2.230D-01 1.850D+00 -5.420D-01 2.830D+01 2.040D+02 6.870D+01 -5.210D+00 -8.430D-01 -2.850D-01 -1.010D-01 -6.750D+00 -2.460D-01 slicot-5.0+20101122/benchmark_data/readme000077500000000000000000000013021201767322700176500ustar00rootroot00000000000000SLICOT Library Subdirectory benchmark_data ------------------------------------------ SLICOT Library Subdirectory benchmark_data contains data files (*.dat) for the SLICOT Library benchmark collections. These files are used by the Chapter B SLICOT routines, but they could also be used independently for testing some algorithms on difficult numerical problems. Special standard or generalized continuous-time or discrete-time systems are generated, as well as examples of Riccati or (generalized) Lyapunov equations. To be used in a specific program, via calls to the Chapter B routines, the required data files should be available in the directory where the executable program has been launched from. slicot-5.0+20101122/doc/000077500000000000000000000000001201767322700143135ustar00rootroot00000000000000slicot-5.0+20101122/doc/AB01MD.html000077500000000000000000000247121201767322700160560ustar00rootroot00000000000000 AB01MD - SLICOT Library Routine Documentation

AB01MD

Controllable realization for single-input systems using orthogonal state and input transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a controllable realization for the linear time-invariant
  single-input system

          dX/dt = A * X + B * U,

  where A is an N-by-N matrix and B is an N element vector which
  are reduced by this routine to orthogonal canonical form using
  (and optionally accumulating) orthogonal similarity
  transformations.
Specification 
      SUBROUTINE AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOBZ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Z the orthogonal similarity transformations for
          reducing the system, as follows:
          = 'N':  Do not form Z and do not store the orthogonal
                  transformations;
          = 'F':  Do not form Z, but store the orthogonal
                  transformations in the factored form;
          = 'I':  Z is initialized to the unit matrix and the
                  orthogonal transformation matrix Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e. the order of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading NCONT-by-NCONT upper Hessenberg
          part of this array contains the canonical form of the
          state dynamics matrix, given by Z' * A * Z, of a
          controllable realization for the original system. The
          elements below the first subdiagonal are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, the original input/state vector B.
          On exit, the leading NCONT elements of this array contain
          canonical form of the input/state vector, given by Z' * B,
          with all elements but B(1) set to zero.

  NCONT   (output) INTEGER
          The order of the controllable state-space representation.

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          If JOBZ = 'I', then the leading N-by-N part of this array
          contains the matrix of accumulated orthogonal similarity
          transformations which reduces the given system to
          orthogonal canonical form.
          If JOBZ = 'F', the elements below the diagonal, with the
          array TAU, represent the orthogonal transformation matrix
          as a product of elementary reflectors. The transformation
          matrix can then be obtained by calling the LAPACK Library
          routine DORGQR.
          If JOBZ = 'N', the array Z is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDZ = 1 and
          declare this array to be Z(1,1) in the calling program).

  LDZ     INTEGER
          The leading dimension of array Z. If JOBZ = 'I' or
          JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The elements of TAU contain the scalar factors of the
          elementary reflectors used in the reduction of B and A.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the
          controllability of (A,B). If the user sets TOL > 0, then
          the given value of TOL is used as an absolute tolerance;
          elements with absolute value less than TOL are considered
          neglijible. If the user sets TOL <= 0, then an implicitly
          computed, default tolerance, defined by
          TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead,
          where EPS is the machine precision (see LAPACK Library
          routine DLAMCH).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK. LDWORK >= MAX(1,N).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The Householder matrix which reduces all but the first element
  of vector B to zero is found and this orthogonal similarity
  transformation is applied to the matrix A. The resulting A is then
  reduced to upper Hessenberg form by a sequence of Householder
  transformations. Finally, the order of the controllable state-
  space representation (NCONT) is determined by finding the position
  of the first sub-diagonal element of A which is below an
  appropriate zero threshold, either TOL or TOLDEF (see parameter
  TOL); if NORM(B) is smaller than this threshold, NCONT is set to
  zero, and no computations for reducing the system to orthogonal
  canonical form are performed.
References 
  [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D.
      Orthogonal Invariants and Canonical Forms for Linear
      Controllable Systems.
      Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981.

  [2] Hammarling, S.J.
      Notes on the use of orthogonal similarity transformations in
      control.
      NPL Report DITC 8/82, August 1982.

  [3] Paige, C.C
      Properties of numerical algorithms related to computing
      controllability.
      IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  None
Example

Program Text 

*     AB01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDZ
      PARAMETER        ( LDA = NMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, N, NCONT
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), TAU(NMAX),
     $                 Z(LDZ,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB01MD, DORGQR
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, TOL, JOBZ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( B(I), I = 1,N )
*        Find a controllable realization for the given system.
         CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL,
     $                DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) NCONT
            DO 20 I = 1, NCONT
               WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT )
            IF ( LSAME( JOBZ, 'F' ) )
     $         CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO )
            IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN
               WRITE ( NOUT, FMT = 99995 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N )
   40          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01MD = ',I2)
99997 FORMAT (' The order of the controllable state-space representati',
     $       'on = ',I2,//' The state dynamics matrix A of a controlla',
     $       'ble realization is ')
99996 FORMAT (/' The input/state vector B of a controllable realizatio',
     $       'n is ',/(1X,F8.4))
99995 FORMAT (/' The similarity transformation matrix Z is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 AB01MD EXAMPLE PROGRAM DATA
   3     0.0     I
   1.0   2.0   0.0
   4.0  -1.0   0.0
   0.0   0.0   1.0
   1.0   0.0   1.0
Program Results 
 AB01MD EXAMPLE PROGRAM RESULTS

 The order of the controllable state-space representation =  3

 The state dynamics matrix A of a controllable realization is 
   1.0000   1.4142   0.0000
   2.8284  -1.0000   2.8284
   0.0000   1.4142   1.0000

 The input/state vector B of a controllable realization is 
  -1.4142
   0.0000
   0.0000

 The similarity transformation matrix Z is 
  -0.7071   0.0000  -0.7071
   0.0000  -1.0000   0.0000
  -0.7071   0.0000   0.7071

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB01ND.html000077500000000000000000000330641201767322700160570ustar00rootroot00000000000000 AB01ND - SLICOT Library Routine Documentation

AB01ND

Controllable realization for multi-input systems using orthogonal state and input transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a controllable realization for the linear time-invariant
  multi-input system

          dX/dt = A * X + B * U,

  where A and B are N-by-N and N-by-M matrices, respectively,
  which are reduced by this routine to orthogonal canonical form
  using (and optionally accumulating) orthogonal similarity
  transformations.  Specifically, the pair (A, B) is reduced to
  the pair (Ac, Bc),  Ac = Z' * A * Z,  Bc = Z' * B,  given by

          [ Acont     *    ]         [ Bcont ]
     Ac = [                ],   Bc = [       ],
          [   0    Auncont ]         [   0   ]

     and

             [ A11 A12  . . .  A1,p-1 A1p ]         [ B1 ]
             [ A21 A22  . . .  A2,p-1 A2p ]         [ 0  ]
             [  0  A32  . . .  A3,p-1 A3p ]         [ 0  ]
     Acont = [  .   .   . . .    .     .  ],   Bc = [ .  ],
             [  .   .     . .    .     .  ]         [ .  ]
             [  .   .       .    .     .  ]         [ .  ]
             [  0   0   . . .  Ap,p-1 App ]         [ 0  ]

  where the blocks  B1, A21, ..., Ap,p-1  have full row ranks and
  p is the controllability index of the pair.  The size of the
  block  Auncont is equal to the dimension of the uncontrollable
  subspace of the pair (A, B).
Specification 
      SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON,
     $                   NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  JOBZ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Z the orthogonal similarity transformations for
          reducing the system, as follows:
          = 'N':  Do not form Z and do not store the orthogonal
                  transformations;
          = 'F':  Do not form Z, but store the orthogonal
                  transformations in the factored form;
          = 'I':  Z is initialized to the unit matrix and the
                  orthogonal transformation matrix Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e. the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs, or of columns of B.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading NCONT-by-NCONT part contains the
          upper block Hessenberg state dynamics matrix Acont in Ac,
          given by Z' * A * Z, of a controllable realization for
          the original system. The elements below the first block-
          subdiagonal are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the leading NCONT-by-M part of this array
          contains the transformed input matrix Bcont in Bc, given
          by Z' * B, with all elements but the first block set to
          zero.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  NCONT   (output) INTEGER
          The order of the controllable state-space representation.

  INDCON  (output) INTEGER
          The controllability index of the controllable part of the
          system representation.

  NBLK    (output) INTEGER array, dimension (N)
          The leading INDCON elements of this array contain the
          the orders of the diagonal blocks of Acont.

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          If JOBZ = 'I', then the leading N-by-N part of this
          array contains the matrix of accumulated orthogonal
          similarity transformations which reduces the given system
          to orthogonal canonical form.
          If JOBZ = 'F', the elements below the diagonal, with the
          array TAU, represent the orthogonal transformation matrix
          as a product of elementary reflectors. The transformation
          matrix can then be obtained by calling the LAPACK Library
          routine DORGQR.
          If JOBZ = 'N', the array Z is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDZ = 1 and
          declare this array to be Z(1,1) in the calling program).

  LDZ     INTEGER
          The leading dimension of array Z. If JOBZ = 'I' or
          JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The elements of TAU contain the scalar factors of the
          elementary reflectors used in the reduction of B and A.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
          is the machine precision (see LAPACK Library routine
          DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N, 3*M).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Matrix B is first QR-decomposed and the appropriate orthogonal
  similarity transformation applied to the matrix A. Leaving the
  first rank(B) states unchanged, the remaining lower left block
  of A is then QR-decomposed and the new orthogonal matrix, Q1,
  is also applied to the right of A to complete the similarity
  transformation. By continuing in this manner, a completely
  controllable state-space pair (Acont, Bcont) is found for the
  given (A, B), where Acont is upper block Hessenberg with each
  subdiagonal block of full row rank, and Bcont is zero apart from
  its (independent) first rank(B) rows.
  NOTE that the system controllability indices are easily
  calculated from the dimensions of the blocks of Acont.
References 
  [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D.
      Orthogonal Invariants and Canonical Forms for Linear
      Controllable Systems.
      Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981.

  [2] Paige, C.C.
      Properties of numerical algorithms related to computing
      controllablity.
      IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981.

  [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and
      Postlethwaite, I.
      Optimal Pole Assignment Design of Linear Multi-Input Systems.
      Leicester University, Report 99-11, May 1996.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  If the system matrices A and B are badly scaled, it would be
  useful to scale them with SLICOT routine TB01ID, before calling
  the routine.
Example

Program Text 

*     AB01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDZ = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX, 3*MMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, INDCON, J, M, N, NCONT
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK),
     $                 TAU(NMAX), Z(LDZ,NMAX)
      INTEGER          IWORK(LIWORK), NBLK(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB01ND, DORGQR
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, JOBZ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
*           Find a controllable ssr for the given system.
            CALL AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON,
     $                   NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK,
     $                   INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) NCONT
               WRITE ( NOUT, FMT = 99996 )
               DO 20 I = 1, NCONT
                  WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCONT )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99994 ) ( NBLK(I), I = 1,INDCON )
               WRITE ( NOUT, FMT = 99993 )
               DO 40 I = 1, NCONT
                  WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99992 ) INDCON
               IF ( LSAME( JOBZ, 'F' ) )
     $            CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK,
     $                         INFO )
               IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN
                  WRITE ( NOUT, FMT = 99991 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB01ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01ND = ',I2)
99997 FORMAT (' The order of the controllable state-space representati',
     $       'on = ',I2)
99996 FORMAT (/' The transformed state dynamics matrix of a controllab',
     $       'le realization is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' and the dimensions of its diagonal blocks are ',
     $       /20(1X,I2))
99993 FORMAT (/' The transformed input/state matrix B of a controllabl',
     $       'e realization is ')
99992 FORMAT (/' The controllability index of the transformed system r',
     $       'epresentation = ',I2)
99991 FORMAT (/' The similarity transformation matrix Z is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 AB01ND EXAMPLE PROGRAM DATA
   3     2     0.0     I
  -1.0   0.0   0.0
  -2.0  -2.0  -2.0
  -1.0   0.0  -3.0
   1.0   0.0   0.0
   0.0   2.0   1.0
Program Results 
 AB01ND EXAMPLE PROGRAM RESULTS

 The order of the controllable state-space representation =  2

 The transformed state dynamics matrix of a controllable realization is 
  -3.0000   2.2361
   0.0000  -1.0000

 and the dimensions of its diagonal blocks are 
  2

 The transformed input/state matrix B of a controllable realization is 
   0.0000  -2.2361
   1.0000   0.0000

 The controllability index of the transformed system representation =  1

 The similarity transformation matrix Z is 
   0.0000   1.0000   0.0000
  -0.8944   0.0000  -0.4472
  -0.4472   0.0000   0.8944

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB01OD.html000077500000000000000000000367641201767322700160720ustar00rootroot00000000000000 AB01OD - SLICOT Library Routine Documentation

AB01OD

Staircase form for multi-input systems using orthogonal state and input transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the matrices A and B using (and optionally accumulating)
  state-space and input-space transformations U and V respectively,
  such that the pair of matrices

     Ac = U' * A * U,    Bc = U' * B * V

  are in upper "staircase" form. Specifically,

          [ Acont     *    ]         [ Bcont ]
     Ac = [                ],   Bc = [       ],
          [   0    Auncont ]         [   0   ]

     and

             [ A11 A12  . . .  A1,p-1 A1p ]         [ B1 ]
             [ A21 A22  . . .  A2,p-1 A2p ]         [ 0  ]
             [  0  A32  . . .  A3,p-1 A3p ]         [ 0  ]
     Acont = [  .   .   . . .    .     .  ],   Bc = [ .  ],
             [  .   .     . .    .     .  ]         [ .  ]
             [  .   .       .    .     .  ]         [ .  ]
             [  0   0   . . .  Ap,p-1 App ]         [ 0  ]

  where the blocks  B1, A21, ..., Ap,p-1  have full row ranks and
  p is the controllability index of the pair.  The size of the
  block Auncont is equal to the dimension of the uncontrollable
  subspace of the pair (A, B).  The first stage of the reduction,
  the "forward" stage, accomplishes the reduction to the orthogonal
  canonical form (see SLICOT library routine AB01ND). The blocks
  B1, A21, ..., Ap,p-1 are further reduced in a second, "backward"
  stage to upper triangular form using RQ factorization. Each of
  these stages is optional.
Specification 
      SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U,
     $                   LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  STAGES  CHARACTER*1
          Specifies the reduction stages to be performed as follows:
          = 'F':  Perform the forward stage only;
          = 'B':  Perform the backward stage only;
          = 'A':  Perform both (all) stages.

  JOBU    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix U the state-space transformations as follows:
          = 'N':  Do not form U;
          = 'I':  U is internally initialized to the unit matrix (if
                  STAGES <> 'B'), or updated (if STAGES = 'B'), and
                  the orthogonal transformation matrix U is
                  returned.

  JOBV    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix V the input-space transformations as follows:
          = 'N':  Do not form V;
          = 'I':  V is initialized to the unit matrix and the
                  orthogonal transformation matrix V is returned.
          JOBV is not referenced if STAGES = 'F'.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e. the order of the
          matrix A.  N >= 0.

  M       (input) INTEGER
          The actual input dimension.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state transition matrix A to be transformed.
          If STAGES = 'B', A should be in the orthogonal canonical
          form, as returned by SLICOT library routine AB01ND.
          On exit, the leading N-by-N part of this array contains
          the transformed state transition matrix U' * A * U.
          The leading NCONT-by-NCONT part contains the upper block
          Hessenberg state matrix Acont in Ac, given by U' * A * U,
          of a controllable realization for the original system.
          The elements below the first block-subdiagonal are set to
          zero.  If STAGES <> 'F', the subdiagonal blocks of A are
          triangularized by RQ factorization, and the annihilated
          elements are explicitly zeroed.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B to be transformed.
          If STAGES = 'B', B should be in the orthogonal canonical
          form, as returned by SLICOT library routine AB01ND.
          On exit with STAGES = 'F', the leading N-by-M part of
          this array contains the transformed input matrix U' * B,
          with all elements but the first block set to zero.
          On exit with STAGES <> 'F', the leading N-by-M part of
          this array contains the transformed input matrix
          U' * B * V, with all elements but the first block set to
          zero and the first block in upper triangular form.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
          If STAGES <> 'B' or JOBU = 'N', then U need not be set
          on entry.
          If STAGES = 'B' and JOBU = 'I', then, on entry, the
          leading N-by-N part of this array must contain the
          transformation matrix U that reduced the pair to the
          orthogonal canonical form.
          On exit, if JOBU = 'I', the leading N-by-N part of this
          array contains the transformation matrix U that performed
          the specified reduction.
          If JOBU = 'N', the array U is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDU = 1 and
          declare this array to be U(1,1) in the calling program).

  LDU     INTEGER
          The leading dimension of array U.
          If JOBU = 'I', LDU >= MAX(1,N);  if JOBU = 'N', LDU >= 1.

  V       (output) DOUBLE PRECISION array, dimension (LDV,M)
          If JOBV = 'I', then the leading M-by-M part of this array
          contains the transformation matrix V.
          If STAGES = 'F', or JOBV = 'N', the array V is not
          referenced and can be supplied as a dummy array (i.e. set
          parameter  LDV = 1 and declare this array to be V(1,1) in
          the calling program).

  LDV     INTEGER
          The leading dimension of array V.
          If STAGES <> 'F' and JOBV = 'I', LDV >= MAX(1,M);
          if STAGES = 'F' or JOBV = 'N', LDV >= 1.

  NCONT   (input/output) INTEGER
          The order of the controllable state-space representation.
          NCONT is input only if STAGES = 'B'.

  INDCON  (input/output) INTEGER
          The number of stairs in the staircase form (also, the
          controllability index of the controllable part of the
          system representation).
          INDCON is input only if STAGES = 'B'.

  KSTAIR  (input/output) INTEGER array, dimension (N)
          The leading INDCON elements of this array contain the
          dimensions of the stairs, or, also, the orders of the
          diagonal blocks of Acont.
          KSTAIR is input if STAGES = 'B', and output otherwise.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
          is the machine precision (see LAPACK Library routine
          DLAMCH).
          TOL is not referenced if STAGES = 'B'.
Workspace 
  IWORK   INTEGER array, dimension (M)
          IWORK is not referenced if STAGES = 'B'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          If STAGES <> 'B', LDWORK >= MAX(1, N + MAX(N,3*M));
          If STAGES =  'B', LDWORK >= MAX(1, M + MAX(N,M)).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Staircase reduction of the pencil [B|sI - A] is used. Orthogonal
  transformations U and V are constructed such that

                     |B |sI-A      *  . . .  *      *       |
                     | 1|    11       .      .      .       |
                     |  |  A    sI-A    .    .      .       |
                     |  |   21      22    .  .      .       |
                     |  |        .     .     *      *       |
  [U'BV|sI - U'AU] = |0 |     0    .     .                  |
                     |  |            A     sI-A     *       |
                     |  |             p,p-1    pp           |
                     |  |                                   |
                     |0 |         0          0   sI-A       |
                     |  |                            p+1,p+1|

  where the i-th diagonal block of U'AU has dimension KSTAIR(i),
  for i = 1,...,p. The value of p is returned in INDCON. The last
  block contains the uncontrollable modes of the (A,B)-pair which
  are also the generalized eigenvalues of the above pencil.

  The complete reduction is performed in two stages. The first,
  forward stage accomplishes the reduction to the orthogonal
  canonical form. The second, backward stage consists in further
  reduction to triangular form by applying left and right orthogonal
  transformations.
References 
  [1] Van Dooren, P.
      The generalized eigenvalue problem in linear system theory.
      IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981.

  [2] Miminis, G. and Paige, C.
      An algorithm for pole assignment of time-invariant multi-input
      linear systems.
      Proc. 21st IEEE CDC, Orlando, Florida, 1, pp. 62-67, 1982.
Numerical Aspects 
  The algorithm requires O((N + M) x N**2) operations and is
  backward stable (see [1]).
Further Comments 
  If the system matrices A and B are badly scaled, it would be
  useful to scale them with SLICOT routine TB01ID, before calling
  the routine.
Example

Program Text 

*     AB01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDU, LDV
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDU = NMAX,
     $                   LDV = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX + MAX( NMAX, 3*MMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INDCON, INFO, J, M, N, NCONT
      CHARACTER*1      JOBU, JOBV, STAGES
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK),
     $                 U(LDU,NMAX), V(LDV,MMAX)
      INTEGER          IWORK(LIWORK), KSTAIR(NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB01OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, STAGES, JOBU, JOBV
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
*           Reduce the matrices A and B to upper "staircase" form.
            CALL AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U,
     $                   LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99996 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99994 ) INDCON
               WRITE ( NOUT, FMT = 99993 ) ( KSTAIR(I), I = 1,INDCON )
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01OD = ',I2)
99997 FORMAT (' The transformed state transition matrix is ')
99996 FORMAT (/' The transformed input matrix is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' The number of stairs in the staircase form = ',I3,/)
99993 FORMAT (' The dimensions of the stairs are ',/(20(I3,2X)))
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 AB01OD EXAMPLE PROGRAM DATA
   5     2     0.0     F     N     N
   17.0   24.0    1.0    8.0   15.0
   23.0    5.0    7.0   14.0   16.0
    4.0    6.0   13.0   20.0   22.0
   10.0   12.0   19.0   21.0    3.0
   11.0   18.0   25.0    2.0    9.0
   -1.0   -4.0
    4.0    9.0
   -9.0  -16.0
   16.0   25.0
  -25.0  -36.0
Program Results 
 AB01OD EXAMPLE PROGRAM RESULTS

 The transformed state transition matrix is 
  12.8848   3.2345  11.8211   3.3758  -0.8982
   4.4741 -12.5544   5.3509   5.9403   1.4360
  14.4576   7.6855  23.1452  26.3872 -29.9557
   0.0000   1.4805  27.4668  22.6564  -0.0072
   0.0000   0.0000 -30.4822   0.6745  18.8680

 The transformed input matrix is 
  31.1199  47.6865
   3.2480   0.0000
   0.0000   0.0000
   0.0000   0.0000
   0.0000   0.0000

 The number of stairs in the staircase form =   3

 The dimensions of the stairs are 
  2    2    1

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB04MD.html000077500000000000000000000250071201767322700160570ustar00rootroot00000000000000 AB04MD - SLICOT Library Routine Documentation

AB04MD

Discrete-time <--> continuous-time systems conversion by a bilinear transformation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform a transformation on the parameters (A,B,C,D) of a
  system, which is equivalent to a bilinear transformation of the
  corresponding transfer function matrix.
Specification 
      SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C,
     $                   LDC, D, LDD, IWORK, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  TYPE    CHARACTER*1
          Indicates the type of the original system and the
          transformation to be performed as follows:
          = 'D':  discrete-time   -> continuous-time;
          = 'C':  continuous-time -> discrete-time.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  ALPHA,  (input) DOUBLE PRECISION
  BETA    Parameters specifying the bilinear transformation.
          Recommended values for stable systems: ALPHA = 1,
          BETA = 1.  ALPHA <> 0, BETA <> 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state matrix A of the original system.
          On exit, the leading N-by-N part of this array contains
                           _
          the state matrix A of the transformed system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B of the original system.
          On exit, the leading N-by-M part of this array contains
                           _
          the input matrix B of the transformed system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C of the original system.
          On exit, the leading P-by-N part of this array contains
                            _
          the output matrix C of the transformed system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the input/output matrix D for the original system.
          On exit, the leading P-by-M part of this array contains
                                  _
          the input/output matrix D of the transformed system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
          For optimum performance LDWORK >= MAX(1,N*NB), where NB
          is the optimal blocksize.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix (ALPHA*I + A) is exactly singular;
          = 2:  if the matrix  (BETA*I - A) is exactly singular.
Method 
  The parameters of the discrete-time system are transformed into
  the parameters of the continuous-time system (TYPE = 'D'), or
  vice-versa (TYPE = 'C') by the transformation:

  1.  Discrete -> continuous
      _                     -1
      A = beta*(alpha*I + A)  * (A - alpha*I)
      _                                     -1
      B = sqrt(2*alpha*beta) * (alpha*I + A)  * B
      _                                         -1
      C = sqrt(2*alpha*beta) * C * (alpha*I + A)
      _                        -1
      D = D - C * (alpha*I + A)  * B

  which is equivalent to the bilinear transformation

                    z - alpha
      z -> s = beta ---------  .
                    z + alpha

  of one transfer matrix onto the other.

  2.  Continuous -> discrete
      _                     -1
      A = alpha*(beta*I - A)  * (beta*I + A)
      _                                    -1
      B = sqrt(2*alpha*beta) * (beta*I - A)  * B
      _                                        -1
      C = sqrt(2*alpha*beta) * C * (beta*I - A)
      _                       -1
      D = D + C * (beta*I - A)  * B

  which is equivalent to the bilinear transformation

                   beta + s
    s -> z = alpha -------- .
                   beta - s

  of one transfer matrix onto the other.
References 
  [1] Al-Saggaf, U.M. and Franklin, G.F.
      Model reduction via balanced realizations: a extension and
      frequency weighting techniques.
      IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988.
Numerical Aspects 
                                                   3
  The time taken is approximately proportional to N .
  The accuracy depends mainly on the condition number of the matrix
  to be inverted.
Further Comments 
  None
Example

Program Text 

*     AB04MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, BETA
      INTEGER          I, INFO, J, M, N, P
      CHARACTER*1      TYPE
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK)
      INTEGER          IWORK(NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB04MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TYPE, ALPHA, BETA
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N )
               READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M )
*              Transform the parameters (A,B,C,D).
               CALL AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB,
     $                      C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99995 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99990 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M )
   80             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB04MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB04MD = ',I2)
99997 FORMAT (' The transformed state matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The transformed input matrix is ')
99994 FORMAT (/' The transformed output matrix is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
99990 FORMAT (/' The transformed input/output matrix is ')
      END
Program Data 
 AB04MD EXAMPLE PROGRAM DATA
   2     2     2     C     1.0D0     1.0D0
   1.0  0.5
   0.5  1.0
   0.0 -1.0
   1.0  0.0
  -1.0  0.0
   0.0  1.0
   1.0  0.0
   0.0 -1.0
Program Results 
 AB04MD EXAMPLE PROGRAM RESULTS

 The transformed state matrix is 
  -1.0000  -4.0000
  -4.0000  -1.0000

 The transformed input matrix is 
   2.8284   0.0000
   0.0000  -2.8284

 The transformed output matrix is 
   0.0000   2.8284
  -2.8284   0.0000

 The transformed input/output matrix is 
  -1.0000   0.0000
   0.0000  -3.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB05MD.html000077500000000000000000000400731201767322700160600ustar00rootroot00000000000000 AB05MD - SLICOT Library Routine Documentation

AB05MD

Cascade inter-connection of two systems in state-space form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To obtain the state-space model (A,B,C,D) for the cascaded
  inter-connection of two systems, each given in state-space form.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Indicates whether the user wishes to obtain the matrix A
          in the upper or lower block diagonal form, as follows:
          = 'U':  Obtain A in the upper block diagonal form;
          = 'L':  Obtain A in the lower block diagonal form.

  OVER    CHARACTER*1
          Indicates whether the user wishes to overlap pairs of
          arrays, as follows:
          = 'N':  Do not overlap;
          = 'O':  Overlap pairs of arrays: A1 and A, B1 and B,
                  C1 and C, and D1 and D (for UPLO = 'L'), or A2
                  and A, B2 and B, C2 and C, and D2 and D (for
                  UPLO = 'U'), i.e. the same name is effectively
                  used for each pair (for all pairs) in the routine
                  call.  In this case, setting LDA1 = LDA,
                  LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD, or
                  LDA2 = LDA, LDB2 = LDB, LDC2 = LDC, and LDD2 = LDD
                  will give maximum efficiency.
Input/Output Parameters 
  N1      (input) INTEGER
          The number of state variables in the first system, i.e.
          the order of the matrix A1.  N1 >= 0.

  M1      (input) INTEGER
          The number of input variables for the first system.
          M1 >= 0.

  P1      (input) INTEGER
          The number of output variables from the first system and
          the number of input variables for the second system.
          P1 >= 0.

  N2      (input) INTEGER
          The number of state variables in the second system, i.e.
          the order of the matrix A2.  N2 >= 0.

  P2      (input) INTEGER
          The number of output variables from the second system.
          P2 >= 0.

  A1      (input) DOUBLE PRECISION array, dimension (LDA1,N1)
          The leading N1-by-N1 part of this array must contain the
          state transition matrix A1 for the first system.

  LDA1    INTEGER
          The leading dimension of array A1.  LDA1 >= MAX(1,N1).

  B1      (input) DOUBLE PRECISION array, dimension (LDB1,M1)
          The leading N1-by-M1 part of this array must contain the
          input/state matrix B1 for the first system.

  LDB1    INTEGER
          The leading dimension of array B1.  LDB1 >= MAX(1,N1).

  C1      (input) DOUBLE PRECISION array, dimension (LDC1,N1)
          The leading P1-by-N1 part of this array must contain the
          state/output matrix C1 for the first system.

  LDC1    INTEGER
          The leading dimension of array C1.
          LDC1 >= MAX(1,P1) if N1 > 0.
          LDC1 >= 1 if N1 = 0.

  D1      (input) DOUBLE PRECISION array, dimension (LDD1,M1)
          The leading P1-by-M1 part of this array must contain the
          input/output matrix D1 for the first system.

  LDD1    INTEGER
          The leading dimension of array D1.  LDD1 >= MAX(1,P1).

  A2      (input) DOUBLE PRECISION array, dimension (LDA2,N2)
          The leading N2-by-N2 part of this array must contain the
          state transition matrix A2 for the second system.

  LDA2    INTEGER
          The leading dimension of array A2.  LDA2 >= MAX(1,N2).

  B2      (input) DOUBLE PRECISION array, dimension (LDB2,P1)
          The leading N2-by-P1 part of this array must contain the
          input/state matrix B2 for the second system.

  LDB2    INTEGER
          The leading dimension of array B2.  LDB2 >= MAX(1,N2).

  C2      (input) DOUBLE PRECISION array, dimension (LDC2,N2)
          The leading P2-by-N2 part of this array must contain the
          state/output matrix C2 for the second system.

  LDC2    INTEGER
          The leading dimension of array C2.
          LDC2 >= MAX(1,P2) if N2 > 0.
          LDC2 >= 1 if N2 = 0.

  D2      (input) DOUBLE PRECISION array, dimension (LDD2,P1)
          The leading P2-by-P1 part of this array must contain the
          input/output matrix D2 for the second system.

  LDD2    INTEGER
          The leading dimension of array D2.  LDD2 >= MAX(1,P2).

  N       (output) INTEGER
          The number of state variables (N1 + N2) in the resulting
          system, i.e. the order of the matrix A, the number of rows
          of B and the number of columns of C.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N1+N2)
          The leading N-by-N part of this array contains the state
          transition matrix A for the cascaded system.
          If OVER = 'O', the array A can overlap A1, if UPLO = 'L',
          or A2, if UPLO = 'U'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N1+N2).

  B       (output) DOUBLE PRECISION array, dimension (LDB,M1)
          The leading N-by-M1 part of this array contains the
          input/state matrix B for the cascaded system.
          If OVER = 'O', the array B can overlap B1, if UPLO = 'L',
          or B2, if UPLO = 'U'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N1+N2).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N1+N2)
          The leading P2-by-N part of this array contains the
          state/output matrix C for the cascaded system.
          If OVER = 'O', the array C can overlap C1, if UPLO = 'L',
          or C2, if UPLO = 'U'.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P2) if N1+N2 > 0.
          LDC >= 1 if N1+N2 = 0.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M1)
          The leading P2-by-M1 part of this array contains the
          input/output matrix D for the cascaded system.
          If OVER = 'O', the array D can overlap D1, if UPLO = 'L',
          or D2, if UPLO = 'U'.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P2).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          The array DWORK is not referenced if OVER = 'N'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, P1*MAX(N1, M1, N2, P2) ) if OVER = 'O'.
          LDWORK >= 1 if OVER = 'N'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  After cascaded inter-connection of the two systems

  X1'     = A1*X1 + B1*U
  V       = C1*X1 + D1*U

  X2'     = A2*X2 + B2*V
  Y       = C2*X2 + D2*V

  (where  '  denotes differentiation with respect to time)

  the following state-space model will be obtained:

  X'      = A*X + B*U
  Y       = C*X + D*U

  where matrix  A  has the form   ( A1     0 ),
                                  ( B2*C1  A2)

        matrix  B  has the form  (  B1   ),
                                 ( B2*D1 )

        matrix  C  has the form  ( D2*C1  C2 ) and

        matrix  D  has the form  ( D2*D1 ).

  This form is returned by the routine when UPLO = 'L'.  Note that
  when A1 and A2 are block lower triangular, the resulting state
  matrix is also block lower triangular.

  By applying a similarity transformation to the system above,
  using the matrix  ( 0  I ),  where  I  is the identity matrix of
                    ( J  0 )
  order  N2,  and  J  is the identity matrix of order  N1,  the
  system matrices become

        A = ( A2  B2*C1 ),
            ( 0     A1  )

        B = ( B2*D1 ),
            (  B1   )

        C = ( C2  D2*C1 ) and

        D = ( D2*D1 ).

  This form is returned by the routine when UPLO = 'U'.  Note that
  when A1 and A2 are block upper triangular (for instance, in the
  real Schur form), the resulting state matrix is also block upper
  triangular.
References 
  None
Numerical Aspects 
  The algorithm requires P1*(N1+M1)*(N2+P2) operations.
Further Comments 
  None
Example

Program Text 

*     AB05MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          N1MAX, N2MAX, NMAX, M1MAX, P1MAX, P2MAX
      PARAMETER        ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX,
     $                   M1MAX = 20, P1MAX = 20, P2MAX = 20 )
      INTEGER          LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1,
     $                 LDC2, LDD, LDD1, LDD2, LDWORK
      PARAMETER        ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX,
     $                   LDB = NMAX,LDB1 = N1MAX, LDB2 = N2MAX,
     $                   LDC = P2MAX, LDC1 = P1MAX, LDC2 = P2MAX,
     $                   LDD = P2MAX, LDD1 = P1MAX, LDD2 = P2MAX,
     $                   LDWORK = P1MAX*N1MAX )
*     .. Local Scalars ..
      CHARACTER*1      OVER, UPLO
      INTEGER          I, INFO, J, M1, N, N1, N2, P1, P2
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX),
     $                 B(LDB,M1MAX), B1(LDB1,M1MAX), B2(LDB2,P1MAX),
     $                 C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX),
     $                 D(LDD,M1MAX), D1(LDD1,M1MAX), D2(LDD2,P1MAX),
     $                 DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         AB05MD
*     .. Executable Statements ..
*
      UPLO = 'Lower'
      OVER = 'N'
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N1, M1, P1, N2, P2
      IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N1
      ELSE
         READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 )
         IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M1
         ELSE
            READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 )
            IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P1
            ELSE
               READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 )
               READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 )
               IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N2
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( A2(I,J), J = 1,N2 ), I = 1,N2 )
                  READ ( NIN, FMT = * )
     $                 ( ( B2(I,J), I = 1,N2 ), J = 1,P1 )
                  IF ( P2.LE.0 .OR. P2.GT.P2MAX ) THEN
                     WRITE ( NOUT, FMT = 99988 ) P2
                  ELSE
                     READ ( NIN, FMT = * )
     $                    ( ( C2(I,J), J = 1,N2 ), I = 1,P2 )
                     READ ( NIN, FMT = * )
     $                    ( ( D2(I,J), J = 1,P1 ), I = 1,P2 )
*                    Find the state-space model (A,B,C,D).
                     CALL 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 )
*
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99998 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99997 )
                        DO 20 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( A(I,J), J = 1,N )
   20                   CONTINUE
                        WRITE ( NOUT, FMT = 99995 )
                        DO 40 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( B(I,J), J = 1,M1 )
   40                   CONTINUE
                        WRITE ( NOUT, FMT = 99994 )
                        DO 60 I = 1, P2
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( C(I,J), J = 1,N )
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99993 )
                        DO 80 I = 1, P2
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( D(I,J), J = 1,M1 )
   80                   CONTINUE
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05MD = ',I2)
99997 FORMAT (' The state transition matrix of the cascaded system is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the cascaded system is ')
99994 FORMAT (/' The state/output matrix of the cascaded system is ')
99993 FORMAT (/' The input/output matrix of the cascaded system is ')
99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5)
99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5)
99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5)
99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5)
99988 FORMAT (/' P2 is out of range.',/' P2 = ',I5)
      END
Program Data 
 AB05MD EXAMPLE PROGRAM DATA
   3     2     2     3     2
   1.0   0.0  -1.0
   0.0  -1.0   1.0
   1.0   1.0   2.0
   1.0   1.0   0.0
   2.0   0.0   1.0
   3.0  -2.0   1.0
   0.0   1.0   0.0
   1.0   0.0
   0.0   1.0
  -3.0   0.0   0.0
   1.0   0.0   1.0
   0.0  -1.0   2.0
   0.0  -1.0   0.0
   1.0   0.0   2.0
   1.0   1.0   0.0
   1.0   1.0  -1.0
   1.0   1.0
   0.0   1.0
Program Results 
 AB05MD EXAMPLE PROGRAM RESULTS

 The state transition matrix of the cascaded system is 
   1.0000   0.0000  -1.0000   0.0000   0.0000   0.0000
   0.0000  -1.0000   1.0000   0.0000   0.0000   0.0000
   1.0000   1.0000   2.0000   0.0000   0.0000   0.0000
   0.0000   1.0000   0.0000  -3.0000   0.0000   0.0000
  -3.0000   2.0000  -1.0000   1.0000   0.0000   1.0000
   0.0000   2.0000   0.0000   0.0000  -1.0000   2.0000

 The input/state matrix of the cascaded system is 
   1.0000   2.0000
   1.0000   0.0000
   0.0000   1.0000
   0.0000   1.0000
  -1.0000   0.0000
   0.0000   2.0000

 The state/output matrix of the cascaded system is 
   3.0000  -1.0000   1.0000   1.0000   1.0000   0.0000
   0.0000   1.0000   0.0000   1.0000   1.0000  -1.0000

 The input/output matrix of the cascaded system is 
   1.0000   1.0000
   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB05ND.html000077500000000000000000000370251201767322700160640ustar00rootroot00000000000000 AB05ND - SLICOT Library Routine Documentation

AB05ND

Feedback inter-connection of two systems in state-space form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To obtain the state-space model (A,B,C,D) for the feedback
  inter-connection of two systems, each given in state-space form.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  OVER    CHARACTER*1
          Indicates whether the user wishes to overlap pairs of
          arrays, as follows:
          = 'N':  Do not overlap;
          = 'O':  Overlap pairs of arrays: A1 and A, B1 and B,
                  C1 and C, and D1 and D, i.e. the same name is
                  effectively used for each pair (for all pairs)
                  in the routine call.  In this case, setting
                  LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD
                  will give maximum efficiency.
Input/Output Parameters 
  N1      (input) INTEGER
          The number of state variables in the first system, i.e.
          the order of the matrix A1.  N1 >= 0.

  M1      (input) INTEGER
          The number of input variables for the first system and the
          number of output variables from the second system.
          M1 >= 0.

  P1      (input) INTEGER
          The number of output variables from the first system and
          the number of input variables for the second system.
          P1 >= 0.

  N2      (input) INTEGER
          The number of state variables in the second system, i.e.
          the order of the matrix A2.  N2 >= 0.

  ALPHA   (input) DOUBLE PRECISION
          A coefficient multiplying the transfer-function matrix
          (or the output equation) of the second system.
          ALPHA = +1 corresponds to positive feedback, and
          ALPHA = -1 corresponds to negative feedback.

  A1      (input) DOUBLE PRECISION array, dimension (LDA1,N1)
          The leading N1-by-N1 part of this array must contain the
          state transition matrix A1 for the first system.

  LDA1    INTEGER
          The leading dimension of array A1.  LDA1 >= MAX(1,N1).

  B1      (input) DOUBLE PRECISION array, dimension (LDB1,M1)
          The leading N1-by-M1 part of this array must contain the
          input/state matrix B1 for the first system.

  LDB1    INTEGER
          The leading dimension of array B1.  LDB1 >= MAX(1,N1).

  C1      (input) DOUBLE PRECISION array, dimension (LDC1,N1)
          The leading P1-by-N1 part of this array must contain the
          state/output matrix C1 for the first system.

  LDC1    INTEGER
          The leading dimension of array C1.
          LDC1 >= MAX(1,P1) if N1 > 0.
          LDC1 >= 1 if N1 = 0.

  D1      (input) DOUBLE PRECISION array, dimension (LDD1,M1)
          The leading P1-by-M1 part of this array must contain the
          input/output matrix D1 for the first system.

  LDD1    INTEGER
          The leading dimension of array D1.  LDD1 >= MAX(1,P1).

  A2      (input) DOUBLE PRECISION array, dimension (LDA2,N2)
          The leading N2-by-N2 part of this array must contain the
          state transition matrix A2 for the second system.

  LDA2    INTEGER
          The leading dimension of array A2.  LDA2 >= MAX(1,N2).

  B2      (input) DOUBLE PRECISION array, dimension (LDB2,P1)
          The leading N2-by-P1 part of this array must contain the
          input/state matrix B2 for the second system.

  LDB2    INTEGER
          The leading dimension of array B2.  LDB2 >= MAX(1,N2).

  C2      (input) DOUBLE PRECISION array, dimension (LDC2,N2)
          The leading M1-by-N2 part of this array must contain the
          state/output matrix C2 for the second system.

  LDC2    INTEGER
          The leading dimension of array C2.
          LDC2 >= MAX(1,M1) if N2 > 0.
          LDC2 >= 1 if N2 = 0.

  D2      (input) DOUBLE PRECISION array, dimension (LDD2,P1)
          The leading M1-by-P1 part of this array must contain the
          input/output matrix D2 for the second system.

  LDD2    INTEGER
          The leading dimension of array D2.  LDD2 >= MAX(1,M1).

  N       (output) INTEGER
          The number of state variables (N1 + N2) in the connected
          system, i.e. the order of the matrix A, the number of rows
          of B and the number of columns of C.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N1+N2)
          The leading N-by-N part of this array contains the state
          transition matrix A for the connected system.
          The array A can overlap A1 if OVER = 'O'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N1+N2).

  B       (output) DOUBLE PRECISION array, dimension (LDB,M1)
          The leading N-by-M1 part of this array contains the
          input/state matrix B for the connected system.
          The array B can overlap B1 if OVER = 'O'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N1+N2).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N1+N2)
          The leading P1-by-N part of this array contains the
          state/output matrix C for the connected system.
          The array C can overlap C1 if OVER = 'O'.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P1) if N1+N2 > 0.
          LDC >= 1 if N1+N2 = 0.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M1)
          The leading P1-by-M1 part of this array contains the
          input/output matrix D for the connected system.
          The array D can overlap D1 if OVER = 'O'.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P1).
Workspace 
  IWORK   INTEGER array, dimension (P1)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.             If OVER = 'N',
          LDWORK >= MAX(1, P1*P1, M1*M1, N1*P1), and if OVER = 'O',
          LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*M1, N1*P1) ),
                                                     if M1 <= N*N2;
          LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*(M1+1), N1*P1) ),
                                                     if M1 >  N*N2.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
          > 0:  if INFO = i, 1 <= i <= P1, the system is not
                completely controllable. That is, the matrix
                (I + ALPHA*D1*D2) is exactly singular (the element
                U(i,i) of the upper triangular factor of LU
                factorization is exactly zero), possibly due to
                rounding errors.
Method 
  After feedback inter-connection of the two systems,

  X1'     = A1*X1 + B1*U1
  Y1      = C1*X1 + D1*U1

  X2'     = A2*X2 + B2*U2
  Y2      = C2*X2 + D2*U2

  (where  '  denotes differentiation with respect to time)

  the following state-space model will be obtained:

  X'      = A*X  +  B*U
  Y       = C*X  +  D*U

  where       U = U1 + alpha*Y2,    X  =  ( X1 ),
              Y = Y1 = U2,                ( X2 )

  matrix  A  has the form

  ( A1  -  alpha*B1*E12*D2*C1       -  alpha*B1*E12*C2    ),
  (        B2*E21*C1            A2  -  alpha*B2*E21*D1*C2 )

  matrix  B  has the form

  (  B1*E12    ),
  (  B2*E21*D1 )

  matrix  C  has the form

  (  E21*C1     -  alpha*E21*D1*C2 ),

  matrix D  has the form

  (  E21*D1 ),

  E21  =  ( I + alpha*D1*D2 )-INVERSE and
  E12  =  ( I + alpha*D2*D1 )-INVERSE = I - alpha*D2*E21*D1.

  Taking N1 = 0 and/or N2 = 0 on the routine call will solve the
  constant plant and/or constant feedback cases.
References 
  None
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

*     AB05ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          N1MAX, N2MAX, NMAX, M1MAX, P1MAX
      PARAMETER        ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX,
     $                   M1MAX = 20, P1MAX = 20 )
      INTEGER          LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1,
     $                 LDC2, LDD, LDD1, LDD2
      PARAMETER        ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX,
     $                   LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX,
     $                   LDC = P1MAX, LDC1 = P1MAX, LDC2 = M1MAX,
     $                   LDD = P1MAX, LDD1 = P1MAX, LDD2 = M1MAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = P1MAX*P1MAX )
      DOUBLE PRECISION ONE
      PARAMETER        ( ONE=1.0D0 )
*     .. Local Scalars ..
      CHARACTER*1      OVER
      INTEGER          I, INFO, J, M1, N, N1, N2, P1
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      INTEGER          IWORK(P1MAX)
      DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX),
     $                 B(LDB,M1MAX), B1(LDB1,M1MAX), B2(LDB2,P1MAX),
     $                 C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX),
     $                 D(LDD,M1MAX), D1(LDD1,M1MAX), D2(LDD2,P1MAX),
     $                 DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         AB05ND
*     .. Executable Statements ..
*
      OVER = 'N'
      ALPHA = ONE
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N1, M1, P1, N2
      IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N1
      ELSE
         READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 )
         IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M1
         ELSE
            READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 )
            IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P1
            ELSE
               READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 )
               READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 )
               IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N2
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( A2(I,J), J = 1,N2 ), I = 1,N2 )
                  READ ( NIN, FMT = * )
     $                 ( ( B2(I,J), I = 1,N2 ), J = 1,P1 )
                  READ ( NIN, FMT = * )
     $                 ( ( C2(I,J), J = 1,N2 ), I = 1,M1 )
                  READ ( NIN, FMT = * )
     $                 ( ( D2(I,J), J = 1,P1 ), I = 1,M1 )
*                 Find the state-space model (A,B,C,D).
                  CALL 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 )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99997 )
                     DO 20 I = 1, N
                        WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 40 I = 1, N
                        WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M1 )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99994 )
                     DO 60 I = 1, P1
                        WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   60                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 80 I = 1, P1
                        WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M1 )
   80                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05ND = ',I2)
99997 FORMAT (' The state transition matrix of the connected system is')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the connected system is ')
99994 FORMAT (/' The state/output matrix of the connected system is ')
99993 FORMAT (/' The input/output matrix of the connected system is ')
99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5)
99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5)
99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5)
99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5)
      END
Program Data 
 AB05ND EXAMPLE PROGRAM DATA
   3     2     2     3
   1.0   0.0  -1.0
   0.0  -1.0   1.0
   1.0   1.0   2.0
   1.0   1.0   0.0
   2.0   0.0   1.0
   3.0  -2.0   1.0
   0.0   1.0   0.0
   1.0   0.0
   0.0   1.0
  -3.0   0.0   0.0
   1.0   0.0   1.0
   0.0  -1.0   2.0
   0.0  -1.0   0.0
   1.0   0.0   2.0
   1.0   1.0   0.0
   1.0   1.0  -1.0
   1.0   1.0
   0.0   1.0
Program Results 
 AB05ND EXAMPLE PROGRAM RESULTS

 The state transition matrix of the connected system is
  -0.5000  -0.2500  -1.5000  -1.2500  -1.2500   0.7500
  -1.5000  -0.2500   0.5000  -0.2500  -0.2500  -0.2500
   1.0000   0.5000   2.0000  -0.5000  -0.5000   0.5000
   0.0000   0.5000   0.0000  -3.5000  -0.5000   0.5000
  -1.5000   1.2500  -0.5000   1.2500   0.2500   1.2500
   0.0000   1.0000   0.0000  -1.0000  -2.0000   3.0000

 The input/state matrix of the connected system is 
   0.5000   0.7500
   0.5000  -0.2500
   0.0000   0.5000
   0.0000   0.5000
  -0.5000   0.2500
   0.0000   1.0000

 The state/output matrix of the connected system is 
   1.5000  -1.2500   0.5000  -0.2500  -0.2500  -0.2500
   0.0000   0.5000   0.0000  -0.5000  -0.5000   0.5000

 The input/output matrix of the connected system is 
   0.5000  -0.2500
   0.0000   0.5000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB05OD.html000077500000000000000000000356021201767322700160640ustar00rootroot00000000000000 AB05OD - SLICOT Library Routine Documentation

AB05OD

Rowwise concatenation of two systems in state-space form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To obtain the state-space model (A,B,C,D) for rowwise
  concatenation (parallel inter-connection on outputs, with separate
  inputs) of two systems, each given in state-space form.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  OVER    CHARACTER*1
          Indicates whether the user wishes to overlap pairs of
          arrays, as follows:
          = 'N':  Do not overlap;
          = 'O':  Overlap pairs of arrays: A1 and A, B1 and B,
                  C1 and C, and D1 and D, i.e. the same name is
                  effectively used for each pair (for all pairs)
                  in the routine call.  In this case, setting
                  LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD
                  will give maximum efficiency.
Input/Output Parameters 
  N1      (input) INTEGER
          The number of state variables in the first system, i.e.
          the order of the matrix A1.  N1 >= 0.

  M1      (input) INTEGER
          The number of input variables for the first system.
          M1 >= 0.

  P1      (input) INTEGER
          The number of output variables from each system.  P1 >= 0.

  N2      (input) INTEGER
          The number of state variables in the second system, i.e.
          the order of the matrix A2.  N2 >= 0.

  M2      (input) INTEGER
          The number of input variables for the second system.
          M2 >= 0.

  ALPHA   (input) DOUBLE PRECISION
          A coefficient multiplying the transfer-function matrix
          (or the output equation) of the second system.

  A1      (input) DOUBLE PRECISION array, dimension (LDA1,N1)
          The leading N1-by-N1 part of this array must contain the
          state transition matrix A1 for the first system.

  LDA1    INTEGER
          The leading dimension of array A1.  LDA1 >= MAX(1,N1).

  B1      (input) DOUBLE PRECISION array, dimension (LDB1,M1)
          The leading N1-by-M1 part of this array must contain the
          input/state matrix B1 for the first system.

  LDB1    INTEGER
          The leading dimension of array B1.  LDB1 >= MAX(1,N1).

  C1      (input) DOUBLE PRECISION array, dimension (LDC1,N1)
          The leading P1-by-N1 part of this array must contain the
          state/output matrix C1 for the first system.

  LDC1    INTEGER
          The leading dimension of array C1.
          LDC1 >= MAX(1,P1) if N1 > 0.
          LDC1 >= 1 if N1 = 0.

  D1      (input) DOUBLE PRECISION array, dimension (LDD1,M1)
          The leading P1-by-M1 part of this array must contain the
          input/output matrix D1 for the first system.

  LDD1    INTEGER
          The leading dimension of array D1.  LDD1 >= MAX(1,P1).

  A2      (input) DOUBLE PRECISION array, dimension (LDA2,N2)
          The leading N2-by-N2 part of this array must contain the
          state transition matrix A2 for the second system.

  LDA2    INTEGER
          The leading dimension of array A2.  LDA2 >= MAX(1,N2).

  B2      (input) DOUBLE PRECISION array, dimension (LDB2,M2)
          The leading N2-by-M2 part of this array must contain the
          input/state matrix B2 for the second system.

  LDB2    INTEGER
          The leading dimension of array B2.  LDB2 >= MAX(1,N2).

  C2      (input) DOUBLE PRECISION array, dimension (LDC2,N2)
          The leading P1-by-N2 part of this array must contain the
          state/output matrix C2 for the second system.

  LDC2    INTEGER
          The leading dimension of array C2.
          LDC2 >= MAX(1,P1) if N2 > 0.
          LDC2 >= 1 if N2 = 0.

  D2      (input) DOUBLE PRECISION array, dimension (LDD2,M2)
          The leading P1-by-M2 part of this array must contain the
          input/output matrix D2 for the second system.

  LDD2    INTEGER
          The leading dimension of array D2.  LDD2 >= MAX(1,P1).

  N       (output) INTEGER
          The number of state variables (N1 + N2) in the connected
          system, i.e. the order of the matrix A, the number of rows
          of B and the number of columns of C.

  M       (output) INTEGER
          The number of input variables (M1 + M2) for the connected
          system, i.e. the number of columns of B and D.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N1+N2)
          The leading N-by-N part of this array contains the state
          transition matrix A for the connected system.
          The array A can overlap A1 if OVER = 'O'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N1+N2).

  B       (output) DOUBLE PRECISION array, dimension (LDB,M1+M2)
          The leading N-by-M part of this array contains the
          input/state matrix B for the connected system.
          The array B can overlap B1 if OVER = 'O'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N1+N2).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N1+N2)
          The leading P1-by-N part of this array contains the
          state/output matrix C for the connected system.
          The array C can overlap C1 if OVER = 'O'.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P1) if N1+N2 > 0.
          LDC >= 1 if N1+N2 = 0.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M1+M2)
          The leading P1-by-M part of this array contains the
          input/output matrix D for the connected system.
          The array D can overlap D1 if OVER = 'O'.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P1).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  After rowwise concatenation (parallel inter-connection with
  separate inputs) of the two systems,

  X1'     = A1*X1 + B1*U
  Y1      = C1*X1 + D1*U

  X2'     = A2*X2 + B2*V
  Y2      = C2*X2 + D2*V

  (where  '  denotes differentiation with respect to time),

  with the output equation for the second system multiplied by a
  scalar alpha, the following state-space model will be obtained:

  X'      = A*X + B*(U)
                    (V)

  Y       = C*X + D*(U)
                    (V)

  where matrix  A  has the form    ( A1   0  ),
                                   ( 0    A2 )

        matrix  B  has the form    ( B1   0  ),
                                   ( 0    B2 )

        matrix  C  has the form    ( C1   alpha*C2 ) and

        matrix  D  has the form    ( D1   alpha*D2 ).
References 
  None
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

*     AB05OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          N1MAX, N2MAX, NMAX, M1MAX, M2MAX, MMAX, P1MAX
      PARAMETER        ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX,
     $                   M1MAX = 20, M2MAX = 20, MMAX = M1MAX+M2MAX,
     $                   P1MAX = 20 )
      INTEGER          LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1,
     $                 LDC2, LDD, LDD1, LDD2
      PARAMETER        ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX,
     $                   LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX,
     $                   LDC = P1MAX, LDC1 = P1MAX, LDC2 = P1MAX,
     $                   LDD = P1MAX, LDD1 = P1MAX, LDD2 = P1MAX )
      DOUBLE PRECISION ONE
      PARAMETER        ( ONE=1.0D0 )
*     .. Local Scalars ..
      CHARACTER*1      OVER
      INTEGER          I, INFO, J, M, M1, M2, N, N1, N2, P1
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX),
     $                 B(LDB,MMAX), B1(LDB1,M1MAX), B2(LDB2,M2MAX),
     $                 C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX),
     $                 D(LDD,MMAX), D1(LDD1,M1MAX), D2(LDD2,M2MAX)
*     .. External Subroutines ..
      EXTERNAL         AB05OD
*     .. Executable Statements ..
*
      OVER = 'N'
      ALPHA = ONE
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N1, M1, P1, N2, M2
      IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N1
      ELSE
         READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 )
         IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M1
         ELSE
            READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 )
            IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P1
            ELSE
               READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 )
               READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 )
               IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN
                  WRITE ( NOUT, FMT = 99990 ) N2
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( A2(I,J), J = 1,N2 ), I = 1,N2 )
                  IF ( M2.LE.0 .OR. M2.GT.M2MAX ) THEN
                     WRITE ( NOUT, FMT = 99989 ) M2
                  ELSE
                     READ ( NIN, FMT = * )
     $                    ( ( B2(I,J), I = 1,N2 ), J = 1,M2 )
                     READ ( NIN, FMT = * )
     $                    ( ( C2(I,J), J = 1,N2 ), I = 1,P1 )
                     READ ( NIN, FMT = * )
     $                    ( ( D2(I,J), J = 1,M2 ), I = 1,P1 )
*                       Find the state-space model (A,B,C,D).
                     CALL 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 )
*
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99998 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99997 )
                        DO 20 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( A(I,J), J = 1,N )
   20                   CONTINUE
                        WRITE ( NOUT, FMT = 99995 )
                        DO 40 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( B(I,J), J = 1,M )
   40                   CONTINUE
                        WRITE ( NOUT, FMT = 99994 )
                        DO 60 I = 1, P1
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( C(I,J), J = 1,N )
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99993 )
                        DO 80 I = 1, P1
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( D(I,J), J = 1,M )
   80                   CONTINUE
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05OD = ',I2)
99997 FORMAT (' The state transition matrix of the connected system is')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the connected system is ')
99994 FORMAT (/' The state/output matrix of the connected system is ')
99993 FORMAT (/' The input/output matrix of the connected system is ')
99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5)
99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5)
99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5)
99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5)
      END
Program Data 
 AB05OD EXAMPLE PROGRAM DATA
   3     2     2     3     2
   1.0   0.0  -1.0
   0.0  -1.0   1.0
   1.0   1.0   2.0
   1.0   1.0   0.0
   2.0   0.0   1.0
   3.0  -2.0   1.0
   0.0   1.0   0.0
   1.0   0.0
   0.0   1.0
  -3.0   0.0   0.0
   1.0   0.0   1.0
   0.0  -1.0   2.0
   0.0  -1.0   0.0
   1.0   0.0   2.0
   1.0   1.0   0.0
   1.0   1.0  -1.0
   1.0   1.0
   0.0   1.0
Program Results 
 AB05OD EXAMPLE PROGRAM RESULTS

 The state transition matrix of the connected system is
   1.0000   0.0000  -1.0000   0.0000   0.0000   0.0000
   0.0000  -1.0000   1.0000   0.0000   0.0000   0.0000
   1.0000   1.0000   2.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000  -3.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000   0.0000   1.0000
   0.0000   0.0000   0.0000   0.0000  -1.0000   2.0000

 The input/state matrix of the connected system is 
   1.0000   2.0000   0.0000   0.0000
   1.0000   0.0000   0.0000   0.0000
   0.0000   1.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000
   0.0000   0.0000  -1.0000   0.0000
   0.0000   0.0000   0.0000   2.0000

 The state/output matrix of the connected system is 
   3.0000  -2.0000   1.0000   1.0000   1.0000   0.0000
   0.0000   1.0000   0.0000   1.0000   1.0000  -1.0000

 The input/output matrix of the connected system is 
   1.0000   0.0000   1.0000   1.0000
   0.0000   1.0000   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB05PD.html000077500000000000000000000331501201767322700160610ustar00rootroot00000000000000 AB05PD - SLICOT Library Routine Documentation

AB05PD

Parallel inter-connection of two systems in state-space form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the state-space model G = (A,B,C,D) corresponding to
  the sum G = G1 + alpha*G2, where G1 = (A1,B1,C1,D1) and
  G2 = (A2,B2,C2,D2).  G, G1, and G2 are the transfer-function
  matrices of the corresponding state-space models.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  OVER    CHARACTER*1
          Indicates whether the user wishes to overlap pairs of
          arrays, as follows:
          = 'N':  Do not overlap;
          = 'O':  Overlap pairs of arrays: A1 and A, B1 and B,
                  C1 and C, and D1 and D, i.e. the same name is
                  effectively used for each pair (for all pairs)
                  in the routine call.  In this case, setting
                  LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD
                  will give maximum efficiency.
Input/Output Parameters 
  N1      (input) INTEGER
          The number of state variables in the first system, i.e.
          the order of the matrix A1, the number of rows of B1 and
          the number of columns of C1.  N1 >= 0.

  M       (input) INTEGER
          The number of input variables of the two systems, i.e. the
          number of columns of matrices B1, D1, B2 and D2.  M >= 0.

  P       (input) INTEGER
          The number of output variables of the two systems, i.e.
          the number of rows of matrices C1, D1, C2 and D2.  P >= 0.

  N2      (input) INTEGER
          The number of state variables in the second system, i.e.
          the order of the matrix A2, the number of rows of B2 and
          the number of columns of C2.  N2 >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The coefficient multiplying G2.

  A1      (input) DOUBLE PRECISION array, dimension (LDA1,N1)
          The leading N1-by-N1 part of this array must contain the
          state transition matrix A1 for the first system.

  LDA1    INTEGER
          The leading dimension of array A1.  LDA1 >= MAX(1,N1).

  B1      (input) DOUBLE PRECISION array, dimension (LDB1,M)
          The leading N1-by-M part of this array must contain the
          input/state matrix B1 for the first system.

  LDB1    INTEGER
          The leading dimension of array B1.  LDB1 >= MAX(1,N1).

  C1      (input) DOUBLE PRECISION array, dimension (LDC1,N1)
          The leading P-by-N1 part of this array must contain the
          state/output matrix C1 for the first system.

  LDC1    INTEGER
          The leading dimension of array C1.
          LDC1 >= MAX(1,P) if N1 > 0.
          LDC1 >= 1 if N1 = 0.

  D1      (input) DOUBLE PRECISION array, dimension (LDD1,M)
          The leading P-by-M part of this array must contain the
          input/output matrix D1 for the first system.

  LDD1    INTEGER
          The leading dimension of array D1.  LDD1 >= MAX(1,P).

  A2      (input) DOUBLE PRECISION array, dimension (LDA2,N2)
          The leading N2-by-N2 part of this array must contain the
          state transition matrix A2 for the second system.

  LDA2    INTEGER
          The leading dimension of array A2.  LDA2 >= MAX(1,N2).

  B2      (input) DOUBLE PRECISION array, dimension (LDB2,M)
          The leading N2-by-M part of this array must contain the
          input/state matrix B2 for the second system.

  LDB2    INTEGER
          The leading dimension of array B2.  LDB2 >= MAX(1,N2).

  C2      (input) DOUBLE PRECISION array, dimension (LDC2,N2)
          The leading P-by-N2 part of this array must contain the
          state/output matrix C2 for the second system.

  LDC2    INTEGER
          The leading dimension of array C2.
          LDC2 >= MAX(1,P) if N2 > 0.
          LDC2 >= 1 if N2 = 0.

  D2      (input) DOUBLE PRECISION array, dimension (LDD2,M)
          The leading P-by-M part of this array must contain the
          input/output matrix D2 for the second system.

  LDD2    INTEGER
          The leading dimension of array D2.  LDD2 >= MAX(1,P).

  N       (output) INTEGER
          The number of state variables (N1 + N2) in the resulting
          system, i.e. the order of the matrix A, the number of rows
          of B and the number of columns of C.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N1+N2)
          The leading N-by-N part of this array contains the state
          transition matrix A for the resulting system.
          The array A can overlap A1 if OVER = 'O'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N1+N2).

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array contains the
          input/state matrix B for the resulting system.
          The array B can overlap B1 if OVER = 'O'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N1+N2).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N1+N2)
          The leading P-by-N part of this array contains the
          state/output matrix C for the resulting system.
          The array C can overlap C1 if OVER = 'O'.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P) if N1+N2 > 0.
          LDC >= 1 if N1+N2 = 0.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array contains the
          input/output matrix D for the resulting system.
          The array D can overlap D1 if OVER = 'O'.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrices of the resulting systems are determined as:

        ( A1   0  )             ( B1 )
    A = (         ) ,       B = (    ) ,
        ( 0    A2 )             ( B2 )

    C = ( C1  alpha*C2 ) ,  D = D1 + alpha*D2 .
References 
  None
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

*     AB05PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          N1MAX, N2MAX, NMAX, MMAX, PMAX
      PARAMETER        ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX,
     $                   MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1,
     $                 LDC2, LDD, LDD1, LDD2
      PARAMETER        ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX,
     $                   LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX,
     $                   LDC = PMAX, LDC1 = PMAX,  LDC2 = PMAX,
     $                   LDD = PMAX, LDD1 = PMAX,  LDD2 = PMAX )
*     .. Local Scalars ..
      CHARACTER*1      OVER
      INTEGER          I, INFO, J, M, N, N1, N2, P
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX),
     $                 B(LDB,MMAX), B1(LDB1,MMAX), B2(LDB2,MMAX),
     $                 C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX),
     $                 D(LDD,MMAX), D1(LDD1,MMAX), D2(LDD2,MMAX)
*     .. External Subroutines ..
      EXTERNAL         AB05PD
*     .. Executable Statements ..
*
      OVER = 'N'
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N1, M, P, N2, ALPHA
      IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N1
      ELSE
         READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M ), I = 1,P )
               IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N2
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( A2(I,J), J = 1,N2 ), I = 1,N2 )
                  READ ( NIN, FMT = * )
     $                 ( ( B2(I,J), I = 1,N2 ), J = 1,M )
                  READ ( NIN, FMT = * )
     $                 ( ( C2(I,J), J = 1,N2 ), I = 1,P )
                  READ ( NIN, FMT = * )
     $                 ( ( D2(I,J), J = 1,M ), I = 1,P )
*                    Find the state-space model (A,B,C,D).
                  CALL 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 )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99997 )
                     DO 20 I = 1, N
                        WRITE ( NOUT, FMT = 99996 )
     $                        ( A(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 40 I = 1, N
                        WRITE ( NOUT, FMT = 99996 )
     $                        ( B(I,J), J = 1,M )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99994 )
                     DO 60 I = 1, P
                        WRITE ( NOUT, FMT = 99996 )
     $                        ( C(I,J), J = 1,N )
   60                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 80 I = 1, P
                        WRITE ( NOUT, FMT = 99996 )
     $                        ( D(I,J), J = 1,M )
   80                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05PD = ',I2)
99997 FORMAT (' The state transition matrix of the connected system is')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the connected system is ')
99994 FORMAT (/' The state/output matrix of the connected system is ')
99993 FORMAT (/' The input/output matrix of the connected system is ')
99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5)
      END
Program Data 
 AB05PD EXAMPLE PROGRAM DATA
   3     2     2     3     1.0D0
   1.0   0.0  -1.0
   0.0  -1.0   1.0
   1.0   1.0   2.0
   1.0   1.0   0.0
   2.0   0.0   1.0
   3.0  -2.0   1.0
   0.0   1.0   0.0
   1.0   0.0
   0.0   1.0
  -3.0   0.0   0.0
   1.0   0.0   1.0
   0.0  -1.0   2.0
   0.0  -1.0   0.0
   1.0   0.0   2.0
   1.0   1.0   0.0
   1.0   1.0  -1.0
   1.0   1.0
   0.0   1.0
Program Results 
 AB05PD EXAMPLE PROGRAM RESULTS

 The state transition matrix of the connected system is
   1.0000   0.0000  -1.0000   0.0000   0.0000   0.0000
   0.0000  -1.0000   1.0000   0.0000   0.0000   0.0000
   1.0000   1.0000   2.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000  -3.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000   0.0000   1.0000
   0.0000   0.0000   0.0000   0.0000  -1.0000   2.0000

 The input/state matrix of the connected system is 
   1.0000   2.0000
   1.0000   0.0000
   0.0000   1.0000
   0.0000   1.0000
  -1.0000   0.0000
   0.0000   2.0000

 The state/output matrix of the connected system is 
   3.0000  -2.0000   1.0000   1.0000   1.0000   0.0000
   0.0000   1.0000   0.0000   1.0000   1.0000  -1.0000

 The input/output matrix of the connected system is 
   2.0000   1.0000
   0.0000   2.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB05QD.html000077500000000000000000000370401201767322700160640ustar00rootroot00000000000000 AB05QD - SLICOT Library Routine Documentation

AB05QD

Appending two systems in state-space form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To append two systems G1 and G2 in state-space form together.
  If G1 = (A1,B1,C1,D1) and G2 = (A2,B2,C2,D2) are the state-space
  models of the given two systems having the transfer-function
  matrices G1 and G2, respectively, this subroutine constructs the
  state-space model G = (A,B,C,D) which corresponds to the
  transfer-function matrix

                        ( G1 0  )
                    G = (       )
                        ( 0  G2 )
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  OVER    CHARACTER*1
          Indicates whether the user wishes to overlap pairs of
          arrays, as follows:
          = 'N':  Do not overlap;
          = 'O':  Overlap pairs of arrays: A1 and A, B1 and B,
                  C1 and C, and D1 and D, i.e. the same name is
                  effectively used for each pair (for all pairs)
                  in the routine call.  In this case, setting
                  LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD
                  will give maximum efficiency.
Input/Output Parameters 
  N1      (input) INTEGER
          The number of state variables in the first system, i.e.
          the order of the matrix A1, the number of rows of B1 and
          the number of columns of C1.  N1 >= 0.

  M1      (input) INTEGER
          The number of input variables in the first system, i.e.
          the number of columns of matrices B1 and D1.  M1 >= 0.

  P1      (input) INTEGER
          The number of output variables in the first system, i.e.
          the number of rows of matrices C1 and D1.  P1 >= 0.

  N2      (input) INTEGER
          The number of state variables in the second system, i.e.
          the order of the matrix A2, the number of rows of B2 and
          the number of columns of C2.  N2 >= 0.

  M2      (input) INTEGER
          The number of input variables in the second system, i.e.
          the number of columns of matrices B2 and D2.  M2 >= 0.

  P2      (input) INTEGER
          The number of output variables in the second system, i.e.
          the number of rows of matrices C2 and D2.  P2 >= 0.

  A1      (input) DOUBLE PRECISION array, dimension (LDA1,N1)
          The leading N1-by-N1 part of this array must contain the
          state transition matrix A1 for the first system.

  LDA1    INTEGER
          The leading dimension of array A1.  LDA1 >= MAX(1,N1).

  B1      (input) DOUBLE PRECISION array, dimension (LDB1,M1)
          The leading N1-by-M1 part of this array must contain the
          input/state matrix B1 for the first system.

  LDB1    INTEGER
          The leading dimension of array B1.  LDB1 >= MAX(1,N1).

  C1      (input) DOUBLE PRECISION array, dimension (LDC1,N1)
          The leading P1-by-N1 part of this array must contain the
          state/output matrix C1 for the first system.

  LDC1    INTEGER
          The leading dimension of array C1.
          LDC1 >= MAX(1,P1) if N1 > 0.
          LDC1 >= 1 if N1 = 0.

  D1      (input) DOUBLE PRECISION array, dimension (LDD1,M1)
          The leading P1-by-M1 part of this array must contain the
          input/output matrix D1 for the first system.

  LDD1    INTEGER
          The leading dimension of array D1.  LDD1 >= MAX(1,P1).

  A2      (input) DOUBLE PRECISION array, dimension (LDA2,N2)
          The leading N2-by-N2 part of this array must contain the
          state transition matrix A2 for the second system.

  LDA2    INTEGER
          The leading dimension of array A2.  LDA2 >= MAX(1,N2).

  B2      (input) DOUBLE PRECISION array, dimension (LDB2,M2)
          The leading N2-by-M2 part of this array must contain the
          input/state matrix B2 for the second system.

  LDB2    INTEGER
          The leading dimension of array B2.  LDB2 >= MAX(1,N2).

  C2      (input) DOUBLE PRECISION array, dimension (LDC2,N2)
          The leading P2-by-N2 part of this array must contain the
          state/output matrix C2 for the second system.

  LDC2    INTEGER
          The leading dimension of array C2.
          LDC2 >= MAX(1,P2) if N2 > 0.
          LDC2 >= 1 if N2 = 0.

  D2      (input) DOUBLE PRECISION array, dimension (LDD2,M2)
          The leading P2-by-M2 part of this array must contain the
          input/output matrix D2 for the second system.

  LDD2    INTEGER
          The leading dimension of array D2.  LDD2 >= MAX(1,P2).

  N       (output) INTEGER
          The number of state variables (N1 + N2) in the resulting
          system, i.e. the order of the matrix A, the number of rows
          of B and the number of columns of C.

  M       (output) INTEGER
          The number of input variables (M1 + M2) in the resulting
          system, i.e. the number of columns of B and D.

  P       (output) INTEGER
          The number of output variables (P1 + P2) of the resulting
          system, i.e. the number of rows of C and D.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N1+N2)
          The leading N-by-N part of this array contains the state
          transition matrix A for the resulting system.
          The array A can overlap A1 if OVER = 'O'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N1+N2).

  B       (output) DOUBLE PRECISION array, dimension (LDB,M1+M2)
          The leading N-by-M part of this array contains the
          input/state matrix B for the resulting system.
          The array B can overlap B1 if OVER = 'O'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N1+N2).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N1+N2)
          The leading P-by-N part of this array contains the
          state/output matrix C for the resulting system.
          The array C can overlap C1 if OVER = 'O'.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P1+P2) if N1+N2 > 0.
          LDC >= 1 if N1+N2 = 0.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M1+M2)
          The leading P-by-M part of this array contains the
          input/output matrix D for the resulting system.
          The array D can overlap D1 if OVER = 'O'.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P1+P2).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrices of the resulting systems are determined as:

        ( A1   0  )         ( B1  0  )
    A = (         ) ,   B = (        ) ,
        ( 0    A2 )         ( 0   B2 )

        ( C1   0  )         ( D1  0  )
    C = (         ) ,   D = (        ) .
        ( 0    C2 )         ( 0   D2 )
References 
  None
Further Comments 
  None
Example

Program Text 

*     AB05QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          N1MAX, N2MAX, NMAX, M1MAX, M2MAX, MMAX, P1MAX,
     $                 P2MAX, PMAX
      PARAMETER        ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX,
     $                   M1MAX = 20, M2MAX = 20, MMAX = M1MAX+M2MAX,
     $                   P1MAX = 20, P2MAX = 20, PMAX = P1MAX+P2MAX )
      INTEGER          LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1,
     $                 LDC2, LDD, LDD1, LDD2
      PARAMETER        ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX,
     $                   LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX,
     $                   LDC = PMAX, LDC1 = P1MAX, LDC2 = P1MAX,
     $                   LDD = PMAX, LDD1 = P1MAX, LDD2 = P1MAX )
      DOUBLE PRECISION ONE
      PARAMETER        ( ONE=1.0D0 )
*     .. Local Scalars ..
      CHARACTER*1      OVER
      INTEGER          I, INFO, J, M, M1, M2, N, N1, N2, P, P1, P2
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX),
     $                 B(LDB,MMAX), B1(LDB1,M1MAX), B2(LDB2,M2MAX),
     $                 C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX),
     $                 D(LDD,MMAX), D1(LDD1,M1MAX), D2(LDD2,M2MAX)
*     .. External Subroutines ..
      EXTERNAL         AB05QD
*     .. Executable Statements ..
*
      OVER = 'N'
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N1, M1, P1, N2, M2, P2
      IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N1
      ELSE
         READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 )
         IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M1
         ELSE
            READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 )
            IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P1
            ELSE
               READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 )
               READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 )
               IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N2
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( A2(I,J), J = 1,N2 ), I = 1,N2 )
                  IF ( M2.LE.0 .OR. M2.GT.M2MAX ) THEN
                     WRITE ( NOUT, FMT = 99988 ) M2
                  ELSE
                     READ ( NIN, FMT = * )
     $                    ( ( B2(I,J), I = 1,N2 ), J = 1,M2 )
                     IF ( P2.LE.0 .OR. P2.GT.P2MAX ) THEN
                        WRITE ( NOUT, FMT = 99987 ) P2
                     ELSE
                        READ ( NIN, FMT = * )
     $                       ( ( C2(I,J), J = 1,N2 ), I = 1,P2 )
                        READ ( NIN, FMT = * )
     $                       ( ( D2(I,J), J = 1,M2 ), I = 1,P2 )
*                          Find the state-space model (A,B,C,D).
                        CALL 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 )
*
                        IF ( INFO.NE.0 ) THEN
                           WRITE ( NOUT, FMT = 99998 ) INFO
                        ELSE
                           WRITE ( NOUT, FMT = 99997 )
                           DO 20 I = 1, N
                              WRITE ( NOUT, FMT = 99996 )
     $                              ( A(I,J), J = 1,N )
   20                      CONTINUE
                           WRITE ( NOUT, FMT = 99995 )
                           DO 40 I = 1, N
                              WRITE ( NOUT, FMT = 99996 )
     $                              ( B(I,J), J = 1,M )
   40                      CONTINUE
                           WRITE ( NOUT, FMT = 99994 )
                           DO 60 I = 1, P
                              WRITE ( NOUT, FMT = 99996 )
     $                              ( C(I,J), J = 1,N )
   60                      CONTINUE
                           WRITE ( NOUT, FMT = 99993 )
                           DO 80 I = 1, P
                              WRITE ( NOUT, FMT = 99996 )
     $                              ( D(I,J), J = 1,M )
   80                      CONTINUE
                        END IF
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05QD = ',I2)
99997 FORMAT (' The state transition matrix of the connected system is')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the connected system is ')
99994 FORMAT (/' The state/output matrix of the connected system is ')
99993 FORMAT (/' The input/output matrix of the connected system is ')
99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5)
99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5)
99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5)
99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5)
99988 FORMAT (/' M2 is out of range.',/' M2 = ',I5)
99987 FORMAT (/' P2 is out of range.',/' P2 = ',I5)
      END
Program Data 
 AB05QD EXAMPLE PROGRAM DATA
   3     2     2     3     2     2
   1.0   0.0  -1.0
   0.0  -1.0   1.0
   1.0   1.0   2.0
   1.0   1.0   0.0
   2.0   0.0   1.0
   3.0  -2.0   1.0
   0.0   1.0   0.0
   1.0   0.0
   0.0   1.0
  -3.0   0.0   0.0
   1.0   0.0   1.0
   0.0  -1.0   2.0
   0.0  -1.0   0.0
   1.0   0.0   2.0
   1.0   1.0   0.0
   1.0   1.0  -1.0
   1.0   1.0
   0.0   1.0
Program Results 
 AB05QD EXAMPLE PROGRAM RESULTS

 The state transition matrix of the connected system is
   1.0000   0.0000  -1.0000   0.0000   0.0000   0.0000
   0.0000  -1.0000   1.0000   0.0000   0.0000   0.0000
   1.0000   1.0000   2.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000  -3.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000   0.0000   1.0000
   0.0000   0.0000   0.0000   0.0000  -1.0000   2.0000

 The input/state matrix of the connected system is 
   1.0000   2.0000   0.0000   0.0000
   1.0000   0.0000   0.0000   0.0000
   0.0000   1.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000
   0.0000   0.0000  -1.0000   0.0000
   0.0000   0.0000   0.0000   2.0000

 The state/output matrix of the connected system is 
   3.0000  -2.0000   1.0000   0.0000   0.0000   0.0000
   0.0000   1.0000   0.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000   1.0000   0.0000
   0.0000   0.0000   0.0000   1.0000   1.0000  -1.0000

 The input/output matrix of the connected system is 
   1.0000   0.0000   0.0000   0.0000
   0.0000   1.0000   0.0000   0.0000
   0.0000   0.0000   1.0000   1.0000
   0.0000   0.0000   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB05RD.html000077500000000000000000000376061201767322700160750ustar00rootroot00000000000000 AB05RD - SLICOT Library Routine Documentation

AB05RD

Closed-loop system for a mixed output and state feedback control law

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct for a given state space system (A,B,C,D) the closed-
  loop system (Ac,Bc,Cc,Dc) corresponding to the mixed output and
  state feedback control law

       u = alpha*F*y + beta*K*x + G*v
       z = H*y.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  FBTYPE  CHARACTER*1
          Specifies the type of the feedback law as follows:
          = 'I':  Unitary output feedback (F = I);
          = 'O':  General output feedback.

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears
          in the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of state vector x, i.e. the order of the
          matrix A, the number of rows of B and the number of
          columns of C.  N >= 0.

  M       (input) INTEGER
          The dimension of input vector u, i.e. the number of
          columns of matrices B and D, and the number of rows of F.
          M >= 0.

  P       (input) INTEGER
          The dimension of output vector y, i.e. the number of rows
          of matrices C and D, and the number of columns of F.
          P >= 0 and P = M if FBTYPE = 'I'.

  MV      (input) INTEGER
          The dimension of the new input vector v, i.e. the number
          of columns of matrix G.  MV >= 0.

  PZ      (input) INTEGER.
          The dimension of the new output vector z, i.e. the number
          of rows of matrix H.  PZ >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The coefficient alpha in the output feedback law.

  BETA    (input) DOUBLE PRECISION.
          The coefficient beta in the state feedback law.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state transition matrix A.
          On exit, the leading N-by-N part of this array contains
          the state matrix Ac of the closed-loop system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the system input matrix B.
          On exit, the leading N-by-M part of this array contains
          the intermediary input matrix B1 (see METHOD).

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the system output matrix C.
          On exit, the leading P-by-N part of this array contains
          the intermediary output matrix C1+BETA*D1*K (see METHOD).

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P) if N > 0.
          LDC >= 1 if N = 0.

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, if JOBD = 'D', the leading P-by-M part of this
          array must contain the system direct input/output
          transmission matrix D.
          On exit, the leading P-by-M part of this array contains
          the intermediary direct input/output transmission matrix
          D1 (see METHOD).
          The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P) if JOBD = 'D'.
          LDD >= 1 if JOBD = 'Z'.

  F       (input) DOUBLE PRECISION array, dimension (LDF,P)
          If FBTYPE = 'O', the leading M-by-P part of this array
          must contain the output feedback matrix F.
          If FBTYPE = 'I', then the feedback matrix is assumed to be
          an M x M order identity matrix.
          The array F is not referenced if FBTYPE = 'I'  or
          ALPHA = 0.

  LDF     INTEGER
          The leading dimension of array F.
          LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0.
          LDF >= 1 if FBTYPE = 'I' or ALPHA = 0.

  K       (input) DOUBLE PRECISION array, dimension (LDK,N)
          The leading M-by-N part of this array must contain the
          state feedback matrix K.
          The array K is not referenced if BETA = 0.

  LDK     INTEGER
          The leading dimension of the array K.
          LDK >= MAX(1,M) if BETA <> 0.
          LDK >= 1 if BETA = 0.

  G       (input) DOUBLE PRECISION array, dimension (LDG,MV)
          The leading M-by-MV part of this array must contain the
          system input scaling matrix G.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,M).

  H       (input) DOUBLE PRECISION array, dimension (LDH,P)
          The leading PZ-by-P part of this array must contain the
          system output scaling matrix H.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= MAX(1,PZ).

  RCOND   (output) DOUBLE PRECISION
          The reciprocal condition number of the matrix
          I - alpha*D*F.

  BC      (output) DOUBLE PRECISION array, dimension (LDBC,MV)
          The leading N-by-MV part of this array contains the input
          matrix Bc of the closed-loop system.

  LDBC    INTEGER
          The leading dimension of array BC.  LDBC >= MAX(1,N).

  CC      (output) DOUBLE PRECISION array, dimension (LDCC,N)
          The leading PZ-by-N part of this array contains the
          system output matrix Cc of the closed-loop system.

  LDCC    INTEGER
          The leading dimension of array CC.
          LDCC >= MAX(1,PZ) if N > 0.
          LDCC >= 1 if N = 0.

  DC      (output) DOUBLE PRECISION array, dimension (LDDC,MV)
          If JOBD = 'D', the leading PZ-by-MV part of this array
          contains the direct input/output transmission matrix Dc
          of the closed-loop system.
          The array DC is not referenced if JOBD = 'Z'.

  LDDC    INTEGER
          The leading dimension of array DC.
          LDDC >= MAX(1,PZ) if JOBD = 'D'.
          LDDC >= 1 if JOBD = 'Z'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= MAX(1,2*P) if JOBD = 'D'.
          LIWORK >= 1 if JOBD = 'Z'.
          IWORK is not referenced if JOBD = 'Z'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= wspace, where
                wspace = MAX( 1, M, P*MV, P*P + 4*P ) if JOBD = 'D',
                wspace = MAX( 1, M ) if JOBD = 'Z'.
          For best performance, LDWORK >= MAX( wspace, N*M, N*P ).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix I - alpha*D*F is numerically singular.
Method 
  The matrices of the closed-loop system have the expressions:

  Ac = A1 + beta*B1*K,      Bc = B1*G,
  Cc = H*(C1 + beta*D1*K),  Dc = H*D1*G,

  where

  A1 = A + alpha*B*F*E*C,   B1 = B + alpha*B*F*E*D,
  C1 = E*C,                 D1 = E*D,

  with E = (I - alpha*D*F)**-1.
Numerical Aspects 
  The accuracy of computations basically depends on the conditioning
  of the matrix I - alpha*D*F. If RCOND is very small, it is likely
  that the computed results are inaccurate.
Further Comments 
  None
Example

Program Text 

*     AB05RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, MVMAX, PMAX, PZMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, MVMAX = 20,
     $                   PMAX = 20, PZMAX = 20 )
      INTEGER          LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, LDF, LDG,
     $                 LDH, LDK, LDWORK, LIWORK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDBC = NMAX,
     $                   LDC = PMAX, LDCC = PZMAX,
     $                   LDD = PMAX, LDDC = PZMAX, LDF = MMAX,
     $                   LDG = MMAX, LDH  = PZMAX, LDK = MMAX,
     $                   LDWORK = MAX( MMAX, PMAX*MVMAX,
     $                   PMAX*PMAX + 4*PMAX ), LIWORK = 2*PMAX )
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
*     .. Local Scalars ..
      LOGICAL          LJOBD, OUTPF
      CHARACTER*1      FBTYPE, JOBD
      INTEGER          I, INFO, J, M, MV, N, P, PZ
      DOUBLE PRECISION ALPHA, BETA, RCOND
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), BC(LDBC,MVMAX),
     $                 C(LDC,NMAX), CC(LDCC,NMAX),
     $                 D(LDD,MMAX), DC(LDDC,MVMAX),  DWORK(LDWORK),
     $                 F(LDF,PMAX), G(LDG,MVMAX), H(LDH,PMAX),
     $                 K(LDK,NMAX)
*     .. External functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB05RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, MV, PZ, ALPHA, BETA, FBTYPE, JOBD
      OUTPF = LSAME( FBTYPE, 'O' )
      LJOBD = LSAME( JOBD, 'D' )
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( BETA.NE.ZERO )
     $         READ ( NIN, FMT = * ) ( ( K(I,J), J = 1,N ), I = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               IF ( LJOBD )
     $            READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               IF ( OUTPF.AND.ALPHA.NE.ZERO )
     $            READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,P ), I = 1,M )
               IF ( MV.LE.0 .OR. MV.GT.MVMAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) MV
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( G(I,J), J = 1,MV ), I = 1,M )
                  IF ( PZ.LE.0 .OR. PZ.GT.PZMAX ) THEN
                     WRITE ( NOUT, FMT = 99988 ) PZ
                  ELSE
                     READ ( NIN, FMT = * )
     $                    ( ( H(I,J), J = 1,P ), I = 1,PZ )
*                       Find the state-space model (A,B,C,D).
                     CALL 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 )
*
                     WRITE ( NOUT, FMT = 99987 ) RCOND
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99998 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99997 )
                        DO 20 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( A(I,J), J = 1,N )
   20                   CONTINUE
                        WRITE ( NOUT, FMT = 99995 )
                        DO 40 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( BC(I,J), J = 1,MV )
   40                   CONTINUE
                        WRITE ( NOUT, FMT = 99994 )
                        DO 60 I = 1, PZ
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( CC(I,J), J = 1,N )
   60                   CONTINUE
                        IF ( LJOBD ) THEN
                           WRITE ( NOUT, FMT = 99993 )
                           DO 80 I = 1, PZ
                              WRITE ( NOUT, FMT = 99996 )
     $                              ( DC(I,J), J = 1,MV )
   80                      CONTINUE
                        END IF
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05RD = ',I2)
99997 FORMAT (' The state transition matrix of the closed-loop system is
     $')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the closed-loop system is ')
99994 FORMAT (/' The state/output matrix of the closed-loop system is ')
99993 FORMAT (/' The input/output matrix of the closed-loop system is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
99989 FORMAT (/' MV is out of range.',/' MV = ',I5)
99988 FORMAT (/' PZ is out of range.',/' PZ = ',I5)
99987 FORMAT ( ' The reciprocal condition number of the matrix ',
     $         ' I - alpha*D*F is',F8.4,/1X)
      END
Program Data 
 AB05RD EXAMPLE PROGRAM DATA
   3     2     2     2     2   1.0   1.0    O     D
   1.0   0.0  -1.0
   0.0  -1.0   1.0
   1.0   1.0   2.0
   1.0   1.0   0.0
   2.0   0.0   1.0
   2.0   1.0   0.0
   1.0   0.0   1.0
   3.0  -2.0   1.0
   0.0   1.0   0.0
   1.0   0.0
   0.0   1.0
   1.0   2.0
   3.0   4.0
   1.0   1.0
   0.0   1.0
   4.0   3.0
   2.0   1.0
Program Results 
 AB05RD EXAMPLE PROGRAM RESULTS

 The reciprocal condition number of the matrix  I - alpha*D*F is  0.2000

 The state transition matrix of the closed-loop system is
  -4.8333   0.1667  -2.8333
  -0.8333   0.1667   0.1667
  -1.5000   0.5000   1.5000

 The input/state matrix of the closed-loop system is 
  -0.5000  -0.8333
   0.5000   0.1667
  -0.5000  -0.5000

 The state/output matrix of the closed-loop system is 
   1.1667  -1.8333  -0.8333
   1.8333  -1.1667  -0.1667

 The input/output matrix of the closed-loop system is 
   0.5000  -0.8333
   0.5000  -0.1667

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB05SD.html000077500000000000000000000153241201767322700160670ustar00rootroot00000000000000 AB05SD - SLICOT Library Routine Documentation

AB05SD

Closed-loop system for an output feedback control law

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct for a given state space system (A,B,C,D) the closed-
  loop system (Ac,Bc,Cc,Dc) corresponding to the output feedback
  control law

       u = alpha*F*y + v.
Specification 
      SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK,
     $                   LDWORK, INFO)
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,*)
Arguments

Mode Parameters 

  FBTYPE  CHARACTER*1
          Specifies the type of the feedback law as follows:
          = 'I':  Unitary output feedback (F = I);
          = 'O':  General output feedback.

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The number of state variables, i.e. the order of the
          matrix A, the number of rows of B and the number of
          columns of C.  N >= 0.

  M       (input) INTEGER
          The number of input variables, i.e. the number of columns
          of matrices B and D, and the number of rows of F.  M >= 0.

  P       (input) INTEGER
          The number of output variables, i.e. the number of rows of
          matrices C and D, and the number of columns of F.  P >= 0
          and P = M if FBTYPE = 'I'.

  ALPHA   (input) DOUBLE PRECISION
          The coefficient alpha in the output feedback law.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state transition matrix A.
          On exit, the leading N-by-N part of this array contains
          the state matrix Ac of the closed-loop system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the system input matrix B.
          On exit, the leading N-by-M part of this array contains
          the input matrix Bc of the closed-loop system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the system output matrix C.
          On exit, the leading P-by-N part of this array contains
          the output matrix Cc of the closed-loop system.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P) if N > 0.
          LDC >= 1 if N = 0.

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the system direct input/output transmission
          matrix D.
          On exit, if JOBD = 'D', the leading P-by-M part of this
          array contains the direct input/output transmission
          matrix Dc of the closed-loop system.
          The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P) if JOBD = 'D'.
          LDD >= 1 if JOBD = 'Z'.

  F       (input) DOUBLE PRECISION array, dimension (LDF,P)
          If FBTYPE = 'O', the leading M-by-P part of this array
          must contain the output feedback matrix F.
          If FBTYPE = 'I', then the feedback matrix is assumed to be
          an M x M order identity matrix.
          The array F is not referenced if FBTYPE = 'I' or
          ALPHA = 0.

  LDF     INTEGER
          The leading dimension of array F.
          LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0.
          LDF >= 1 if FBTYPE = 'I' or ALPHA = 0.

  RCOND   (output) DOUBLE PRECISION
          The reciprocal condition number of the matrix
          I - alpha*D*F.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= MAX(1,2*P) if JOBD = 'D'.
          LIWORK >= 1 if JOBD = 'Z'.
          IWORK is not referenced if JOBD = 'Z'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= wspace, where
                    wspace = MAX( 1, M, P*P + 4*P ) if JOBD = 'D',
                    wspace = MAX( 1, M ) if JOBD = 'Z'.
          For best performance, LDWORK >= MAX( wspace, N*M, N*P ).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix I - alpha*D*F is numerically singular.
Method 
  The matrices of the closed-loop system have the expressions:

  Ac = A + alpha*B*F*E*C,  Bc = B + alpha*B*F*E*D,
  Cc = E*C,                Dc = E*D,

  where E = (I - alpha*D*F)**-1.
Numerical Aspects 
  The accuracy of computations basically depends on the conditioning
  of the matrix I - alpha*D*F.  If RCOND is very small, it is likely
  that the computed results are inaccurate.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB07MD.html000077500000000000000000000202531201767322700160600ustar00rootroot00000000000000 AB07MD - SLICOT Library Routine Documentation

AB07MD

Dual of a given state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find the dual of a given state-space representation.
Specification 
      SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   INFO )
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,*)
Arguments

Mode Parameters 

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading N-by-N part of this array contains
          the dual state dynamics matrix A'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,MAX(M,P))
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, the leading N-by-P part of this array contains
          the dual input/state matrix C'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, the leading M-by-N part of this array contains
          the dual state/output matrix B'.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,M,P) if N > 0.
          LDC >= 1 if N = 0.

  D       (input/output) DOUBLE PRECISION array, dimension
          (LDD,MAX(M,P))
          On entry, if JOBD = 'D', the leading P-by-M part of this
          array must contain the original direct transmission
          matrix D.
          On exit, if JOBD = 'D', the leading M-by-P part of this
          array contains the dual direct transmission matrix D'.
          The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,M,P) if JOBD = 'D'.
          LDD >= 1 if JOBD = 'Z'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  If the given state-space representation is the M-input/P-output
  (A,B,C,D), its dual is simply the P-input/M-output (A',C',B',D').
References 
  None
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

*     AB07MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MAXMP,
     $                   LDD = MAXMP )
*     .. Local Scalars ..
      CHARACTER*1      JOBD
      INTEGER          I, INFO, J, M, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP)
*     .. External functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB07MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOBD
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the dual of the ssr (A,B,C,D).
               CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99995 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,P )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   60             CONTINUE
                  IF ( LSAME( JOBD, 'D' ) ) THEN
                     WRITE ( NOUT, FMT = 99993 )
                     DO 80 I = 1, M
                        WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,P )
   80                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB07MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB07MD = ',I2)
99997 FORMAT (' The dual state dynamics matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The dual input/state matrix is ')
99994 FORMAT (/' The dual state/output matrix is ')
99993 FORMAT (/' The dual direct transmission matrix is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 AB07MD EXAMPLE PROGRAM DATA
   3     1     2     D
   1.0   2.0   0.0
   4.0  -1.0   0.0
   0.0   0.0   1.0
   1.0   0.0   1.0
   0.0   1.0  -1.0
   0.0   0.0   1.0
   0.0   1.0
Program Results 
 AB07MD EXAMPLE PROGRAM RESULTS

 The dual state dynamics matrix is 
   1.0000   4.0000   0.0000
   2.0000  -1.0000   0.0000
   0.0000   0.0000   1.0000

 The dual input/state matrix is 
   0.0000   0.0000
   1.0000   0.0000
  -1.0000   1.0000

 The dual state/output matrix is 
   1.0000   0.0000   1.0000

 The dual direct transmission matrix is 
   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB07ND.html000077500000000000000000000211161201767322700160600ustar00rootroot00000000000000 AB07ND - SLICOT Library Routine Documentation

AB07ND

Inverse of a given linear system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D).
Specification 
      SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND,
     $                   IWORK, DWORK, LDWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the state matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs and outputs.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state matrix A of the original system.
          On exit, the leading N-by-N part of this array contains
          the state matrix Ai of the inverse system.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B of the original system.
          On exit, the leading N-by-M part of this array contains
          the input matrix Bi of the inverse system.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the output matrix C of the original system.
          On exit, the leading M-by-N part of this array contains
          the output matrix Ci of the inverse system.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,M).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading M-by-M part of this array must
          contain the feedthrough matrix D of the original system.
          On exit, the leading M-by-M part of this array contains
          the feedthrough matrix Di of the inverse system.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,M).

  RCOND   (output) DOUBLE PRECISION
          The estimated reciprocal condition number of the
          feedthrough matrix D of the original system.
Workspace 
  IWORK   INTEGER array, dimension (2*M)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or M+1, DWORK(1) returns the optimal
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,4*M).
          For good performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = i:  the matrix D is exactly singular; the (i,i) diagonal
                element is zero, i <= M; RCOND was set to zero;
          = M+1:  the matrix D is numerically singular, i.e., RCOND
                is less than the relative machine precision, EPS
                (see LAPACK Library routine DLAMCH). The
                calculations have been completed, but the results
                could be very inaccurate.
Method 
  The matrices of the inverse system are computed with the formulas:
                -1              -1         -1           -1
    Ai = A - B*D  *C,  Bi = -B*D  ,  Ci = D  *C,  Di = D  .
Numerical Aspects 
  The accuracy depends mainly on the condition number of the matrix
  D to be inverted. The estimated reciprocal condition number is
  returned in RCOND.
Further Comments 
  None
Example

Program Text 

*     AB07ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MMAX,
     $                   LDD = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*MMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
      DOUBLE PRECISION RCOND
*     .. Local Arrays ..
      INTEGER          IWORK(2*MMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         AB07ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M )
            READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,M )
*           Find the inverse of the ssr (A,B,C,D).
            CALL AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND,
     $                   IWORK, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 60 I = 1, M
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   60          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 80 I = 1, M
                  WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M )
   80          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB07ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB07ND = ',I2)
99997 FORMAT (' The state dynamics matrix of the inverse system is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the inverse system is ')
99994 FORMAT (/' The state/output matrix of the inverse system is ')
99993 FORMAT (/' The feedthrough matrix of the inverse system is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 AB07ND EXAMPLE PROGRAM DATA
   3     2
   1.0   2.0   0.0
   4.0  -1.0   0.0
   0.0   0.0   1.0
   1.0   0.0
   0.0   1.0
   1.0   0.0
   0.0   1.0  -1.0
   0.0   0.0   1.0
   4.0   0.0
   0.0   1.0
Program Results 
 AB07ND EXAMPLE PROGRAM RESULTS

 The state dynamics matrix of the inverse system is 
   1.0000   1.7500   0.2500
   4.0000  -1.0000  -1.0000
   0.0000  -0.2500   1.2500

 The input/state matrix of the inverse system is 
  -0.2500   0.0000
   0.0000  -1.0000
  -0.2500   0.0000

 The state/output matrix of the inverse system is 
   0.0000   0.2500  -0.2500
   0.0000   0.0000   1.0000

 The feedthrough matrix of the inverse system is 
   0.2500   0.0000
   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB08MD.html000077500000000000000000000135221201767322700160620ustar00rootroot00000000000000 AB08MD - SLICOT Library Routine Documentation

AB08MD

Normal rank of the transfer-function matrix of a state space model

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the normal rank of the transfer-function matrix of a
  state-space model (A,B,C,D).
Specification 
      SUBROUTINE AB08MD( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   RANK, TOL, IWORK, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the compound
          matrix (see METHOD) as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The number of state variables, i.e., the order of the
          matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state dynamics matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct transmission matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  RANK    (output) INTEGER
          The normal rank of the transfer-function matrix.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS
          then the tolerance is taken as SQRT((N+P)*(N+M))*EPS,
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (2*N+MAX(M,P)+1)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= (N+P)*(N+M) +
                    MAX( MIN(P,M) + MAX(3*M-1,N), 1,
                         MIN(P,N) + MAX(3*P-1,N+P,N+M) )
          For optimum performance LDWORK should be larger.

          If LDWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          DWORK array, returns this value as the first entry of
          the DWORK array, and no error message related to LDWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine reduces the (N+P)-by-(M+N) compound matrix (B  A)
                                                         (D  C)

  to one with the same invariant zeros and with D of full row rank.
  The normal rank of the transfer-function matrix is the rank of D.
References 
  [1] Svaricek, F.
      Computation of the Structural Invariants of Linear
      Multivariable Systems with an Extended Version of
      the Program ZEROS.
      System & Control Letters, 6, pp. 261-266, 1985.

  [2] Emami-Naeini, A. and Van Dooren, P.
      Computation of Zeros of Linear Multivariable Systems.
      Automatica, 18, pp. 415-430, 1982.
Numerical Aspects 
  The algorithm is backward stable (see [2] and [1]).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB08MZ.html000077500000000000000000000136341201767322700161140ustar00rootroot00000000000000 AB08MZ - SLICOT Library Routine Documentation

AB08MZ

Normal rank of the transfer-function matrix of a state space model (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the normal rank of the transfer-function matrix of a
  state-space model (A,B,C,D).
Specification 
      SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO )
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(*)
Arguments

Mode Parameters 

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the compound
          matrix (see METHOD) as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The number of state variables, i.e., the order of the
          matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input) COMPLEX*16 array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state dynamics matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) COMPLEX*16 array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) COMPLEX*16 array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) COMPLEX*16 array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct transmission matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  RANK    (output) INTEGER
          The normal rank of the transfer-function matrix.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS
          then the tolerance is taken as SQRT((N+P)*(N+M))*EPS,
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (2*N+MAX(M,P)+1)

  DWORK   DOUBLE PRECISION array, dimension (2*MAX(M,P))

  ZWORK   COMPLEX*16 array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) returns the optimal value
          of LZWORK.

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= (N+P)*(N+M) + MAX(MIN(P,M) + MAX(3*M-1,N), 1,
                                      MIN(P,N) + MAX(3*P-1,N+P,N+M))
          For optimum performance LZWORK should be larger.

          If LZWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          ZWORK array, returns this value as the first entry of
          the ZWORK array, and no error message related to LZWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine reduces the (N+P)-by-(M+N) compound matrix (B  A)
                                                         (D  C)

  to one with the same invariant zeros and with D of full row rank.
  The normal rank of the transfer-function matrix is the rank of D.
References 
  [1] Svaricek, F.
      Computation of the Structural Invariants of Linear
      Multivariable Systems with an Extended Version of
      the Program ZEROS.
      System & Control Letters, 6, pp. 261-266, 1985.

  [2] Emami-Naeini, A. and Van Dooren, P.
      Computation of Zeros of Linear Multivariable Systems.
      Automatica, 18, pp. 415-430, 1982.
Numerical Aspects 
  The algorithm is backward stable (see [2] and [1]).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB08ND.html000077500000000000000000000472351201767322700160730ustar00rootroot00000000000000 AB08ND - SLICOT Library Routine Documentation

AB08ND

Construction of a regular pencil for a given system such that its generalized eigenvalues are invariant zeros of the system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct for a linear multivariable system described by a
  state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which
                                                 f          f
  has the invariant zeros of the system as generalized eigenvalues.
  The routine also computes the orders of the infinite zeros and the
  right and left Kronecker indices of the system (A,B,C,D).
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the compound
          matrix (see METHOD) as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The number of state variables, i.e., the order of the
          matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state dynamics matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct transmission matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NU      (output) INTEGER
          The number of (finite) invariant zeros.

  RANK    (output) INTEGER
          The normal rank of the transfer function matrix.

  DINFZ   (output) INTEGER
          The maximum degree of infinite elementary divisors.

  NKROR   (output) INTEGER
          The number of right Kronecker indices.

  NKROL   (output) INTEGER
          The number of left Kronecker indices.

  INFZ    (output) INTEGER array, dimension (N)
          The leading DINFZ elements of INFZ contain information
          on the infinite elementary divisors as follows:
          the system has INFZ(i) infinite elementary divisors
          of degree i, where i = 1,2,...,DINFZ.

  KRONR   (output) INTEGER array, dimension (MAX(N,M)+1)
          The leading NKROR elements of this array contain the
          right Kronecker (column) indices.

  KRONL   (output) INTEGER array, dimension (MAX(N,P)+1)
          The leading NKROL elements of this array contain the
          left Kronecker (row) indices.

  AF      (output) DOUBLE PRECISION array, dimension
          (LDAF,N+MIN(P,M))
          The leading NU-by-NU part of this array contains the
          coefficient matrix A  of the reduced pencil. The remainder
                              f
          of the leading (N+M)-by-(N+MIN(P,M)) part is used as
          internal workspace.

  LDAF    INTEGER
          The leading dimension of array AF.  LDAF >= MAX(1,N+M).

  BF      (output) DOUBLE PRECISION array, dimension (LDBF,N+M)
          The leading NU-by-NU part of this array contains the
          coefficient matrix B  of the reduced pencil. The
                              f
          remainder of the leading (N+P)-by-(N+M) part is used as
          internal workspace.

  LDBF    INTEGER
          The leading dimension of array BF.  LDBF >= MAX(1,N+P).
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS
          then the tolerance is taken as SQRT((N+P)*(N+M))*EPS,
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (MAX(M,P))

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, MIN(P,M) + 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) ).
          An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with
          s = MAX(M,P).
          For optimum performance LDWORK should be larger.

          If LDWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          DWORK array, returns this value as the first entry of
          the DWORK array, and no error message related to LDWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine extracts from the system matrix of a state-space
  system (A,B,C,D) a regular pencil A - lambda*B  which has the
                                     f          f
  invariant zeros of the system as generalized eigenvalues as
  follows:

     (a) construct the (N+P)-by-(N+M) compound matrix (B  A);
                                                      (D  C)

     (b) reduce the above system to one with the same invariant
         zeros and with D of full row rank;

     (c) pertranspose the system;

     (d) reduce the system to one with the same invariant zeros and
         with D square invertible;

     (e) perform a unitary transformation on the columns of
         (A - lambda*I  B) in order to reduce it to
         (      C       D)

         (A  - lambda*B   X)
         ( f           f   ), with Y and B  square invertible;
         (      0         Y)              f

     (f) compute the right and left Kronecker indices of the system
         (A,B,C,D), which together with the orders of the infinite
         zeros (determined by steps (a) - (e)) constitute the
         complete set of structural invariants under strict
         equivalence transformations of a linear system.
References 
  [1] Svaricek, F.
      Computation of the Structural Invariants of Linear
      Multivariable Systems with an Extended Version of
      the Program ZEROS.
      System & Control Letters, 6, pp. 261-266, 1985.

  [2] Emami-Naeini, A. and Van Dooren, P.
      Computation of Zeros of Linear Multivariable Systems.
      Automatica, 18, pp. 415-430, 1982.
Numerical Aspects 
  The algorithm is backward stable (see [2] and [1]).
Further Comments 
  In order to compute the invariant zeros of the system explicitly,
  a call to this routine may be followed by a call to the LAPACK
  Library routine DGGEV with A = A , B = B  and N = NU.
                                  f       f
  If RANK = 0, the routine DGEEV can be used (since B = I).
                                                     f
Example

Program Text 

*     AB08ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          MPMAX
      PARAMETER        ( MPMAX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDAF, LDBF, LDQ, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDAF = NMAX+MPMAX,
     $                   LDBF = NMAX+PMAX, LDQ = 1, LDZ = 1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( MAX( MPMAX+1, NMAX ) +
     $                                 MAX( 3*(MPMAX+1), NMAX+MPMAX ),
     $                                 8*NMAX ) )
*     PARAMETER        ( LDWORK = 10*NMAX + 5*MPMAX + 4 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          DINFZ, I, INFO, II, J, M, N, NINFZ, NKROL, NKROR,
     $                 NU, P, RANK
      CHARACTER*1      EQUIL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), AF(LDAF,NMAX+PMAX), ALFI(NMAX),
     $                 ALFR(NMAX), B(LDB,MMAX), BETA(NMAX),
     $                 BF(LDBF,MMAX+NMAX), C(LDC,NMAX), D(LDD,MMAX),
     $                 DWORK(LDWORK), Q(LDQ,1), Z(LDZ,1)
      INTEGER          INFZ(NMAX), IWORK(MPMAX+1), KRONL(NMAX+1),
     $                 KRONR(NMAX+1), LINFZ(NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB08ND, DGEGV
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99970 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Check the observability and compute the ordered set of
*              the observability indices (call the routine with M = 0).
               CALL AB08ND( EQUIL, N, 0, 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P )
                  IF ( NU.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99993 )
                  ELSE
                     WRITE ( NOUT, FMT = 99992 ) N - NU
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 20 I = 1, NU
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( AF(I,J), J = 1,NU )
   20                CONTINUE
                  END IF
               END IF
*              Check the controllability and compute the ordered set of
*              the controllability indices (call the routine with P = 0)
               CALL AB08ND( EQUIL, N, M, 0, 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M )
                  IF ( NU.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99987 )
                  ELSE
                     WRITE ( NOUT, FMT = 99986 ) N - NU
                     WRITE ( NOUT, FMT = 99985 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 40 I = 1, NU
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( AF(I,J), J = 1,NU )
   40                CONTINUE
                  END IF
               END IF
*              Compute the structural invariants of the given system.
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99984 ) NU
                  IF ( NU.GT.0 ) THEN
*                    Compute the invariant zeros of the given system.
*                    Workspace: need 8*NU.
                     WRITE ( NOUT, FMT = 99983 )
                     CALL DGEGV( 'No vectors', 'No vectors', NU, AF,
     $                           LDAF, BF, LDBF, ALFR, ALFI, BETA, Q,
     $                           LDQ, Z, LDZ, DWORK, LDWORK, INFO )
*
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99981 )
                        DO 60 I = 1, NU
                           IF ( ALFI(I).EQ.ZERO ) THEN
                              WRITE ( NOUT, FMT = 99980 )
     $                                ALFR(I)/BETA(I)
                           ELSE
                              WRITE ( NOUT, FMT = 99979 )
     $                                ALFR(I)/BETA(I),
     $                                ALFI(I)/BETA(I)
                           END IF
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99982 )
                     END IF
                  END IF
                  NINFZ = 0
                  II = 1
                  DO 100 I = 1, N
                     IF ( INFZ(I).GT.0 ) THEN
                        NINFZ = NINFZ + INFZ(I)
                        DO 80 J = 1, INFZ(I)
                           LINFZ(II) = I
                           II = II + 1
   80                   CONTINUE
                     END IF
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99978 ) NINFZ
                  IF ( NINFZ.GT.0 )
     $               WRITE ( NOUT, FMT = 99977 )
     $                     ( LINFZ(I), I = 1,NINFZ )
                  WRITE ( NOUT, FMT = 99976 ) NKROR
                  IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 )
     $                                      ( KRONR(I), I = 1,NKROR )
                  WRITE ( NOUT, FMT = 99974 ) NKROL
                  IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 )
     $                                      ( KRONL(I), I = 1,NKROL )
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' AB08ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB08ND = ',I2)
99997 FORMAT (' INFO on exit from DGEGV = ',I2)
99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X)))
99993 FORMAT (/' The system (A,C) is completely observable ')
99992 FORMAT (/' The dimension of the observable subspace = ',I3)
99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th',
     $       'e matrix AF. ')
99990 FORMAT (/' The matrix AF is ')
99989 FORMAT (20(1X,F8.4))
99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X)
     $       ))
99987 FORMAT (/' The system (A,B) is completely controllable ')
99986 FORMAT (/' The dimension of the controllable subspace = ',I3)
99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the',
     $       ' matrix AF. ')
99984 FORMAT (//' The number of finite invariant zeros = ',I3)
99983 FORMAT (/' The finite invariant zeros are ')
99982 FORMAT (/' which correspond to the generalized eigenvalues of (l',
     $       'ambda*BF - AF).')
99981 FORMAT (/' real  part     imag  part ')
99980 FORMAT (1X,F9.4)
99979 FORMAT (1X,F9.4,6X,F9.4)
99978 FORMAT (//' The number of infinite zeros = ',I3)
99977 FORMAT (/' The orders of the infinite zeros are ',/(20(I3,2X)))
99976 FORMAT (/' The number of right Kronecker indices = ',I3)
99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99974 FORMAT (/' The number of left Kronecker indices = ',I3)
99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99972 FORMAT (/' N is out of range.',/' N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
99970 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 AB08ND EXAMPLE PROGRAM DATA
   6     2     3     0.0     N
   1.0   0.0   0.0   0.0   0.0   0.0
   0.0   1.0   0.0   0.0   0.0   0.0
   0.0   0.0   3.0   0.0   0.0   0.0
   0.0   0.0   0.0  -4.0   0.0   0.0
   0.0   0.0   0.0   0.0  -1.0   0.0
   0.0   0.0   0.0   0.0   0.0   3.0
   0.0  -1.0
  -1.0   0.0
   1.0  -1.0
   0.0   0.0
   0.0   1.0
  -1.0  -1.0
   1.0   0.0   0.0   1.0   0.0   0.0
   0.0   1.0   0.0   1.0   0.0   1.0
   0.0   0.0   1.0   0.0   0.0   1.0
   0.0   0.0
   0.0   0.0
   0.0   0.0
Program Results 
 AB08ND EXAMPLE PROGRAM RESULTS

 The left Kronecker indices of (A,C) are 
  1    2    2

 The dimension of the observable subspace =   5

 The output decoupling zeros are the eigenvalues of the matrix AF. 

 The matrix AF is 
  -1.0000


 The right Kronecker indices of (A,B) are 
  2    3

 The dimension of the controllable subspace =   5

 The input decoupling zeros are the eigenvalues of the matrix AF. 

 The matrix AF is 
  -4.0000


 The number of finite invariant zeros =   2

 The finite invariant zeros are 

 real  part     imag  part 
    2.0000
   -1.0000

 which correspond to the generalized eigenvalues of (lambda*BF - AF).


 The number of infinite zeros =   2

 The orders of the infinite zeros are 
  1    1

 The number of right Kronecker indices =   0

 The number of left Kronecker indices =   1

 The left Kronecker (row) indices of (A,B,C,D) are 
  2

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB08NX.html000077500000000000000000000150731201767322700161120ustar00rootroot00000000000000 AB08NX - SLICOT Library Routine Documentation

AB08NX

Construction of a reduced system (Ar,Br,Cr,Dr), having the same transmission zeros as (A,B,C,D), but with Dr of full row rank

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To extract from the (N+P)-by-(M+N) system
               ( B  A )
               ( D  C )
  an (NU+MU)-by-(M+NU) "reduced" system
               ( B' A')
               ( D' C')
  having the same transmission zeros but with D' of full row rank.
Specification 
      SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD,
     $                   NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of state variables.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  RO      (input/output) INTEGER
          On entry,
          = P     for the original system;
          = MAX(P-M, 0) for the pertransposed system.
          On exit, RO contains the last computed rank.

  SIGMA   (input/output) INTEGER
          On entry,
          = 0  for the original system;
          = M  for the pertransposed system.
          On exit, SIGMA contains the last computed value sigma in
          the algorithm.

  SVLMAX  (input) DOUBLE PRECISION
          During each reduction step, the rank-revealing QR
          factorization of a matrix stops when the estimated minimum
          singular value is smaller than TOL * MAX(SVLMAX,EMSV),
          where EMSV is the estimated maximum singular value.
          SVLMAX >= 0.

  ABCD    (input/output) DOUBLE PRECISION array, dimension
          (LDABCD,M+N)
          On entry, the leading (N+P)-by-(M+N) part of this array
          must contain the compound input matrix of the system.
          On exit, the leading (NU+MU)-by-(M+NU) part of this array
          contains the reduced compound input matrix of the system.

  LDABCD  INTEGER
          The leading dimension of array ABCD.
          LDABCD >= MAX(1,N+P).

  NINFZ   (input/output) INTEGER
          On entry, the currently computed number of infinite zeros.
          It should be initialized to zero on the first call.
          NINFZ >= 0.
          On exit, the number of infinite zeros.

  INFZ    (input/output) INTEGER array, dimension (N)
          On entry, INFZ(i) must contain the current number of
          infinite zeros of degree i, where i = 1,2,...,N, found in
          the previous call(s) of the routine. It should be
          initialized to zero on the first call.
          On exit, INFZ(i) contains the number of infinite zeros of
          degree i, where i = 1,2,...,N.

  KRONL   (input/output) INTEGER array, dimension (N+1)
          On entry, this array must contain the currently computed
          left Kronecker (row) indices found in the previous call(s)
          of the routine. It should be initialized to zero on the
          first call.
          On exit, the leading NKROL elements of this array contain
          the left Kronecker (row) indices.

  MU      (output) INTEGER
          The normal rank of the transfer function matrix of the
          original system.

  NU      (output) INTEGER
          The dimension of the reduced system matrix and the number
          of (finite) invariant zeros if D' is invertible.

  NKROL   (output) INTEGER
          The number of left Kronecker indices.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          NOTE that when SVLMAX > 0, the estimated ranks could be
          less than those defined above (see SVLMAX).
Workspace 
  IWORK   INTEGER array, dimension (MAX(M,P))

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N),
                            MIN(P,N) + MAX(3*P-1,N+P,N+M) ).
          For optimum performance LDWORK should be larger.

          If LDWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          DWORK array, returns this value as the first entry of
          the DWORK array, and no error message related to LDWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Svaricek, F.
      Computation of the Structural Invariants of Linear
      Multivariable Systems with an Extended Version of
      the Program ZEROS.
      System & Control Letters, 6, pp. 261-266, 1985.

  [2] Emami-Naeini, A. and Van Dooren, P.
      Computation of Zeros of Linear Multivariable Systems.
      Automatica, 18, pp. 415-430, 1982.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB08NZ.html000077500000000000000000000474001201767322700161130ustar00rootroot00000000000000 AB08NZ - SLICOT Library Routine Documentation

AB08NZ

Construction of a regular pencil for a given system such that its generalized eigenvalues are invariant zeros of the system (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct for a linear multivariable system described by a
  state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which
                                                 f          f
  has the invariant zeros of the system as generalized eigenvalues.
  The routine also computes the orders of the infinite zeros and the
  right and left Kronecker indices of the system (A,B,C,D).
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the compound
          matrix (see METHOD) as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The number of state variables, i.e., the order of the
          matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input) COMPLEX*16 array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state dynamics matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) COMPLEX*16 array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) COMPLEX*16 array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) COMPLEX*16 array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct transmission matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NU      (output) INTEGER
          The number of (finite) invariant zeros.

  RANK    (output) INTEGER
          The normal rank of the transfer function matrix.

  DINFZ   (output) INTEGER
          The maximum degree of infinite elementary divisors.

  NKROR   (output) INTEGER
          The number of right Kronecker indices.

  NKROL   (output) INTEGER
          The number of left Kronecker indices.

  INFZ    (output) INTEGER array, dimension (N)
          The leading DINFZ elements of INFZ contain information
          on the infinite elementary divisors as follows:
          the system has INFZ(i) infinite elementary divisors
          of degree i, where i = 1,2,...,DINFZ.

  KRONR   (output) INTEGER array, dimension (MAX(N,M)+1)
          The leading NKROR elements of this array contain the
          right Kronecker (column) indices.

  KRONL   (output) INTEGER array, dimension (MAX(N,P)+1)
          The leading NKROL elements of this array contain the
          left Kronecker (row) indices.

  AF      (output) COMPLEX*16 array, dimension (LDAF,N+MIN(P,M))
          The leading NU-by-NU part of this array contains the
          coefficient matrix A  of the reduced pencil. The remainder
                              f
          of the leading (N+M)-by-(N+MIN(P,M)) part is used as
          internal workspace.

  LDAF    INTEGER
          The leading dimension of array AF.  LDAF >= MAX(1,N+M).

  BF      (output) COMPLEX*16 array, dimension (LDBF,N+M)
          The leading NU-by-NU part of this array contains the
          coefficient matrix B  of the reduced pencil. The
                              f
          remainder of the leading (N+P)-by-(N+M) part is used as
          internal workspace.

  LDBF    INTEGER
          The leading dimension of array BF.  LDBF >= MAX(1,N+P).
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS
          then the tolerance is taken as SQRT((N+P)*(N+M))*EPS,
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (MAX(M,P))

  DWORK   DOUBLE PRECISION array, dimension (MAX(N,2*MAX(P,M)))

  ZWORK   DOUBLE PRECISION array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) returns the optimal value
          of LZWORK.

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= MAX( 1, MIN(P,M) + 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) ).
          An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with
          s = MAX(M,P).
          For optimum performance LZWORK should be larger.

          If LZWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          ZWORK array, returns this value as the first entry of
          the ZWORK array, and no error message related to LZWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine extracts from the system matrix of a state-space
  system (A,B,C,D) a regular pencil A - lambda*B  which has the
                                     f          f
  invariant zeros of the system as generalized eigenvalues as
  follows:

     (a) construct the (N+P)-by-(N+M) compound matrix (B  A);
                                                      (D  C)

     (b) reduce the above system to one with the same invariant
         zeros and with D of full row rank;

     (c) pertranspose the system;

     (d) reduce the system to one with the same invariant zeros and
         with D square invertible;

     (e) perform a unitary transformation on the columns of
         (A - lambda*I  B) in order to reduce it to
         (      C       D)

         (A  - lambda*B   X)
         ( f           f   ), with Y and B  square invertible;
         (     0          Y)              f

     (f) compute the right and left Kronecker indices of the system
         (A,B,C,D), which together with the orders of the infinite
         zeros (determined by steps (a) - (e)) constitute the
         complete set of structural invariants under strict
         equivalence transformations of a linear system.
References 
  [1] Svaricek, F.
      Computation of the Structural Invariants of Linear
      Multivariable Systems with an Extended Version of
      the Program ZEROS.
      System & Control Letters, 6, pp. 261-266, 1985.

  [2] Emami-Naeini, A. and Van Dooren, P.
      Computation of Zeros of Linear Multivariable Systems.
      Automatica, 18, pp. 415-430, 1982.
Numerical Aspects 
  The algorithm is backward stable (see [2] and [1]).
Further Comments 
  In order to compute the invariant zeros of the system explicitly,
  a call to this routine may be followed by a call to the LAPACK
  Library routine ZGGEV with A = A , B = B  and N = NU.
                                  f       f
  If RANK = 0, the routine ZGEEV can be used (since B = I).
                                                     f
Example

Program Text 

*     AB08NZ EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          MPMAX
      PARAMETER        ( MPMAX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDAF, LDBF, LDQ, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDAF = NMAX+MPMAX,
     $                   LDBF = NMAX+PMAX, LDQ = 1, LDZ = 1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 8*NMAX )
      INTEGER          LZWORK
      PARAMETER        ( LZWORK =
     $                   MAX( MIN( PMAX, MMAX ) +
     $                        MAX( 3*MMAX - 1, NMAX ),
     $                        MIN( PMAX, NMAX ) +
     $                        MAX( 3*PMAX, NMAX+PMAX, NMAX+MMAX ),
     $                        MIN( MMAX, NMAX ) +
     $                        MAX( 3*MMAX, NMAX+MMAX ), 1 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          DINFZ, I, INFO, II, J, M, N, NINFZ, NKROL, NKROR,
     $                 NU, P, RANK
      CHARACTER*1      EQUIL
*     .. Local Arrays ..
      COMPLEX*16       A(LDA,NMAX), AF(LDAF,NMAX+PMAX), ALPHA(NMAX),
     $                 B(LDB,MMAX), BETA(NMAX), BF(LDBF,MMAX+NMAX),
     $                 C(LDC,NMAX), D(LDD,MMAX), Q(LDQ,1), Z(LDZ,1),
     $                 ZWORK(LZWORK)
      DOUBLE PRECISION DWORK(LDWORK)
      INTEGER          INFZ(NMAX), IWORK(MPMAX+1), KRONL(NMAX+1),
     $                 KRONR(NMAX+1), LINFZ(NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB08NZ, ZGEGV
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99970 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Check the observability and compute the ordered set of
*              the observability indices (call the routine with M = 0).
               CALL AB08NZ( EQUIL, N, 0, 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P )
                  IF ( NU.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99993 )
                  ELSE
                     WRITE ( NOUT, FMT = 99992 ) N - NU
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 20 I = 1, NU
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( AF(I,J), J = 1,NU )
   20                CONTINUE
                  END IF
               END IF
*              Check the controllability and compute the ordered set of
*              the controllability indices (call the routine with P = 0)
               CALL AB08NZ( EQUIL, N, M, 0, 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M )
                  IF ( NU.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99987 )
                  ELSE
                     WRITE ( NOUT, FMT = 99986 ) N - NU
                     WRITE ( NOUT, FMT = 99985 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 40 I = 1, NU
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( AF(I,J), J = 1,NU )
   40                CONTINUE
                  END IF
               END IF
*              Compute the structural invariants of the given system.
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99984 ) NU
                  IF ( NU.GT.0 ) THEN
*                    Compute the invariant zeros of the given system.
*                    Complex Workspace: need 2*NU.
*                    Real Workspace:    need 8*NU.
                     WRITE ( NOUT, FMT = 99983 )
                     CALL ZGEGV( 'No vectors', 'No vectors', NU, AF,
     $                           LDAF, BF, LDBF, ALPHA, BETA, Q, LDQ,
     $                           Z, LDZ, ZWORK, LZWORK, DWORK, INFO )
*
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99981 )
                        DO 60 I = 1, NU
                           WRITE ( NOUT, FMT = 99980 ) ALPHA(I)/BETA(I)
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99982 )
                     END IF
                  END IF
                  NINFZ = 0
                  II = 1
                  DO 100 I = 1, N
                     IF ( INFZ(I).GT.0 ) THEN
                        NINFZ = NINFZ + INFZ(I)
                        DO 80 J = 1, INFZ(I)
                           LINFZ(II) = I
                           II = II + 1
   80                   CONTINUE
                     END IF
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99978 ) NINFZ
                  IF ( NINFZ.GT.0 )
     $               WRITE ( NOUT, FMT = 99977 )
     $                     ( LINFZ(I), I = 1,NINFZ )
                  WRITE ( NOUT, FMT = 99976 ) NKROR
                  IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 )
     $                                      ( KRONR(I), I = 1,NKROR )
                  WRITE ( NOUT, FMT = 99974 ) NKROL
                  IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 )
     $                                      ( KRONL(I), I = 1,NKROL )
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' AB08NZ EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB08NZ = ',I2)
99997 FORMAT (' INFO on exit from ZGEGV = ',I2)
99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X)))
99993 FORMAT (/' The system (A,C) is completely observable ')
99992 FORMAT (/' The dimension of the observable subspace = ',I3)
99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th',
     $       'e matrix AF. ')
99990 FORMAT (/' The matrix AF is ')
99989 FORMAT (20(1X,F9.4,SP,F9.4,S,'i '))
99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X)
     $       ))
99987 FORMAT (/' The system (A,B) is completely controllable ')
99986 FORMAT (/' The dimension of the controllable subspace = ',I3)
99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the',
     $       ' matrix AF. ')
99984 FORMAT (//' The number of finite invariant zeros = ',I3)
99983 FORMAT (/' The finite invariant zeros are ')
99982 FORMAT (/' which correspond to the generalized eigenvalues of (l',
     $       'ambda*BF - AF).')
99981 FORMAT (/' real  part     imag  part ')
99980 FORMAT (1X,F9.4,SP,F9.4,S,'i ')
99978 FORMAT (//' The number of infinite zeros = ',I3)
99977 FORMAT (/' The orders of the infinite zeros are ',/(20(I3,2X)))
99976 FORMAT (/' The number of right Kronecker indices = ',I3)
99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99974 FORMAT (/' The number of left Kronecker indices = ',I3)
99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99972 FORMAT (/' N is out of range.',/' N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
99970 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 AB08NZ EXAMPLE PROGRAM DATA
   6     2     3     0.0     N
   1.0   0.0   0.0   0.0   0.0   0.0
   0.0   1.0   0.0   0.0   0.0   0.0
   0.0   0.0   3.0   0.0   0.0   0.0
   0.0   0.0   0.0  -4.0   0.0   0.0
   0.0   0.0   0.0   0.0  -1.0   0.0
   0.0   0.0   0.0   0.0   0.0   3.0
   0.0  -1.0
  -1.0   0.0
   1.0  -1.0
   0.0   0.0
   0.0   1.0
  -1.0  -1.0
   1.0   0.0   0.0   1.0   0.0   0.0
   0.0   1.0   0.0   1.0   0.0   1.0
   0.0   0.0   1.0   0.0   0.0   1.0
   0.0   0.0
   0.0   0.0
   0.0   0.0
Program Results 
 AB08NZ EXAMPLE PROGRAM RESULTS

 The left Kronecker indices of (A,C) are 
  1    2    2

 The dimension of the observable subspace =   5

 The output decoupling zeros are the eigenvalues of the matrix AF. 

 The matrix AF is 
   -1.0000  +0.0000i 


 The right Kronecker indices of (A,B) are 
  2    3

 The dimension of the controllable subspace =   5

 The input decoupling zeros are the eigenvalues of the matrix AF. 

 The matrix AF is 
   -4.0000  +0.0000i 


 The number of finite invariant zeros =   2

 The finite invariant zeros are 

 real  part     imag  part 
    2.0000  +0.0000i 
   -1.0000  +0.0000i 

 which correspond to the generalized eigenvalues of (lambda*BF - AF).


 The number of infinite zeros =   2

 The orders of the infinite zeros are 
  1    1

 The number of right Kronecker indices =   0

 The number of left Kronecker indices =   1

 The left Kronecker (row) indices of (A,B,C,D) are 
  2

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09AD.html000077500000000000000000000346251201767322700160560ustar00rootroot00000000000000 AB09AD - SLICOT Library Routine Documentation

AB09AD

Balance & Truncate model reduction for stable systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr) for a stable original
  state-space representation (A,B,C) by using either the square-root
  or the balancing-free square-root Balance & Truncate (B & T)
  model reduction method.
Specification 
      SUBROUTINE AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA,
     $                   B, LDB, C, LDC, HSV, TOL, IWORK, DWORK, LDWORK,
     $                   IWARN, INFO )
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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'N':  use the balancing-free square-root
                  Balance & Truncate method.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR
          is the desired order on entry and NMIN is the order of a
          minimal realization of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than N*EPS*HNORM(A,B,C), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(A,B,C) is the Hankel norm of the system (computed
          in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the reduced
          order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values of
          the original system ordered decreasingly. HSV(1) is the
          Hankel norm of the system.
Tolerances 
  TOL     DOUBLE PRECISION
          If ORDSEL = 'A', TOL contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL = c*HNORM(A,B,C), where c is a constant in the
          interval [0.00001,0.001], and HNORM(A,B,C) is the
          Hankel-norm of the given system (computed in HSV(1)).
          For computing a minimal realization, the recommended
          value is TOL = N*EPS*HNORM(A,B,C), where EPS is the
          machine precision (see LAPACK Library Routine DLAMCH).
          This value is used by default if TOL <= 0 on entry.
          If ORDSEL = 'F', the value of TOL is ignored.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = 0, if JOB = 'B';
          LIWORK = N, if JOB = 'N'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than the order of a minimal realization of the
                given system. In this case, the resulting NR is
                set automatically to a value corresponding to the
                order of a minimal realization of the system.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to the real Schur form failed;
          = 2:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D');
          = 3:  the computation of Hankel singular values failed.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t)                               (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09AD determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t)                             (2)

  such that

        HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  If JOB = 'B', the square-root Balance & Truncate method of [1]
  is used and, for DICO = 'C', the resulting model is balanced.
  By setting TOL <= 0, the routine can be used to compute balanced
  minimal state-space realizations of stable systems.

  If JOB = 'N', the balancing-free square-root version of the
  Balance & Truncate method [2] is used.
  By setting TOL <= 0, the routine can be used to compute minimal
  state-space realizations of stable systems.
References 
  [1] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [2] Varga A.
      Efficient minimal realization procedure based on balancing.
      Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
      A. El Moudui, P. Borne, S. G. Tzafestas (Eds.),
      Vol. 2, pp. 42-46.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( 2*NMAX + 5 +
     $                            MAX( NMAX, MMAX, PMAX ) ) +
     $                          ( NMAX*( NMAX + 1 ) )/2 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, IWARN, J, M, N, NR, P
      CHARACTER*1      DICO, EQUIL, JOB, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, TOL, DICO, JOB, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find a reduced ssr for (A,B,C).
               CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR,
     $                      A, LDA, B, LDB, C, LDC, HSV, TOL, IWORK,
     $                      DWORK, LDWORK, IWARN, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N )
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09AD = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values HSV are')
      END
Program Data 
 AB09AD EXAMPLE PROGRAM DATA (Continuous system)
  7     2     3     0   1.E-1      C     N     N     A
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
Program Results 
 AB09AD EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values HSV are
   2.5139   2.0846   1.9178   0.7666   0.5473   0.0253   0.0246

 The reduced state dynamics matrix Ar is 
   1.3451   5.0399   0.0000   0.0000   4.5315
  -4.0214  -3.6604   0.0000   0.0000  -0.9056
   0.0000   0.0000   0.5124   1.7910   0.0000
   0.0000   0.0000  -4.2167  -2.9900   0.0000
   1.2402   1.6416   0.0000   0.0000  -0.0586

 The reduced input/state matrix Br is 
  -0.3857   0.3857
  -3.1753   3.1753
  -0.7447  -0.7447
  -3.6872  -3.6872
   1.8197  -1.8197

 The reduced state/output matrix Cr is 
  -0.6704   0.1828  -0.6582   0.2222  -0.0104
   0.1089   0.4867   0.0000   0.0000   0.8651
   0.6704  -0.1828  -0.6582   0.2222   0.0104

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09AX.html000077500000000000000000000236301201767322700160740ustar00rootroot00000000000000 AB09AX - SLICOT Library Routine Documentation

AB09AX

Balance & Truncate model reduction for stable systems with state matrix in real Schur canonical form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr) for a stable original
  state-space representation (A,B,C) by using either the square-root
  or the balancing-free square-root Balance & Truncate model
  reduction method. The state dynamics matrix A of the original
  system is an upper quasi-triangular matrix in real Schur canonical
  form. The matrices of the reduced order system are computed using
  the truncation formulas:

       Ar = TI * A * T ,  Br = TI * B ,  Cr = C * T .
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'N':  use the balancing-free square-root
                  Balance & Truncate method.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR
          is the desired order on entry and NMIN is the order of a
          minimal realization of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than N*EPS*HNORM(A,B,C), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(A,B,C) is the Hankel norm of the system (computed
          in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A in a real Schur
          canonical form.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values of
          the original system ordered decreasingly. HSV(1) is the
          Hankel norm of the system.

  T       (output) DOUBLE PRECISION array, dimension (LDT,N)
          If INFO = 0 and NR > 0, the leading N-by-NR part of this
          array contains the right truncation matrix T.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  TI      (output) DOUBLE PRECISION array, dimension (LDTI,N)
          If INFO = 0 and NR > 0, the leading NR-by-N part of this
          array contains the left truncation matrix TI.

  LDTI    INTEGER
          The leading dimension of array TI.  LDTI >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          If ORDSEL = 'A', TOL contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL = c*HNORM(A,B,C), where c is a constant in the
          interval [0.00001,0.001], and HNORM(A,B,C) is the
          Hankel-norm of the given system (computed in HSV(1)).
          For computing a minimal realization, the recommended
          value is TOL = N*EPS*HNORM(A,B,C), where EPS is the
          machine precision (see LAPACK Library Routine DLAMCH).
          This value is used by default if TOL <= 0 on entry.
          If ORDSEL = 'F', the value of TOL is ignored.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = 0, if JOB = 'B', or
          LIWORK = N, if JOB = 'N'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than the order of a minimal realization of the
                given system. In this case, the resulting NR is
                set automatically to a value corresponding to the
                order of a minimal realization of the system.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D');
          = 2:  the computation of Hankel singular values failed.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t)                               (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09AX determines for
  the given system (1), the matrices of a reduced NR order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t)                             (2)

  such that

        HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  If JOB = 'B', the square-root Balance & Truncate method of [1]
  is used and, for DICO = 'C', the resulting model is balanced.
  By setting TOL <= 0, the routine can be used to compute balanced
  minimal state-space realizations of stable systems.

  If JOB = 'N', the balancing-free square-root version of the
  Balance & Truncate method [2] is used.
  By setting TOL <= 0, the routine can be used to compute minimal
  state-space realizations of stable systems.
References 
  [1] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [2] Varga A.
      Efficient minimal realization procedure based on balancing.
      Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
      A. El Moudui, P. Borne, S. G. Tzafestas (Eds.),
      Vol. 2, pp. 42-46.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09BD.html000077500000000000000000000372011201767322700160500ustar00rootroot00000000000000 AB09BD - SLICOT Library Routine Documentation

AB09BD

Singular Perturbation Approximation based model reduction for stable systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for a stable
  original state-space representation (A,B,C,D) by using either the
  square-root or the balancing-free square-root Singular
  Perturbation Approximation (SPA) model reduction method.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root SPA method;
          = 'N':  use the balancing-free square-root SPA method.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR
          is the desired order on entry and NMIN is the order of a
          minimal realization of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than N*EPS*HNORM(A,B,C), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(A,B,C) is the Hankel norm of the system (computed
          in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values of
          the original system ordered decreasingly. HSV(1) is the
          Hankel norm of the system.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(A,B,C), where c is a constant in the
          interval [0.00001,0.001], and HNORM(A,B,C) is the
          Hankel-norm of the given system (computed in HSV(1)).
          For computing a minimal realization, the recommended
          value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the
          machine precision (see LAPACK Library Routine DLAMCH).
          This value is used by default if TOL1 <= 0 on entry.
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the given system. The recommended value is
          TOL2 = N*EPS*HNORM(A,B,C). This value is used by default
          if TOL2 <= 0 on entry.
          If TOL2 > 0, then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension MAX(1,2*N)
          On exit with INFO = 0, IWORK(1) contains the order of the
          minimal realization of the system.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than the order of a minimal realization of the
                given system. In this case, the resulting NR is
                set automatically to a value corresponding to the
                order of a minimal realization of the system.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to the real Schur form failed;
          = 2:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D');
          = 3:  the computation of Hankel singular values failed.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t)                           (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09BD determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t)                       (2)

  such that

        HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  If JOB = 'B', the balancing-based square-root SPA method of [1]
  is used and the resulting model is balanced.

  If JOB = 'N', the balancing-free square-root SPA method of [2]
  is used.
  By setting TOL1 = TOL2, the routine can be used to compute
  Balance & Truncate approximations.
References 
  [1] Liu Y. and Anderson B.D.O.
      Singular Perturbation Approximation of Balanced Systems,
      Int. J. Control, Vol. 50, pp. 1379-1405, 1989.

  [2] Varga A.
      Balancing-free square-root algorithm for computing singular
      perturbation approximations.
      Proc. 30-th IEEE CDC,  Brighton, Dec. 11-13, 1991,
      Vol. 2, pp. 1062-1065.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( 2*NMAX + 5 +
     $                            MAX( NMAX, MMAX, PMAX ) ) +
     $                          ( NMAX*( NMAX + 1 ) )/2 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NR, P
      CHARACTER*1      DICO, EQUIL, JOB, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09BD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, TOL1, TOL2, DICO, JOB, EQUIL,
     $                      ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find a reduced ssr for (A,B,C).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09BD = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values are')
      END
Program Data 
 AB09BD EXAMPLE PROGRAM DATA (Continuous system)
  7     2     3     0   1.E-1  1.E-14      C     N     N     A
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 AB09BD EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values are
   2.5139   2.0846   1.9178   0.7666   0.5473   0.0253   0.0246

 The reduced state dynamics matrix Ar is 
   1.3960   5.1248   0.0000   0.0000   4.4331
  -4.1411  -3.8605   0.0000   0.0000  -0.6738
   0.0000   0.0000   0.5847   1.9230   0.0000
   0.0000   0.0000  -4.3823  -3.2922   0.0000
   1.3261   1.7851   0.0000   0.0000  -0.2249

 The reduced input/state matrix Br is 
  -0.2901   0.2901
  -3.4004   3.4004
  -0.6379  -0.6379
  -3.9315  -3.9315
   1.9813  -1.9813

 The reduced state/output matrix Cr is 
  -0.6570   0.2053  -0.6416   0.2526  -0.0364
   0.1094   0.4875   0.0000   0.0000   0.8641
   0.6570  -0.2053  -0.6416   0.2526   0.0364

 The reduced input/output matrix Dr is 
   0.0498  -0.0007
   0.0010  -0.0010
  -0.0007   0.0498

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09BX.html000077500000000000000000000251401201767322700160730ustar00rootroot00000000000000 AB09BX - SLICOT Library Routine Documentation

AB09BX

Singular Perturbation Approximation based model reduction for stable systems with state matrix in real Schur canonical form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for a stable
  original state-space representation (A,B,C,D) by using either the
  square-root or the balancing-free square-root
  Singular Perturbation Approximation (SPA) model reduction method.
  The state dynamics matrix A of the original system is an upper
  quasi-triangular matrix in real Schur canonical form. The matrices
  of a minimal realization are computed using the truncation
  formulas:

       Am = TI * A * T ,  Bm = TI * B ,  Cm = C * T .      (1)

  Am, Bm, Cm and D serve further for computing the SPA of the given
  system.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root SPA method;
          = 'N':  use the balancing-free square-root SPA method.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR
          is the desired order on entry and NMIN is the order of a
          minimal realization of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than N*EPS*HNORM(A,B,C), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(A,B,C) is the Hankel norm of the system (computed
          in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A in a real Schur
          canonical form.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values of
          the original system ordered decreasingly. HSV(1) is the
          Hankel norm of the system.

  T       (output) DOUBLE PRECISION array, dimension (LDT,N)
          If INFO = 0 and NR > 0, the leading N-by-NR part of this
          array contains the right truncation matrix T in (1).

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  TI      (output) DOUBLE PRECISION array, dimension (LDTI,N)
          If INFO = 0 and NR > 0, the leading NR-by-N part of this
          array contains the left truncation matrix TI in (1).

  LDTI    INTEGER
          The leading dimension of array TI.  LDTI >= MAX(1,N).
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(A,B,C), where c is a constant in the
          interval [0.00001,0.001], and HNORM(A,B,C) is the
          Hankel-norm of the given system (computed in HSV(1)).
          For computing a minimal realization, the recommended
          value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the
          machine precision (see LAPACK Library Routine DLAMCH).
          This value is used by default if TOL1 <= 0 on entry.
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the given system. The recommended value is
          TOL2 = N*EPS*HNORM(A,B,C). This value is used by default
          if TOL2 <= 0 on entry.
          If TOL2 > 0, then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension MAX(1,2*N)
          On exit with INFO = 0, IWORK(1) contains the order of the
          minimal realization of the system.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than the order of a minimal realization of the
                given system. In this case, the resulting NR is
                set automatically to a value corresponding to the
                order of a minimal realization of the system.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D');
          = 2:  the computation of Hankel singular values failed.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t)                              (2)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09BX determines for
  the given system (1), the matrices of a reduced NR order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t)                          (3)

  such that

        HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  If JOB = 'B', the balancing-based square-root SPA method of [1]
  is used and the resulting model is balanced.

  If JOB = 'N', the balancing-free square-root SPA method of [2]
  is used.
  By setting TOL1 = TOL2, the routine can be also used to compute
  Balance & Truncate approximations.
References 
  [1] Liu Y. and Anderson B.D.O.
      Singular Perturbation Approximation of Balanced Systems,
      Int. J. Control, Vol. 50, pp. 1379-1405, 1989.

  [2] Varga A.
      Balancing-free square-root algorithm for computing singular
      perturbation approximations.
      Proc. 30-th IEEE CDC,  Brighton, Dec. 11-13, 1991,
      Vol. 2, pp. 1062-1065.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09CD.html000077500000000000000000000376501201767322700160610ustar00rootroot00000000000000 AB09CD - SLICOT Library Routine Documentation

AB09CD

Optimal Hankel-norm approximation based model reduction for stable systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for a stable
  original state-space representation (A,B,C,D) by using the
  optimal Hankel-norm approximation method in conjunction with
  square-root balancing.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN),
          where KR is the multiplicity of the Hankel singular value
          HSV(NR+1), NR is the desired order on entry, and NMIN is
          the order of a minimal realization of the given system;
          NMIN is determined as the number of Hankel singular values
          greater than N*EPS*HNORM(A,B,C), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(A,B,C) is the Hankel norm of the system (computed
          in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system in a real Schur form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values of
          the original system ordered decreasingly. HSV(1) is the
          Hankel norm of the system.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(A,B,C), where c is a constant in the
          interval [0.00001,0.001], and HNORM(A,B,C) is the
          Hankel-norm of the given system (computed in HSV(1)).
          For computing a minimal realization, the recommended
          value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the
          machine precision (see LAPACK Library Routine DLAMCH).
          This value is used by default if TOL1 <= 0 on entry.
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the given system. The recommended value is
          TOL2 = N*EPS*HNORM(A,B,C). This value is used by default
          if TOL2 <= 0 on entry.
          If TOL2 > 0, then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = MAX(1,M),   if DICO = 'C';
          LIWORK = MAX(1,N,M), if DICO = 'D'.
          On exit, if INFO = 0, IWORK(1) contains NMIN, the order of
          the computed minimal realization.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( LDW1, LDW2 ), where
          LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2,
          LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) +
                 MAX( 3*M+1, MIN(N,M)+P ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than the order of a minimal realization of the
                given system. In this case, the resulting NR is set
                automatically to a value corresponding to the order
                of a minimal realization of the system.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to the real Schur form failed;
          = 2:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D');
          = 3:  the computation of Hankel singular values failed;
          = 4:  the computation of stable projection failed;
          = 5:  the order of computed stable projection differs
                from the order of Hankel-norm approximation.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t)                           (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09CD determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t)                       (2)

  such that

        HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  The optimal Hankel-norm approximation method of [1], based on the
  square-root balancing projection formulas of [2], is employed.
References 
  [1] Glover, K.
      All optimal Hankel norm approximation of linear
      multivariable systems and their L-infinity error bounds.
      Int. J. Control, Vol. 36, pp. 1145-1193, 1984.

  [2] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
Numerical Aspects 
  The implemented methods rely on an accuracy enhancing square-root
  technique.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( NMAX, MMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*( 2*NMAX +
     $                                 MAX( NMAX, MMAX, PMAX ) + 5 ) +
     $                               ( NMAX*( NMAX + 1 ) )/2,
     $                            NMAX*( MMAX + PMAX + 2 ) +
     $                            2*MMAX*PMAX +
     $                            MIN( NMAX, MMAX ) + MAX( 3*MMAX + 1,
     $                            MIN( NMAX, MMAX ) + PMAX ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NR, P
      CHARACTER*1      DICO, EQUIL, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, TOL1, TOL2, DICO, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find a reduced ssr for (A,B,C).
               CALL AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR,
     $                      A, LDA, B, LDB, C, LDC, D, LDD, HSV, TOL1,
     $                      TOL2, IWORK, DWORK, LDWORK, IWARN, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09CD = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values are')
      END
Program Data 
 AB09CD EXAMPLE PROGRAM DATA (Continuous system)
  7     2     3     0   1.E-1  1.E-14      C     N     A
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
Program Results 
 AB09CD EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values are
   2.5139   2.0846   1.9178   0.7666   0.5473   0.0253   0.0246

 The reduced state dynamics matrix Ar is 
  -0.5038  -5.3070  -3.2250   0.0000   0.0000
   1.8355  -0.5038  -2.6289   0.0000   0.0000
   0.0000   0.0000  -1.5171   0.0000   0.0000
   0.0000   0.0000   0.0000  -1.2925  -9.0718
   0.0000   0.0000   0.0000   0.5047  -1.2925

 The reduced input/state matrix Br is 
  -1.5343   1.5343
  -0.3614   0.3614
  -1.1096   1.1096
  -4.5325  -4.5325
  -0.7396  -0.7396

 The reduced state/output matrix Cr is 
   1.8971  -0.3055  -2.1124   0.4421  -2.1023
  -0.0394   1.1112  -0.3119   0.0000   0.0000
  -1.8971   0.3055   2.1124   0.4421  -2.1023

 The reduced input/output matrix Dr is 
   0.0126  -0.0126
   0.0005  -0.0005
  -0.0126   0.0126

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09CX.html000077500000000000000000000235231201767322700160770ustar00rootroot00000000000000 AB09CX - SLICOT Library Routine Documentation

AB09CX

Optimal Hankel-norm approximation based model reduction for stable systems with state matrix in real Schur canonical form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for a stable
  original state-space representation (A,B,C,D) by using the optimal
  Hankel-norm approximation method in conjunction with square-root
  balancing. The state dynamics matrix A of the original system is
  an upper quasi-triangular matrix in real Schur canonical form.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN),
          where KR is the multiplicity of the Hankel singular value
          HSV(NR+1), NR is the desired order on entry, and NMIN is
          the order of a minimal realization of the given system;
          NMIN is determined as the number of Hankel singular values
          greater than N*EPS*HNORM(A,B,C), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(A,B,C) is the Hankel norm of the system (computed
          in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A in a real Schur
          canonical form.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system in a real Schur form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values of
          the original system ordered decreasingly. HSV(1) is the
          Hankel norm of the system.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(A,B,C), where c is a constant in the
          interval [0.00001,0.001], and HNORM(A,B,C) is the
          Hankel-norm of the given system (computed in HSV(1)).
          For computing a minimal realization, the recommended
          value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the
          machine precision (see LAPACK Library Routine DLAMCH).
          This value is used by default if TOL1 <= 0 on entry.
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the given system. The recommended value is
          TOL2 = N*EPS*HNORM(A,B,C). This value is used by default
          if TOL2 <= 0 on entry.
          If TOL2 > 0, then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = MAX(1,M),   if DICO = 'C';
          LIWORK = MAX(1,N,M), if DICO = 'D'.
          On exit, if INFO = 0, IWORK(1) contains NMIN, the order of
          the computed minimal realization.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( LDW1,LDW2 ), where
          LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2,
          LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) +
                 MAX( 3*M+1, MIN(N,M)+P ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than the order of a minimal realization of the
                given system. In this case, the resulting NR is set
                automatically to a value corresponding to the order
                of a minimal realization of the system.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D');
          = 2:  the computation of Hankel singular values failed;
          = 3:  the computation of stable projection failed;
          = 4:  the order of computed stable projection differs
                from the order of Hankel-norm approximation.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t)                           (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09CX determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t)                       (2)

  such that

        HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  The optimal Hankel-norm approximation method of [1], based on the
  square-root balancing projection formulas of [2], is employed.
References 
  [1] Glover, K.
      All optimal Hankel norm approximation of linear
      multivariable systems and their L-infinity error bounds.
      Int. J. Control, Vol. 36, pp. 1145-1193, 1984.

  [2] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
Numerical Aspects 
  The implemented methods rely on an accuracy enhancing square-root
  technique.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09DD.html000077500000000000000000000252011201767322700160470ustar00rootroot00000000000000 AB09DD - SLICOT Library Routine Documentation

AB09DD

Computation of a reduced order model using singular perturbation approximation formulas

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model by using singular perturbation
  approximation formulas.
Specification 
      SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, RCOND, IWORK, DWORK, INFO )
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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector, i.e. the order of the
          matrix A; also the number of rows of matrix B and the
          number of columns of the matrix C.  N >= 0.

  M       (input) INTEGER
          The dimension of input vector, i.e. the number of columns
          of matrices B and D.  M >= 0.

  P       (input) INTEGER
          The dimension of output vector, i.e. the number of rows of
          matrices C and D.  P >= 0.

  NR      (input) INTEGER
          The order of the reduced order system.  N >= NR >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix of the original system.
          On exit, the leading NR-by-NR part of this array contains
          the state dynamics matrix Ar of the reduced order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix of the original system.
          On exit, the leading NR-by-M part of this array contains
          the input/state matrix Br of the reduced order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix of the original system.
          On exit, the leading P-by-NR part of this array contains
          the state/output matrix Cr of the reduced order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the input/output matrix of the original system.
          On exit, the leading P-by-M part of this array contains
          the input/output matrix Dr of the reduced order system.
          If NR = 0 and the given system is stable, then D contains
          the steady state gain of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  RCOND   (output) DOUBLE PRECISION
          The reciprocal condition number of the matrix A22-g*I
          (see METHOD).
Workspace 
  IWORK   INTEGER array, dimension 2*(N-NR)

  DWORK   DOUBLE PRECISION array, dimension 4*(N-NR)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1: if the matrix A22-g*I (see METHOD) is numerically
               singular.
Method 
  Given the system (A,B,C,D), partition the system matrices as

         ( A11 A12 )        ( B1 )
     A = (         ) ,  B = (    ) ,  C = ( C1  C2 ),
         ( A21 A22 )        ( B2 )

  where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other
  submatrices have appropriate dimensions.

  The matrices of the reduced order system (Ar,Br,Cr,Dr) are
  computed according to the following residualization formulas:
                             -1                               -1
     Ar = A11 + A12*(g*I-A22)  *A21 ,  Br = B1 + A12*(g*I-A22)  *B2
                           -1                               -1
     Cr = C1 + C2*(g*I-A22)  *A21   ,  Dr = D + C2*(g*I-A22)  *B2

  where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'.
Further Comments 
  None
Example

Program Text 

*     AB09DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION RCOND
      INTEGER          I, INFO, J, M, N, NR, P
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09DD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, DICO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find a reduced ssr for (A,B,C).
               CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC,
     $                      D, LDD, RCOND, IWORK, DWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) RCOND
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09DD = ',I2)
99997 FORMAT (' The computed reciprocal condition number = ',1PD12.5)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 AB09DD EXAMPLE PROGRAM DATA  (Continuous system)
  7     2     3     5      C
  -0.04165    4.9200   -4.9200         0         0         0         0
         0   -3.3300         0         0         0    3.3300         0
    0.5450         0         0   -0.5450         0         0         0
         0         0    4.9200  -0.04165    4.9200         0         0
         0         0         0         0   -3.3300         0    3.3300
   -5.2100         0         0         0         0  -12.5000         0
         0         0         0   -5.2100         0         0  -12.5000
         0         0   
         0         0   
         0         0   
         0         0   
         0         0   
   12.5000         0   
         0   12.5000   
     1     0     0     0     0     0     0
     0     0     1     0     0     0     0
     0     0     0     1     0     0     0
     0     0     
     0     0     
     0     0
Program Results 
 AB09DD EXAMPLE PROGRAM RESULTS

 The computed reciprocal condition number =  1.00000D+00

 The reduced state dynamics matrix Ar is 
  -0.0416   4.9200  -4.9200   0.0000   0.0000
  -1.3879  -3.3300   0.0000   0.0000   0.0000
   0.5450   0.0000   0.0000  -0.5450   0.0000
   0.0000   0.0000   4.9200  -0.0416   4.9200
   0.0000   0.0000   0.0000  -1.3879  -3.3300

 The reduced input/state matrix Br is 
   0.0000   0.0000
   3.3300   0.0000
   0.0000   0.0000
   0.0000   0.0000
   0.0000   3.3300

 The reduced state/output matrix Cr is 
   1.0000   0.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   1.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000   0.0000

 The reduced input/output matrix Dr is 
   0.0000   0.0000
   0.0000   0.0000
   0.0000   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09ED.html000077500000000000000000000452461201767322700160630ustar00rootroot00000000000000 AB09ED - SLICOT Library Routine Documentation

AB09ED

Optimal Hankel-norm approximation based model reduction for unstable systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using the optimal
  Hankel-norm approximation method in conjunction with square-root
  balancing for the ALPHA-stable part of the system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. For a system with NU ALPHA-unstable
          eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
          NR is set as follows: if ORDSEL = 'F', NR is equal to
          NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the
          multiplicity of the Hankel singular value HSV(NR-NU+1),
          NR is the desired order on entry, and NMIN is the order
          of a minimal realization of the ALPHA-stable part of the
          given system; NMIN is determined as the number of Hankel
          singular values greater than NS*EPS*HNORM(As,Bs,Cs), where
          EPS is the machine precision (see LAPACK Library Routine
          DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the
          ALPHA-stable part of the given system (computed in
          HSV(1));
          if ORDSEL = 'A', NR is the sum of NU and the number of
          Hankel singular values greater than
          MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system in a real Schur form.
          The resulting A has a block-diagonal form with two blocks.
          For a system with NU ALPHA-unstable eigenvalues and
          NS ALPHA-stable eigenvalues (NU+NS = N), the leading
          NU-by-NU block contains the unreduced part of A
          corresponding to ALPHA-unstable eigenvalues.
          The trailing (NR+NS-N)-by-(NR+NS-N) block contains
          the reduced part of A corresponding to ALPHA-stable
          eigenvalues.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of HSV contain the
          Hankel singular values of the ALPHA-stable part of the
          original system ordered decreasingly.
          HSV(1) is the Hankel norm of the ALPHA-stable subsystem.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the
          interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the
          Hankel-norm of the ALPHA-stable part of the given system
          (computed in HSV(1)).
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of
          ALPHA-stable eigenvalues of A and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          This value is appropriate to compute a minimal realization
          of the ALPHA-stable part.
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the ALPHA-stable part of the given system.
          The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs).
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0, then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = MAX(1,M),   if DICO = 'C';
          LIWORK = MAX(1,N,M), if DICO = 'D'.
          On exit, if INFO = 0, IWORK(1) contains NMIN, the order of
          the computed minimal realization.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( LDW1, LDW2 ), where
          LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2,
          LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) +
                 MAX( 3*M+1, MIN(N,M)+P ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                system. In this case, the resulting NR is set equal
                to NSMIN.
          = 2:  with ORDSEL = 'F', the selected order NR is less
                than the order of the ALPHA-unstable part of the
                given system. In this case NR is set equal to the
                order of the ALPHA-unstable part.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the computation of the ordered real Schur form of A
                failed;
          = 2:  the separation of the ALPHA-stable/unstable diagonal
                blocks failed because of very close eigenvalues;
          = 3:  the computed ALPHA-stable part is just stable,
                having stable eigenvalues very near to the imaginary
                axis (if DICO = 'C') or to the unit circle
                (if DICO = 'D');
          = 4:  the computation of Hankel singular values failed;
          = 5:  the computation of stable projection in the
                Hankel-norm approximation algorithm failed;
          = 6:  the order of computed stable projection in the
                Hankel-norm approximation algorithm differs
                from the order of Hankel-norm approximation.
Method 
  Let be the following linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t)                           (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09ED determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t)                       (2)

  such that

  HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  The following procedure is used to reduce a given G:

  1) Decompose additively G as

       G = G1 + G2

     such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and
     G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles.

  2) Determine G1r, a reduced order approximation of the
     ALPHA-stable part G1.

  3) Assemble the reduced model Gr as

        Gr = G1r + G2.

  To reduce the ALPHA-stable part G1, the optimal Hankel-norm
  approximation method of [1], based on the square-root
  balancing projection formulas of [2], is employed.
References 
  [1] Glover, K.
      All optimal Hankel norm approximation of linear
      multivariable systems and their L-infinity error bounds.
      Int. J. Control, Vol. 36, pp. 1145-1193, 1984.

  [2] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
Numerical Aspects 
  The implemented methods rely on an accuracy enhancing square-root
  technique.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( NMAX, MMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*( 2*NMAX +
     $                                        MAX( NMAX, MMAX, PMAX ) +
     $                                 5 ) + ( NMAX*( NMAX + 1 ) )/2,
     $                                 NMAX*( MMAX + PMAX + 2 ) +
     $                                 2*MMAX*PMAX + MIN( NMAX, MMAX ) +
     $                                 MAX( 3*MMAX + 1,
     $                                      MIN( NMAX, MMAX ) +
     $                                      PMAX ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NR, NS, P
      CHARACTER*1      DICO, EQUIL, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09ED
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2,
     $                      DICO, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09ED EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09ED = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are')
      END
Program Data 
 AB09ED EXAMPLE PROGRAM DATA (Continuous system)
  7  2   3   0   -0.6D0 1.E-1  1.E-14 C  N  A  
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000  0.0000
  0.0000  0.0000
  0.0000  0.0000
Program Results 
 AB09ED EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values of ALPHA-stable part are
   1.9178   0.8621   0.7666   0.0336   0.0246

 The reduced state dynamics matrix Ar is 
  -0.5181  -1.1084   0.0000   0.0000   0.0000
   8.8157  -0.5181   0.0000   0.0000   0.0000
   0.0000   0.0000  -1.2769   7.3264   0.0000
   0.0000   0.0000  -0.6203  -1.2769   0.0000
   0.0000   0.0000   0.0000   0.0000  -1.5496

 The reduced input/state matrix Br is 
  -1.2837   1.2837
  -0.7522   0.7522
   3.2016   3.2016
  -0.7640  -0.7640
   1.3415  -1.3415

 The reduced state/output matrix Cr is 
  -0.1380  -0.6445  -0.6247  -2.0857  -0.8964
   0.6246   0.0196   0.0000   0.0000   0.6131
   0.1380   0.6445  -0.6247  -2.0857   0.8964

 The reduced input/output matrix Dr is 
   0.0168  -0.0168
   0.0008  -0.0008
  -0.0168   0.0168

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09FD.html000077500000000000000000000456431201767322700160650ustar00rootroot00000000000000 AB09FD - SLICOT Library Routine Documentation

AB09FD

Balance & Truncate model reduction for unstable systems in conjunction with coprime factorization

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr) for an original
  state-space representation (A,B,C) by using either the square-root
  or the balancing-free square-root Balance & Truncate (B & T)
  model reduction method in conjunction with stable coprime
  factorization techniques.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBCF   CHARACTER*1
          Specifies whether left or right coprime factorization is
          to be used as follows:
          = 'L':  use left coprime factorization;
          = 'R':  use right coprime factorization.

  FACT    CHARACTER*1
          Specifies the type of coprime factorization to be computed
          as follows:
          = 'S':  compute a coprime factorization with prescribed
                  stability degree ALPHA;
          = 'I':  compute a coprime factorization with inner
                  denominator.

  JOBMR   CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'N':  use the balancing-free square-root
                  Balance & Truncate method.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR
          is the desired order on entry, NQ is the order of the
          computed coprime factorization of the given system, and
          NMIN is the order of a minimal realization of the extended
          system (see METHOD); NMIN is determined as the number of
          Hankel singular values greater than NQ*EPS*HNORM(Ge),
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the
          extended system (computed in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)).

  ALPHA   (input) DOUBLE PRECISION
          If FACT = 'S', the desired stability degree for the
          factors of the coprime factorization (see SLICOT Library
          routines SB08ED/SB08FD).
          ALPHA < 0 for a continuous-time system (DICO = 'C'), and
          0 <= ALPHA < 1 for a discrete-time system (DICO = 'D').
          If FACT = 'I', ALPHA is not used.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the reduced
          order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  NQ      (output) INTEGER
          The order of the computed extended system Ge (see METHOD).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the NQ Hankel singular values of
          the extended system Ge ordered decreasingly (see METHOD).
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced extended system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(Ge), where c is a constant in the
          interval [0.00001,0.001], and HNORM(Ge) is the
          Hankel-norm of the extended system (computed in HSV(1)).
          The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if
          TOL1 <= 0 on entry, where EPS is the machine precision
          (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The absolute tolerance level below which the elements of
          B or C are considered zero (used for controllability or
          observability tests).
          If the user sets TOL2 <= 0, then an implicitly computed,
          default tolerance TOLDEF is used:
          TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or
          TOLDEF = N*EPS*NORM(B),  if JOBCF = 'R',
          where EPS is the machine precision, and NORM(.) denotes
          the 1-norm of a matrix.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = PM,        if JOBMR = 'B',
          LIWORK = MAX(N,PM), if JOBMR = 'N', where
          PM = P, if JOBCF = 'L',
          PM = M, if JOBCF = 'R'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S',
          LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I',
          LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S',
          LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where
          LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) +
                MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ),
          LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) +
                MAX( N*P+MAX(N*(N+5), P*(P+2), 4*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 ), and
          LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 10*K+I:
            I = 1:  with ORDSEL = 'F', the selected order NR is
                    greater than the order of the computed coprime
                    factorization of the given system. In this case,
                    the resulting NR is set automatically to a value
                    corresponding to the order of a minimal
                    realization of the system;
            K > 0:  K violations of the numerical stability
                    condition occured when computing the coprime
                    factorization using pole assignment (see SLICOT
                    Library routines SB08CD/SB08ED, SB08DD/SB08FD).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the ordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + H*C)*Z
                (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT
                Library routines SB08CD/SB08ED (or SB08DD/SB08FD);
          = 3:  the matrix A has an observable or controllable
                eigenvalue on the imaginary axis if DICO = 'C' or
                on the unit circle if DICO = 'D';
          = 4:  the computation of Hankel singular values failed.
Method 
  Let be the linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t)                               (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system, and let G be the corresponding
  transfer-function matrix. The subroutine AB09FD determines
  the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t)                             (2)

  with the transfer-function matrix Gr, by using the
  balanced-truncation model reduction method in conjunction with
  a left coprime factorization (LCF) or a right coprime
  factorization (RCF) technique:

  1. Compute the appropriate stable coprime factorization of G:
                  -1                   -1
             G = R  *Q (LCF) or G = Q*R   (RCF).

  2. Perform the model reduction algorithm on the extended system
                                        ( Q )
             Ge = ( Q R ) (LCF) or Ge = ( R )  (RCF)

     to obtain a reduced extended system with reduced factors
                                            ( Qr )
             Ger = ( Qr Rr ) (LCF) or Ger = ( Rr )  (RCF).

  3. Recover the reduced system from the reduced factors as
                    -1                       -1
             Gr = Rr  *Qr (LCF) or Gr = Qr*Rr   (RCF).

  The approximation error for the extended system satisfies

     HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)],

  where INFNORM(G) is the infinity-norm of G.

  If JOBMR = 'B', the square-root Balance & Truncate method of [1]
  is used for model reduction.
  If JOBMR = 'N', the balancing-free square-root version of the
  Balance & Truncate method [2] is used for model reduction.

  If FACT = 'S', the stable coprime factorization with prescribed
  stability degree ALPHA is computed by using the algorithm of [3].
  If FACT = 'I', the stable coprime factorization with inner
  denominator is computed by using the algorithm of [4].
References 
  [1] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [2] Varga A.
      Efficient minimal realization procedure based on balancing.
      Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
      A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2,
      pp. 42-46, 1991.

  [3] Varga A.
      Coprime factors model reduction method based on square-root
      balancing-free techniques.
      System Analysis, Modelling and Simulation, Vol. 11,
      pp. 303-311, 1993.

  [4] Varga A.
      A Schur method for computing coprime factorizations with
      inner denominators and applications in model reduction.
      Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09FD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( NMAX, MMAX, PMAX ) )
*     The formula below uses that NMAX = MMAX = PMAX.
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 10*NMAX*NMAX + 5*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NQ, NR, P
      CHARACTER*1      DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09FD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2,
     $                      DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
*              Find a reduced ssr for (A,B,C).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NQ )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NR )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09FD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09FD = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of coprime factors are')
      END
Program Data 
 AB08FD EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3  0 -1.e-1  .1 1.E-10 C L I B S A
 -0.04165  0.0000  4.9200   0.4920  0.0000   0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000   0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000   0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000  0.0545   0.0000  0.0000
  0.0000   0.0000  0.0000  -0.49200 0.004165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000  0.5210  -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000   3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
Program Results 
 AB09FD EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values of coprime factors are
  13.6047   9.4106   1.7684   0.7456   0.6891   0.0241   0.0230

 The reduced state dynamics matrix Ar is 
   0.0520  -0.1491   0.0037  -0.0232   0.0168
   0.2340   0.2618   0.0010  -0.0153  -0.0318
   0.1197   0.0075  -0.5752   2.0119  -0.7779
   0.1571  -0.2019  -2.1282  -2.1192  -0.3618
   0.0368  -0.4810   0.8395  -0.2790  -2.8796

 The reduced input/state matrix Br is 
   1.0454   0.5860
  -0.0489  -1.9194
  -1.4282   0.0541
  -1.6144  -0.7533
   0.5916  -1.9242

 The reduced state/output matrix Cr is 
   0.4368   0.1122  -1.2917   1.5888  -0.6354
   1.1170   0.3963   0.6115   0.1249  -0.0859
   0.0756  -1.8904   0.0144   0.7964   1.9085

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09GD.html000077500000000000000000000506331201767322700160610ustar00rootroot00000000000000 AB09GD - SLICOT Library Routine Documentation

AB09GD

Singular Perturbation Approximation based model reduction for unstable systems in conjunction with coprime factorization

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using either the
  square-root or the balancing-free square-root Singular
  Perturbation Approximation (SPA) model reduction method in
  conjunction with stable coprime factorization techniques.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBCF   CHARACTER*1
          Specifies whether left or right coprime factorization is
          to be used as follows:
          = 'L':  use left coprime factorization;
          = 'R':  use right coprime factorization.

  FACT    CHARACTER*1
          Specifies the type of coprime factorization to be computed
          as follows:
          = 'S':  compute a coprime factorization with prescribed
                  stability degree ALPHA;
          = 'I':  compute a coprime factorization with inner
                  denominator.

  JOBMR   CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'N':  use the balancing-free square-root
                  Balance & Truncate method.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR
          is the desired order on entry, NQ is the order of the
          computed coprime factorization of the given system, and
          NMIN is the order of a minimal realization of the extended
          system (see METHOD); NMIN is determined as the number of
          Hankel singular values greater than NQ*EPS*HNORM(Ge),
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the
          extended system (computed in HSV(1));
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)).

  ALPHA   (input) DOUBLE PRECISION
          If FACT = 'S', the desired stability degree for the
          factors of the coprime factorization (see SLICOT Library
          routines SB08ED/SB08FD).
          ALPHA < 0 for a continuous-time system (DICO = 'C'), and
          0 <= ALPHA < 1 for a discrete-time system (DICO = 'D').
          If FACT = 'I', ALPHA is not used.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the reduced
          order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NQ      (output) INTEGER
          The order of the computed extended system Ge (see METHOD).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the NQ Hankel singular values of
          the extended system Ge ordered decreasingly (see METHOD).
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced extended system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(Ge), where c is a constant in the
          interval [0.00001,0.001], and HNORM(Ge) is the
          Hankel-norm of the extended system (computed in HSV(1)).
          The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if
          TOL1 <= 0 on entry, where EPS is the machine precision
          (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the extended system Ge (see METHOD).
          The recommended value is TOL2 = NQ*EPS*HNORM(Ge).
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0, then TOL2 <= TOL1.

  TOL3    DOUBLE PRECISION
          The absolute tolerance level below which the elements of
          B or C are considered zero (used for controllability or
          observability tests by the coprime factorization method).
          If the user sets TOL3 <= 0, then an implicitly computed,
          default tolerance TOLDEF is used:
          TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or
          TOLDEF = N*EPS*NORM(B),  if JOBCF = 'R',
          where EPS is the machine precision, and NORM(.) denotes
          the 1-norm of a matrix.
Workspace 
  IWORK   INTEGER array, dimension (MAX(1,2*N,PM))
          where  PM = P, if JOBCF = 'L',
                 PM = M, if JOBCF = 'R'.
          On exit with INFO = 0, IWORK(1) contains the order of the
          minimal realization of the system.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S',
          LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I',
          LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S',
          LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where
          LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) +
                MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ),
          LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) +
                MAX( N*P+MAX(N*(N+5), P*(P+2), 4*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 ), and
          LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 10*K+I:
            I = 1:  with ORDSEL = 'F', the selected order NR is
                    greater than the order of the computed coprime
                    factorization of the given system. In this case,
                    the resulting NR is set automatically to a value
                    corresponding to the order of a minimal
                    realization of the system;
            K > 0:  K violations of the numerical stability
                    condition occured when computing the coprime
                    factorization using pole assignment (see SLICOT
                    Library routines SB08CD/SB08ED, SB08DD/SB08FD).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the ordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + H*C)*Z
                (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT
                Library routines SB08CD/SB08ED (or SB08DD/SB08FD);
          = 3:  the matrix A has an observable or controllable
                eigenvalue on the imaginary axis if DICO = 'C' or
                on the unit circle if DICO = 'D';
          = 4:  the computation of Hankel singular values failed.
Method 
  Let be the linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t)                       (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system, and let G be the corresponding
  transfer-function matrix. The subroutine AB09GD determines
  the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t)                   (2)

  with the transfer-function matrix Gr, by using the
  singular perturbation approximation (SPA) method in conjunction
  with a left coprime factorization (LCF) or a right coprime
  factorization (RCF) technique:

  1. Compute the appropriate stable coprime factorization of G:
                  -1                   -1
             G = R  *Q (LCF) or G = Q*R   (RCF).

  2. Perform the model reduction algorithm on the extended system
                                        ( Q )
             Ge = ( Q R ) (LCF) or Ge = ( R )  (RCF)

     to obtain a reduced extended system with reduced factors
                                            ( Qr )
             Ger = ( Qr Rr ) (LCF) or Ger = ( Rr )  (RCF).

  3. Recover the reduced system from the reduced factors as
                    -1                       -1
             Gr = Rr  *Qr (LCF) or Gr = Qr*Rr   (RCF).

  The approximation error for the extended system satisfies

     HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)],

  where INFNORM(G) is the infinity-norm of G.

  If JOBMR = 'B', the balancing-based square-root SPA method of [1]
  is used for model reduction.
  If JOBMR = 'N', the balancing-free square-root SPA method of [2]
  is used for model reduction.
  By setting TOL1 = TOL2, the routine can be used to compute
  Balance & Truncate approximations.

  If FACT = 'S', the stable coprime factorization with prescribed
  stability degree ALPHA is computed by using the algorithm of [3].
  If FACT = 'I', the stable coprime factorization with inner
  denominator is computed by using the algorithm of [4].
References 
  [1] Liu Y. and Anderson B.D.O.
      Singular Perturbation Approximation of Balanced Systems.
      Int. J. Control, Vol. 50, pp. 1379-1405, 1989.

  [2] Varga A.
      Balancing-free square-root algorithm for computing singular
      perturbation approximations.
      Proc. 30-th IEEE CDC,  Brighton, Dec. 11-13, 1991, Vol. 2,
      pp. 1062-1065.

  [3] Varga A.
      Coprime factors model reduction method based on square-root
      balancing-free techniques.
      System Analysis, Modelling and Simulation, Vol. 11,
      pp. 303-311, 1993.

  [4] Varga A.
      A Schur method for computing coprime factorizations with
      inner denominators and applications in model reduction.
      Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09GD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX, MMAX, PMAX ) )
*     The formula below uses that NMAX = MMAX = PMAX.
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 10*NMAX*NMAX + 5*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3
      INTEGER          I, INFO, IWARN, J, M, N, NQ, NR, P
      CHARACTER*1      DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09GD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, TOL3,
     $                      DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P )
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NQ )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M )
   80             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09GD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09GD = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of coprime factors are')
      END
Program Data 
 AB08GD EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3  0 -1.e-1  .1 1.E-10 1.E-10 C L I B S A
 -0.04165  0.0000  4.9200   0.4920  0.0000   0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000   0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000   0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000  0.0545   0.0000  0.0000
  0.0000   0.0000  0.0000  -0.49200 0.004165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000  0.5210  -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000   3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 AB09GD EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values of coprime factors are
  13.6047   9.4106   1.7684   0.7456   0.6891   0.0241   0.0230

 The reduced state dynamics matrix Ar is 
   0.0521  -0.1491   0.0032  -0.0242   0.0181
   0.2341   0.2615   0.0009  -0.0171  -0.0362
   0.1170   0.0076  -0.5471   2.0904  -0.8098
   0.1675  -0.2122  -2.2113  -2.4097  -0.4139
   0.0390  -0.5061   0.8787  -0.3166  -3.2955

 The reduced input/state matrix Br is 
   1.0449   0.5863
  -0.0490  -1.9210
  -1.3930   0.0540
  -1.7206  -0.8039
   0.6358  -2.0542

 The reduced state/output matrix Cr is 
   0.4331   0.1125  -1.2534   1.6965  -0.6773
   1.1171   0.3963   0.6102   0.1213  -0.0841
   0.0736  -1.8815   0.0134   0.8457   2.0413

 The reduced input/output matrix Dr is 
   0.0480   0.0003
  -0.0017   0.0001
   0.0005   0.0460

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09HD.html000077500000000000000000000554501201767322700160640ustar00rootroot00000000000000 AB09HD - SLICOT Library Routine Documentation

AB09HD

Stochastic balancing based model reduction

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using the stochastic
  balancing approach in conjunction with the square-root or
  the balancing-free square-root Balance & Truncate (B&T)
  or Singular Perturbation Approximation (SPA) model reduction
  methods for the ALPHA-stable part of the system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'F':  use the balancing-free square-root
                  Balance & Truncate method;
          = 'S':  use the square-root Singular Perturbation
                  Approximation method;
          = 'P':  use the balancing-free square-root
                  Singular Perturbation Approximation method.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e., the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.
          P <= M if BETA = 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. For a system with NU ALPHA-unstable
          eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
          NR is set as follows: if ORDSEL = 'F', NR is equal to
          NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order
          on entry, and NMIN is the order of a minimal realization
          of the ALPHA-stable part of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than NS*EPS, where EPS is the machine precision
          (see LAPACK Library Routine DLAMCH);
          if ORDSEL = 'A', NR is the sum of NU and the number of
          Hankel singular values greater than MAX(TOL1,NS*EPS);
          NR can be further reduced to ensure that
          HSV(NR-NU) > HSV(NR+1-NU).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  BETA    (input) DOUBLE PRECISION
          BETA > 0 specifies the absolute/relative error weighting
          parameter. A large positive value of BETA favours the
          minimization of the absolute approximation error, while a
          small value of BETA is appropriate for the minimization
          of the relative error.
          BETA = 0 means a pure relative error method and can be
          used only if rank(D) = P.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the reduced
          order system.
          The resulting A has a block-diagonal form with two blocks.
          For a system with NU ALPHA-unstable eigenvalues and
          NS ALPHA-stable eigenvalues (NU+NS = N), the leading
          NU-by-NU block contains the unreduced part of A
          corresponding to ALPHA-unstable eigenvalues in an
          upper real Schur form.
          The trailing (NR+NS-N)-by-(NR+NS-N) block contains
          the reduced part of A corresponding to ALPHA-stable
          eigenvalues.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of HSV contain the
          Hankel singular values of the phase system corresponding
          to the ALPHA-stable part of the original system.
          The Hankel singular values are ordered decreasingly.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value of TOL1 lies
          in the interval [0.00001,0.001].
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = NS*EPS, where NS is the number of
          ALPHA-stable eigenvalues of A and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.
          TOL1 < 1.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the phase system (see METHOD) corresponding
          to the ALPHA-stable part of the given system.
          The recommended value is TOL2 = NS*EPS.
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
          TOL2 < 1.
Workspace 
  IWORK   INTEGER array, dimension MAX(1,2*N)
          On exit with INFO = 0, IWORK(1) contains the order of the
          minimal realization of the system.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK and DWORK(2) contains RCOND, the reciprocal
          condition number of the U11 matrix from the expression
          used to compute the solution X = U21*inv(U11) of the
          Riccati equation for spectral factorization.
          A small value RCOND indicates possible ill-conditioning
          of the respective Riccati equation.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 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) ) ),
          where MB = M if BETA = 0 and MB = M+P if BETA > 0.
          For optimum performance LDWORK should be larger.

  BWORK   LOGICAL array, dimension 2*N
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                system; in this case, the resulting NR is set equal
                to NSMIN;
          = 2:  with ORDSEL = 'F', the selected order NR corresponds
                to repeated singular values for the ALPHA-stable
                part, which are neither all included nor all
                excluded from the reduced model; in this case, the
                resulting NR is automatically decreased to exclude
                all repeated singular values;
          = 3:  with ORDSEL = 'F', the selected order NR is less
                than the order of the ALPHA-unstable part of the
                given system; in this case NR is set equal to the
                order of the ALPHA-unstable part.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the computation of the ordered real Schur form of A
                failed;
          = 2:  the reduction of the Hamiltonian matrix to real
                Schur form failed;
          = 3:  the reordering of the real Schur form of the
                Hamiltonian matrix failed;
          = 4:  the Hamiltonian matrix has less than N stable
                eigenvalues;
          = 5:  the coefficient matrix U11 in the linear system
                X*U11 = U21 to determine X is singular to working
                precision;
          = 6:  BETA = 0 and D has not a maximal row rank;
          = 7:  the computation of Hankel singular values failed;
          = 8:  the separation of the ALPHA-stable/unstable diagonal
                blocks failed because of very close eigenvalues;
          = 9:  the resulting order of reduced stable part is less
                than the number of unstable zeros of the stable
                part.
Method 
  Let be the following linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                      (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09HD determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t),                  (2)

  such that

       INFNORM[inv(conj(W))*(G-Gr)] <=
                    (1+HSV(NR+NS-N+1)) / (1-HSV(NR+NS-N+1)) + ...
                    + (1+HSV(NS)) / (1-HSV(NS)) - 1,

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, W is the right, minimum
  phase spectral factor satisfying

      G1*conj(G1) = conj(W)* W,                      (3)

  G1 is the NS-order ALPHA-stable part of G, and INFNORM(G) is the
  infinity-norm of G. HSV(1), ... , HSV(NS) are the Hankel-singular
  values of the stable part of the phase system (Ap,Bp,Cp)
  with the transfer-function matrix

       P = inv(conj(W))*G1.

  If BETA > 0, then the model reduction is performed on [G BETA*I]
  instead of G. This is the recommended approach to be used when D
  has not a maximal row rank or when a certain balance between
  relative and absolute approximation errors is desired. For
  increasingly large values of BETA, the obtained reduced system
  assymptotically approaches that computed by using the
  Balance & Truncate or Singular Perturbation Approximation methods.

  Note: conj(G)  denotes either G'(-s) for a continuous-time system
        or G'(1/z) for a discrete-time system.
        inv(G) is the inverse of G.

  The following procedure is used to reduce a given G:

  1) Decompose additively G as

       G = G1 + G2,

     such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and
     G2 = (Au,Bu,Cu) has only ALPHA-unstable poles.

  2) Determine G1r, a reduced order approximation of the
     ALPHA-stable part G1 using the balancing stochastic method
     in conjunction with either the B&T [1,2] or SPA methods [3].

  3) Assemble the reduced model Gr as

        Gr = G1r + G2.

  Note: The employed stochastic truncation algorithm [2,3] has the
  property that right half plane zeros of G1 remain as right half
  plane zeros of G1r. Thus, the order can not be chosen smaller than
  the sum of the number of unstable poles of G and the number of
  unstable zeros of G1.

  The reduction of the ALPHA-stable part G1 is done as follows.

  If JOB = 'B', the square-root stochastic Balance & Truncate
  method of [1] is used.
  For an ALPHA-stable continuous-time system (DICO = 'C'),
  the resulting reduced model is stochastically balanced.

  If JOB = 'F', the balancing-free square-root version of the
  stochastic Balance & Truncate method [1] is used to reduce
  the ALPHA-stable part G1.

  If JOB = 'S', the stochastic balancing method is used to reduce
  the ALPHA-stable part G1, in conjunction with the square-root
  version of the Singular Perturbation Approximation method [3,4].

  If JOB = 'P', the stochastic balancing method is used to reduce
  the ALPHA-stable part G1, in conjunction with the balancing-free
  square-root version of the Singular Perturbation Approximation
  method [3,4].
References 
  [1] Varga A. and Fasol K.H.
      A new square-root balancing-free stochastic truncation model
      reduction algorithm.
      Proc. 12th IFAC World Congress, Sydney, 1993.

  [2] Safonov M. G. and Chiang R. Y.
      Model reduction for robust control: a Schur relative error
      method.
      Int. J. Adapt. Contr. Sign. Proc., vol. 2, pp. 259-272, 1988.

  [3] Green M. and Anderson B. D. O.
      Generalized balanced stochastic truncation.
      Proc. 29-th CDC, Honolulu, Hawaii, pp. 476-481, 1990.

  [4] Varga A.
      Balancing-free square-root algorithm for computing
      singular perturbation approximations.
      Proc. 30-th IEEE CDC,  Brighton, Dec. 11-13, 1991,
      Vol. 2, pp. 1062-1065.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques. The effectiveness of the
  accuracy enhancing technique depends on the accuracy of the
  solution of a Riccati equation. An ill-conditioned Riccati
  solution typically results when [D BETA*I] is nearly
  rank deficient.
                                   3
  The algorithm requires about 100N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09HD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                 LDD = PMAX )
      INTEGER          LBWORK, LIWORK
      PARAMETER        ( LBWORK = 2*NMAX, LIWORK = 2*NMAX )
      INTEGER          LDWORK, MBMAX
      PARAMETER        ( MBMAX = MMAX + PMAX )
      PARAMETER        ( LDWORK = 2*NMAX*NMAX + MBMAX*(NMAX+PMAX) +
     $                      MAX( NMAX*(MAX( NMAX, MMAX, PMAX) + 5),
     $                     2*NMAX*PMAX + MAX( PMAX*(MBMAX+2),
     $                                        10*NMAX*(NMAX+1) ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NR, NS, P
      CHARACTER*1      DICO, EQUIL, JOB, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX)
      LOGICAL          BWORK(LBWORK)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09HD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, BETA, TOL1, TOL2,
     $                      DICO, JOB, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09HD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09HD = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The stochastic Hankel singular values of ALPHA-stable'
     $        ,' part are')
      END
Program Data 
 AB09HD EXAMPLE PROGRAM DATA (Continuous system)
  7  2   3   0   0.0   1.0  0.1E0  0.0    C     F     N     A
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
Program Results 
 AB09HD EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The stochastic Hankel singular values of ALPHA-stable part are
   0.8803   0.8506   0.8038   0.4494   0.3973   0.0214   0.0209

 The reduced state dynamics matrix Ar is 
   1.2729   0.0000   6.5947   0.0000  -3.4229
   0.0000   0.8169   0.0000   2.4821   0.0000
  -2.9889   0.0000  -2.9028   0.0000  -0.3692
   0.0000  -3.3921   0.0000  -3.1126   0.0000
  -1.4767   0.0000  -2.0339   0.0000  -0.6107

 The reduced input/state matrix Br is 
   0.1331  -0.1331
  -0.0862  -0.0862
  -2.6777   2.6777
  -3.5767  -3.5767
  -2.3033   2.3033

 The reduced state/output matrix Cr is 
  -0.6907  -0.6882   0.0779   0.0958  -0.0038
   0.0676   0.0000   0.6532   0.0000  -0.7522
   0.6907  -0.6882  -0.0779   0.0958   0.0038

 The reduced input/output matrix Dr is 
   0.0000   0.0000
   0.0000   0.0000
   0.0000   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09HX.html000077500000000000000000000313731201767322700161060ustar00rootroot00000000000000 AB09HX - SLICOT Library Routine Documentation

AB09HX

Stochastic balancing model reduction of stable systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  stable state-space representation (A,B,C,D) by using the
  stochastic balancing approach in conjunction with the square-root
  or the balancing-free square-root Balance & Truncate (B&T) or
  Singular Perturbation Approximation (SPA) model reduction methods.
  The state dynamics matrix A of the original system is an upper
  quasi-triangular matrix in real Schur canonical form and D must be
  full row rank.

  For the B&T approach, the matrices of the reduced order system
  are computed using the truncation formulas:

       Ar = TI * A * T ,  Br = TI * B ,  Cr = C * T .     (1)

  For the SPA approach, the matrices of a minimal realization
  (Am,Bm,Cm) are computed using the truncation formulas:

       Am = TI * A * T ,  Bm = TI * B ,  Cm = C * T .     (2)

  Am, Bm, Cm and D serve further for computing the SPA of the given
  system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'F':  use the balancing-free square-root
                  Balance & Truncate method;
          = 'S':  use the square-root Singular Perturbation
                  Approximation method;
          = 'P':  use the balancing-free square-root
                  Singular Perturbation Approximation method.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e., the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  M >= P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR
          is the desired order on entry and NMIN is the order of a
          minimal realization of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than N*EPS, where EPS is the machine precision
          (see LAPACK Library Routine DLAMCH);
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,N*EPS).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A in a real Schur
          canonical form.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values,
          ordered decreasingly, of the phase system. All singular
          values are less than or equal to 1.

  T       (output) DOUBLE PRECISION array, dimension (LDT,N)
          If INFO = 0 and NR > 0, the leading N-by-NR part of this
          array contains the right truncation matrix T in (1), for
          the B&T approach, or in (2), for the SPA approach.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  TI      (output) DOUBLE PRECISION array, dimension (LDTI,N)
          If INFO = 0 and NR > 0, the leading NR-by-N part of this
          array contains the left truncation matrix TI in (1), for
          the B&T approach, or in (2), for the SPA approach.

  LDTI    INTEGER
          The leading dimension of array TI.  LDTI >= MAX(1,N).
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value lies in the
          interval [0.00001,0.001].
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = N*EPS, where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the phase system (see METHOD) corresponding
          to the given system.
          The recommended value is TOL2 = N*EPS.
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension MAX(1,2*N)
          On exit with INFO = 0, IWORK(1) contains the order of the
          minimal realization of the system.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK and DWORK(2) contains RCOND, the reciprocal
          condition number of the U11 matrix from the expression
          used to compute the solution X = U21*inv(U11) of the
          Riccati equation for spectral factorization.
          A small value RCOND indicates possible ill-conditioning
          of the respective Riccati equation.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 2, N*(MAX(N,M,P)+5),
                         2*N*P+MAX(P*(M+2),10*N*(N+1) ) ).
          For optimum performance LDWORK should be larger.

  BWORK   LOGICAL array, dimension 2*N
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than the order of a minimal realization of the
                given system. In this case, the resulting NR is
                set automatically to a value corresponding to the
                order of a minimal realization of the system.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D'), or it is not in
                a real Schur form;
          = 2:  the reduction of Hamiltonian matrix to real
                Schur form failed;
          = 3:  the reordering of the real Schur form of the
                Hamiltonian matrix failed;
          = 4:  the Hamiltonian matrix has less than N stable
                eigenvalues;
          = 5:  the coefficient matrix U11 in the linear system
                X*U11 = U21, used to determine X, is singular to
                working precision;
          = 6:  the feedthrough matrix D has not a full row rank P;
          = 7:  the computation of Hankel singular values failed.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                             (3)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09HX determines for
  the given system (3), the matrices of a reduced NR-rder system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t),                         (4)

  such that

        HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  If JOB = 'B', the square-root stochastic Balance & Truncate
  method of [1] is used and the resulting model is balanced.

  If JOB = 'F', the balancing-free square-root version of the
  stochastic Balance & Truncate method [1] is used.

  If JOB = 'S', the stochastic balancing method, in conjunction
  with the square-root version of the Singular Perturbation
  Approximation method [2,3] is used.

  If JOB = 'P', the stochastic balancing method, in conjunction
  with the balancing-free square-root version of the Singular
  Perturbation Approximation method [2,3] is used.

  By setting TOL1 = TOL2, the routine can be also used to compute
  Balance & Truncate approximations.
References 
  [1] Varga A. and Fasol K.H.
      A new square-root balancing-free stochastic truncation
      model reduction algorithm.
      Proc. of 12th IFAC World Congress, Sydney, 1993.

  [2] Liu Y. and Anderson B.D.O.
      Singular Perturbation Approximation of balanced systems.
      Int. J. Control, Vol. 50, pp. 1379-1405, 1989.

  [3] Varga A.
      Balancing-free square-root algorithm for computing singular
      perturbation approximations.
      Proc. 30-th IEEE CDC,  Brighton, Dec. 11-13, 1991,
      Vol. 2, pp. 1062-1065.
Numerical Aspects 
  The implemented method relies on accuracy enhancing square-root
  or balancing-free square-root methods. The effectiveness of the
  accuracy enhancing technique depends on the accuracy of the
  solution of a Riccati equation. Ill-conditioned Riccati solution
  typically results when D is nearly rank deficient.
                                   3
  The algorithm requires about 100N  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09HY.html000077500000000000000000000137331201767322700161070ustar00rootroot00000000000000 AB09HY - SLICOT Library Routine Documentation

AB09HY

Cholesky factors of the controllability and observability Grammians

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Cholesky factors Su and Ru of the controllability
  Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru,
  respectively, satisfying

         A*P  + P*A' +  scalec^2*B*B'   = 0,       (1)

         A'*Q + Q*A  +  scaleo^2*Cw'*Cw = 0,       (2)

  where
         Cw = Hw - Bw'*X,
         Hw = inv(Dw)*C,
         Bw = (B*D' + P*C')*inv(Dw'),
         D*D' = Dw*Dw' (Dw upper triangular),

  and, with Aw = A - Bw*Hw, X is the stabilizing solution of the
  Riccati equation

         Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0.   (3)

  The P-by-M matrix D must have full row rank. Matrix A must be
  stable and in a real Schur form.
Specification 
      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     .. 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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of state-space representation, i.e.,
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  M >= P >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          stable state dynamics matrix A in a real Schur canonical
          form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B, corresponding to the Schur matrix A.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C, corresponding to the Schur
          matrix A.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must
          contain the full row rank input/output matrix D.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  SCALEC  (output) DOUBLE PRECISION
          Scaling factor for the controllability Grammian in (1).

  SCALEO  (output) DOUBLE PRECISION
          Scaling factor for the observability Grammian in (2).

  S       (output) DOUBLE PRECISION array, dimension (LDS,N)
          The leading N-by-N upper triangular part of this array
          contains the Cholesky factor Su of the cotrollability
          Grammian P = Su*Su' satisfying (1).

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,N).

  R       (output) DOUBLE PRECISION array, dimension (LDR,N)
          The leading N-by-N upper triangular part of this array
          contains the Cholesky factor Ru of the observability
          Grammian Q = Ru'*Ru satisfying (2).

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).
Workspace 
  IWORK   INTEGER array, dimension 2*N

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK and DWORK(2) contains RCOND, the reciprocal
          condition number of the U11 matrix from the expression
          used to compute X = U21*inv(U11). A small value RCOND
          indicates possible ill-conditioning of the Riccati
          equation (3).

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 2, N*(MAX(N,M,P)+5),
                         2*N*P+MAX(P*(M+2),10*N*(N+1) ) ).
          For optimum performance LDWORK should be larger.

  BWORK   LOGICAL array, dimension 2*N
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the state matrix A is not stable or is not in a
                real Schur form;
          = 2:  the reduction of Hamiltonian matrix to real Schur
                form failed;
          = 3:  the reordering of the real Schur form of the
                Hamiltonian matrix failed;
          = 4:  the Hamiltonian matrix has less than N stable
                eigenvalues;
          = 5:  the coefficient matrix U11 in the linear system
                X*U11 = U21, used to determine X, is singular to
                working precision;
          = 6:  the feedthrough matrix D has not a full row rank P.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09ID.html000077500000000000000000001127761201767322700160720ustar00rootroot00000000000000 AB09ID - SLICOT Library Routine Documentation

AB09ID

Frequency-weighted model reduction based on balancing techniques

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using the frequency
  weighted square-root or balancing-free square-root
  Balance & Truncate (B&T) or Singular Perturbation Approximation
  (SPA) model reduction methods. The algorithm tries to minimize
  the norm of the frequency-weighted error

        ||V*(G-Gr)*W||

  where G and Gr are the transfer-function matrices of the original
  and reduced order models, respectively, and V and W are
  frequency-weighting transfer-function matrices. V and W must not
  have poles on the imaginary axis for a continuous-time
  system or on the unit circle for a discrete-time system.
  If G is unstable, only the ALPHA-stable part of G is reduced.
  In case of possible pole-zero cancellations in V*G and/or G*W,
  the absolute values of parameters ALPHAO and/or ALPHAC must be
  different from 1.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBC    CHARACTER*1
          Specifies the choice of frequency-weighted controllability
          Grammian as follows:
          = 'S': choice corresponding to a combination method [4]
                 of the approaches of Enns [1] and Lin-Chiu [2,3];
          = 'E': choice corresponding to the stability enhanced
                 modified combination method of [4].

  JOBO    CHARACTER*1
          Specifies the choice of frequency-weighted observability
          Grammian as follows:
          = 'S': choice corresponding to a combination method [4]
                 of the approaches of Enns [1] and Lin-Chiu [2,3];
          = 'E': choice corresponding to the stability enhanced
                 modified combination method of [4].

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'F':  use the balancing-free square-root
                  Balance & Truncate method;
          = 'S':  use the square-root Singular Perturbation
                  Approximation method;
          = 'P':  use the balancing-free square-root
                  Singular Perturbation Approximation method.

  WEIGHT  CHARACTER*1
          Specifies the type of frequency weighting, as follows:
          = 'N':  no weightings are used (V = I, W = I);
          = 'L':  only left weighting V is used (W = I);
          = 'R':  only right weighting W is used (V = I);
          = 'B':  both left and right weightings V and W are used.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e., the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NV      (input) INTEGER
          The order of the matrix AV. Also the number of rows of
          the matrix BV and the number of columns of the matrix CV.
          NV represents the dimension of the state vector of the
          system with the transfer-function matrix V.  NV >= 0.

  PV      (input) INTEGER
          The number of rows of the matrices CV and DV.  PV >= 0.
          PV represents the dimension of the output vector of the
          system with the transfer-function matrix V.

  NW      (input) INTEGER
          The order of the matrix AW. Also the number of rows of
          the matrix BW and the number of columns of the matrix CW.
          NW represents the dimension of the state vector of the
          system with the transfer-function matrix W.  NW >= 0.

  MW      (input) INTEGER
          The number of columns of the matrices BW and DW.  MW >= 0.
          MW represents the dimension of the input vector of the
          system with the transfer-function matrix W.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. For a system with NU ALPHA-unstable
          eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
          NR is set as follows: if ORDSEL = 'F', NR is equal to
          NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order
          on entry, NMIN is the number of frequency-weighted Hankel
          singular values greater than NS*EPS*S1, EPS is the
          machine precision (see LAPACK Library Routine DLAMCH)
          and S1 is the largest Hankel singular value (computed
          in HSV(1)); NR can be further reduced to ensure
          HSV(NR-NU) > HSV(NR+1-NU);
          if ORDSEL = 'A', NR is the sum of NU and the number of
          Hankel singular values greater than MAX(TOL1,NS*EPS*S1).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  ALPHAC  (input) DOUBLE PRECISION
          Combination method parameter for defining the
          frequency-weighted controllability Grammian (see METHOD);
          ABS(ALPHAC) <= 1.

  ALPHAO  (input) DOUBLE PRECISION
          Combination method parameter for defining the
          frequency-weighted observability Grammian (see METHOD);
          ABS(ALPHAO) <= 1.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system.
          The resulting A has a block-diagonal form with two blocks.
          For a system with NU ALPHA-unstable eigenvalues and
          NS ALPHA-stable eigenvalues (NU+NS = N), the leading
          NU-by-NU block contains the unreduced part of A
          corresponding to ALPHA-unstable eigenvalues.
          The trailing (NR+NS-N)-by-(NR+NS-N) block contains
          the reduced part of A corresponding to ALPHA-stable
          eigenvalues.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  AV      (input/output) DOUBLE PRECISION array, dimension (LDAV,NV)
          On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV
          part of this array must contain the state matrix AV of
          the system with the transfer-function matrix V.
          On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and
          INFO = 0, the leading NVR-by-NVR part of this array
          contains the state matrix of a minimal realization of V
          in a real Schur form. NVR is returned in IWORK(2).
          AV is not referenced if WEIGHT = 'R' or 'N',
          or MIN(N,M,P) = 0.

  LDAV    INTEGER
          The leading dimension of array AV.
          LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDAV >= 1,         if WEIGHT = 'R' or 'N'.

  BV      (input/output) DOUBLE PRECISION array, dimension (LDBV,P)
          On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part
          of this array must contain the input matrix BV of the
          system with the transfer-function matrix V.
          On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and
          INFO = 0, the leading NVR-by-P part of this array contains
          the input matrix of a minimal realization of V.
          BV is not referenced if WEIGHT = 'R' or 'N',
          or MIN(N,M,P) = 0.

  LDBV    INTEGER
          The leading dimension of array BV.
          LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDBV >= 1,         if WEIGHT = 'R' or 'N'.

  CV      (input/output) DOUBLE PRECISION array, dimension (LDCV,NV)
          On entry, if WEIGHT = 'L' or 'B', the leading PV-by-NV
          part of this array must contain the output matrix CV of
          the system with the transfer-function matrix V.
          On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and
          INFO = 0, the leading PV-by-NVR part of this array
          contains the output matrix of a minimal realization of V.
          CV is not referenced if WEIGHT = 'R' or 'N',
          or MIN(N,M,P) = 0.

  LDCV    INTEGER
          The leading dimension of array CV.
          LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B';
          LDCV >= 1,         if WEIGHT = 'R' or 'N'.

  DV      (input) DOUBLE PRECISION array, dimension (LDDV,P)
          If WEIGHT = 'L' or 'B', the leading PV-by-P part of this
          array must contain the feedthrough matrix DV of the system
          with the transfer-function matrix V.
          DV is not referenced if WEIGHT = 'R' or 'N',
          or MIN(N,M,P) = 0.

  LDDV    INTEGER
          The leading dimension of array DV.
          LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B';
          LDDV >= 1,         if WEIGHT = 'R' or 'N'.

  AW      (input/output) DOUBLE PRECISION array, dimension (LDAW,NW)
          On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW
          part of this array must contain the state matrix AW of
          the system with the transfer-function matrix W.
          On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and
          INFO = 0, the leading NWR-by-NWR part of this array
          contains the state matrix of a minimal realization of W
          in a real Schur form. NWR is returned in IWORK(3).
          AW is not referenced if WEIGHT = 'L' or 'N',
          or MIN(N,M,P) = 0.

  LDAW    INTEGER
          The leading dimension of array AW.
          LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDAW >= 1,         if WEIGHT = 'L' or 'N'.

  BW      (input/output) DOUBLE PRECISION array, dimension (LDBW,MW)
          On entry, if WEIGHT = 'R' or 'B', the leading NW-by-MW
          part of this array must contain the input matrix BW of the
          system with the transfer-function matrix W.
          On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and
          INFO = 0, the leading NWR-by-MW part of this array
          contains the input matrix of a minimal realization of W.
          BW is not referenced if WEIGHT = 'L' or 'N',
          or MIN(N,M,P) = 0.

  LDBW    INTEGER
          The leading dimension of array BW.
          LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDBW >= 1,         if WEIGHT = 'L' or 'N'.

  CW      (input/output) DOUBLE PRECISION array, dimension (LDCW,NW)
          On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part
          of this array must contain the output matrix CW of the
          system with the transfer-function matrix W.
          On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and
          INFO = 0, the leading M-by-NWR part of this array contains
          the output matrix of a minimal realization of W.
          CW is not referenced if WEIGHT = 'L' or 'N',
          or MIN(N,M,P) = 0.

  LDCW    INTEGER
          The leading dimension of array CW.
          LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDCW >= 1,        if WEIGHT = 'L' or 'N'.

  DW      (input) DOUBLE PRECISION array, dimension (LDDW,MW)
          If WEIGHT = 'R' or 'B', the leading M-by-MW part of this
          array must contain the feedthrough matrix DW of the system
          with the transfer-function matrix W.
          DW is not referenced if WEIGHT = 'L' or 'N',
          or MIN(N,M,P) = 0.

  LDDW    INTEGER
          The leading dimension of array DW.
          LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDDW >= 1,        if WEIGHT = 'L' or 'N'.

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of this array contain
          the frequency-weighted Hankel singular values, ordered
          decreasingly, of the ALPHA-stable part of the original
          system.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*S1, where c is a constant in the
          interval [0.00001,0.001], and S1 is the largest
          frequency-weighted Hankel singular value of the
          ALPHA-stable part of the original system (computed
          in HSV(1)).
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = NS*EPS*S1, where NS is the number of
          ALPHA-stable eigenvalues of A and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the ALPHA-stable part of the given system.
          The recommended value is TOL2 = NS*EPS*S1.
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension
          ( MAX( 3, LIWRK1, LIWRK2, LIWRK3 ) ), where
          LIWRK1 = 0,             if JOB = 'B';
          LIWRK1 = N,             if JOB = 'F';
          LIWRK1 = 2*N,           if JOB = 'S' or 'P';
          LIWRK2 = 0,             if WEIGHT = 'R' or 'N' or  NV = 0;
          LIWRK2 = NV+MAX(P,PV),  if WEIGHT = 'L' or 'B' and NV > 0;
          LIWRK3 = 0,             if WEIGHT = 'L' or 'N' or  NW = 0;
          LIWRK3 = NW+MAX(M,MW),  if WEIGHT = 'R' or 'B' and NW > 0.
          On exit, if INFO = 0, IWORK(1) contains the order of a
          minimal realization of the stable part of the system,
          IWORK(2) and IWORK(3) contain the actual orders
          of the state space realizations of V and W, respectively.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( LMINL, LMINR, LRCF,
                         2*N*N + MAX( 1, LLEFT, LRIGHT, 2*N*N+5*N,
                                      N*MAX(M,P) ) ),
          where
          LMINL  = 0, if WEIGHT = 'R' or 'N' or NV = 0; otherwise,
          LMINL  = MAX(LLCF,NV+MAX(NV,3*P))           if P =  PV;
          LMINL  = MAX(P,PV)*(2*NV+MAX(P,PV))+
                   MAX(LLCF,NV+MAX(NV,3*P,3*PV))      if P <> PV;
          LRCF   = 0, and
          LMINR  = 0, if WEIGHT = 'L' or 'N' or NW = 0; otherwise,
          LMINR  = NW+MAX(NW,3*M)                     if M =  MW;
          LMINR  = 2*NW*MAX(M,MW)+NW+MAX(NW,3*M,3*MW) if M <> MW;
          LLCF   = PV*(NV+PV)+PV*NV+MAX(NV*(NV+5), PV*(PV+2),
                                        4*PV, 4*P);
          LRCF   = MW*(NW+MW)+MAX(NW*(NW+5),MW*(MW+2),4*MW,4*M)
          LLEFT  = (N+NV)*(N+NV+MAX(N+NV,PV)+5)
                           if WEIGHT = 'L' or 'B' and PV > 0;
          LLEFT  = N*(P+5) if WEIGHT = 'R' or 'N' or  PV = 0;
          LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5)
                           if WEIGHT = 'R' or 'B' and MW > 0;
          LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or  MW = 0.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                system; in this case, the resulting NR is set equal
                to NSMIN;
          = 2:  with ORDSEL = 'F', the selected order NR corresponds
                to repeated singular values for the ALPHA-stable
                part, which are neither all included nor all
                excluded from the reduced model; in this case, the
                resulting NR is automatically decreased to exclude
                all repeated singular values;
          = 3:  with ORDSEL = 'F', the selected order NR is less
                than the order of the ALPHA-unstable part of the
                given system; in this case NR is set equal to the
                order of the ALPHA-unstable part.
          = 10+K:  K violations of the numerical stability condition
                occured during the assignment of eigenvalues in the
                SLICOT Library routines SB08CD and/or SB08DD.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the computation of the ordered real Schur form of A
                failed;
          = 2:  the separation of the ALPHA-stable/unstable
                diagonal blocks failed because of very close
                eigenvalues;
          = 3:  the reduction to a real Schur form of the state
                matrix of a minimal realization of V failed;
          = 4:  a failure was detected during the ordering of the
                real Schur form of the state matrix of a minimal
                realization of V or in the iterative process to
                compute a left coprime factorization with inner
                denominator;
          = 5:  if DICO = 'C' and the matrix AV has an observable
                eigenvalue on the imaginary axis, or DICO = 'D' and
                AV has an observable eigenvalue on the unit circle;
          = 6:  the reduction to a real Schur form of the state
                matrix of a minimal realization of W failed;
          = 7:  a failure was detected during the ordering of the
                real Schur form of the state matrix of a minimal
                realization of W or in the iterative process to
                compute a right coprime factorization with inner
                denominator;
          = 8:  if DICO = 'C' and the matrix AW has a controllable
                eigenvalue on the imaginary axis, or DICO = 'D' and
                AW has a controllable eigenvalue on the unit circle;
          = 9:  the computation of eigenvalues failed;
          = 10: the computation of Hankel singular values failed.
Method 
  Let G be the transfer-function matrix of the original
  linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                          (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09ID determines
  the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t),                      (2)

  such that the corresponding transfer-function matrix Gr minimizes
  the norm of the frequency-weighted error

          V*(G-Gr)*W,                                    (3)

  where V and W are transfer-function matrices without poles on the
  imaginary axis in continuous-time case or on the unit circle in
  discrete-time case.

  The following procedure is used to reduce G:

  1) Decompose additively G, of order N, as

       G = G1 + G2,

     such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and
     G2 = (A2,B2,C2,0), of order NU, has only ALPHA-unstable poles.

  2) Compute for G1 a B&T or SPA frequency-weighted approximation
     G1r of order NR-NU using the combination method or the
     modified combination method of [4].

  3) Assemble the reduced model Gr as

        Gr = G1r + G2.

  For the frequency-weighted reduction of the ALPHA-stable part,
  several methods described in [4] can be employed in conjunction
  with the combination method and modified combination method
  proposed in [4].

  If JOB = 'B', the square-root B&T method is used.
  If JOB = 'F', the balancing-free square-root version of the
  B&T method is used.
  If JOB = 'S', the square-root version of the SPA method is used.
  If JOB = 'P', the balancing-free square-root version of the
  SPA method is used.

  For each of these methods, left and right truncation matrices
  are determined using the Cholesky factors of an input
  frequency-weighted controllability Grammian P and an output
  frequency-weighted observability Grammian Q.
  P and Q are computed from the controllability Grammian Pi of G*W
  and the observability Grammian Qo of V*G. Using special
  realizations of G*W and V*G, Pi and Qo are computed in the
  partitioned forms

        Pi = ( P11  P12 )   and    Qo = ( Q11  Q12 ) ,
             ( P12' P22 )               ( Q12' Q22 )

  where P11 and Q11 are the leading N-by-N parts of Pi and Qo,
  respectively. Let P0 and Q0 be non-negative definite matrices
  defined below
                                     -1
         P0 = P11 - ALPHAC**2*P12*P22 *P21 ,
                                     -1
         Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21.

  The frequency-weighted controllability and observability
  Grammians, P and Q, respectively, are defined as follows:
  P = P0 if JOBC = 'S' (standard combination method [4]);
  P = P1 >= P0 if JOBC = 'E', where P1 is the controllability
  Grammian defined to enforce stability for a modified combination
  method of [4];
  Q = Q0 if JOBO = 'S' (standard combination method [4]);
  Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability
  Grammian defined to enforce stability for a modified combination
  method of [4].

  If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of
  Grammians corresponds to the method of Enns [1], while if
  ALPHAC = ALPHAO = 1, the choice of Grammians corresponds
  to the method of Lin and Chiu [2,3].

  If JOBC = 'S' and ALPHAC = 1, no pole-zero cancellations must
  occur in G*W. If JOBO = 'S' and ALPHAO = 1, no pole-zero
  cancellations must occur in V*G. The presence of pole-zero
  cancellations leads to meaningless results and must be avoided.

  The frequency-weighted Hankel singular values HSV(1), ....,
  HSV(N) are computed as the square roots of the eigenvalues
  of the product P*Q.
References 
  [1] Enns, D.
      Model reduction with balanced realizations: An error bound
      and a frequency weighted generalization.
      Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984.

  [2] Lin, C.-A. and Chiu, T.-Y.
      Model reduction via frequency-weighted balanced realization.
      Control Theory and Advanced Technology, vol. 8,
      pp. 341-351, 1992.

  [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G.
      New results on frequency weighted balanced reduction
      technique.
      Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995.

  [4] Varga, A. and Anderson, B.D.O.
      Square-root balancing-free methods for the frequency-weighted
      balancing related model reduction.
      (report in preparation)
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root
  techniques.
Further Comments 
  None
Example

Program Text 

*     AB09ID EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, MWMAX, NMAX, NVMAX, NWMAX, PMAX, PVMAX
      PARAMETER        ( MMAX = 20, MWMAX = 20,
     $                   NMAX = 20, NVMAX = 20, NWMAX = 20,
     $                   PMAX = 20, PVMAX = 20 )
      INTEGER          LDA, LDAV, LDAW, LDB, LDBV, LDBW,
     $                 LDC, LDCV, LDCW, LDD, LDDV, LDDW
      PARAMETER        ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX,
     $                   LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX,
     $                   LDC = PMAX, LDCV = PVMAX, LDCW = MMAX,
     $                   LDD = PMAX, LDDV = PVMAX, LDDW = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX,
     $                                 NVMAX + MAX( PMAX, PVMAX ),
     $                                 NWMAX + MAX( MMAX, MWMAX ) ) )
      INTEGER          LDW1, LDW2, LDW3, LDW4, LDW5, LDW6, LDW7, LDW8,
     $                 LDWORK
      PARAMETER        ( LDW1 = NMAX + NVMAX, LDW2 = NMAX + NWMAX,
     $                   LDW3 = MAX( LDW1*( LDW1 + MAX( LDW1, PVMAX ) +
     $                               5 ), NMAX*( PMAX + 5 ) ),
     $                   LDW4 = MAX( LDW2*( LDW2 + MAX( LDW2, MWMAX ) +
     $                               5 ), NMAX*( MMAX + 5 ) ),
     $                   LDW5 = PVMAX*( NVMAX + PVMAX ) + PVMAX*NVMAX +
     $                          MAX( NVMAX*( NVMAX + 5 ), 4*PVMAX,
     $                               PVMAX*( PVMAX + 2 ), 4*PMAX ),
     $                   LDW6 = MAX( PMAX, PVMAX )*( 2*NVMAX +
     $                               MAX( PMAX, PVMAX ) ) +
     $                               MAX( LDW5, NVMAX +
     $                                    MAX( NVMAX, 3*PMAX, 3*PVMAX )
     $                                       ),
     $                   LDW7 = MAX( NWMAX + MAX( NWMAX, 3*MMAX ),
     $                               2*NWMAX*MAX( MMAX, MWMAX ) +
     $                               NWMAX + MAX( NWMAX, 3*MMAX,
     $                                                   3*MWMAX ) ),
     $                   LDW8 = MWMAX*( NWMAX + MWMAX ) +
     $                          MAX( NWMAX*( NWMAX + 5 ), 4*MWMAX,
     $                               MWMAX*( MWMAX + 2 ), 4*MMAX ) )
      PARAMETER        ( LDWORK = MAX( LDW6, LDW7, LDW8,
     $                                 2*NMAX*NMAX +
     $                                   MAX( 1, LDW3, LDW4,
     $                                        2*NMAX*NMAX + 5*NMAX,
     $                                        NMAX*MAX( MMAX, PMAX ) ) )
     $                  )
*     .. Local Scalars ..
      LOGICAL          LEFTW, RIGHTW
      DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, MW, N, NR, NS, NV, NW, P,
     $                 PV
      CHARACTER*1      DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX),
     $                 B(LDB,MMAX), BV(LDBV,PMAX),  BW(LDBW,MWMAX),
     $                 C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX),
     $                 D(LDD,MMAX), DV(LDDV,PMAX),  DW(LDDW,MWMAX),
     $                 DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB09ID
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NV, PV, NW, MW, NR,
     $                      ALPHA, ALPHAC, ALPHAO, TOL1, TOL2,
     $                      DICO, JOBC, JOBO, JOB, WEIGHT,
     $                      EQUIL, ORDSEL
      LEFTW  = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' )
      RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' )
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               IF( LEFTW ) THEN
                  IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN
                     WRITE ( NOUT, FMT = 99986 ) NV
                  ELSE
                     IF( NV.GT.0 ) THEN
                        READ ( NIN, FMT = * )
     $                    ( ( AV(I,J), J = 1,NV ), I = 1,NV )
                        READ ( NIN, FMT = * )
     $                    ( ( BV(I,J), J = 1,P ),  I = 1,NV )
                        IF( PV.LE.0 .OR. PV.GT.PVMAX ) THEN
                           WRITE ( NOUT, FMT = 99985 ) PV
                        ELSE
                           READ ( NIN, FMT = * )
     $                       ( ( CV(I,J), J = 1,NV ), I = 1,PV )
                        END IF
                     END IF
                     IF( PV.LE.0 .OR. PV.GT.PVMAX ) THEN
                        WRITE ( NOUT, FMT = 99985 ) PV
                     ELSE
                        READ ( NIN, FMT = * )
     $                    ( ( DV(I,J), J = 1,P ), I = 1,PV )
                     END IF
                  END IF
               END IF
               IF( RIGHTW ) THEN
                  IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN
                     WRITE ( NOUT, FMT = 99984 ) NW
                  ELSE
                     IF( NW.GT.0 ) THEN
                        READ ( NIN, FMT = * )
     $                    ( ( AW(I,J), J = 1,NW ), I = 1,NW )
                        IF( MW.LE.0 .OR. MW.GT.MWMAX ) THEN
                           WRITE ( NOUT, FMT = 99983 ) MW
                        ELSE
                           READ ( NIN, FMT = * )
     $                       ( ( BW(I,J), J = 1,MW ), I = 1,NW )
                        END IF
                        READ ( NIN, FMT = * )
     $                    ( ( CW(I,J), J = 1,NW ), I = 1,M )
                     END IF
                     IF( MW.LE.0 .OR. MW.GT.MWMAX ) THEN
                        WRITE ( NOUT, FMT = 99983 ) MW
                     ELSE
                        READ ( NIN, FMT = * )
     $                     ( ( DW(I,J), J = 1,MW ), I = 1,M )
                     END IF
                  END IF
               END IF
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99982 ) IWARN
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09ID EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09ID = ',I2)
99997 FORMAT (/' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable',
     $         ' part are')
99986 FORMAT (/' NV is out of range.',/' NV = ',I5)
99985 FORMAT (/' PV is out of range.',/' PV = ',I5)
99984 FORMAT (/' NW is out of range.',/' NW = ',I5)
99983 FORMAT (/' MW is out of range.',/' MW = ',I5)
99982 FORMAT (' IWARN on exit from AB09ID = ',I2)
      END
Program Data 
 AB09ID EXAMPLE PROGRAM DATA (Continuous system)
  3  1  1   6  1  0  0   2   0.0  0.0  0.0 0.1E0  0.0    C   S  S   F   L  S  F 
  -26.4000    6.4023    4.3868
   32.0000         0         0
         0    8.0000         0
    16
     0
     0
    9.2994    1.1624    0.1090
     0
   -1.0000         0    4.0000   -9.2994   -1.1624   -0.1090
         0    2.0000         0   -9.2994   -1.1624   -0.1090
         0         0   -3.0000   -9.2994   -1.1624   -0.1090
   16.0000   16.0000   16.0000  -26.4000    6.4023    4.3868
         0         0         0   32.0000         0         0
         0         0         0         0    8.0000         0
     1
     1
     1
     0
     0
     0
     1     1     1     0     0     0
     0
Program Results 
 AB09ID EXAMPLE PROGRAM RESULTS


 The order of reduced model =  2

 The Hankel singular values of weighted ALPHA-stable part are
   3.8253   0.2005

 The reduced state dynamics matrix Ar is 
   9.1900   0.0000
   0.0000 -34.5297

 The reduced input/state matrix Br is 
  11.9593
  16.9329

 The reduced state/output matrix Cr is 
   2.8955   6.9152

 The reduced input/output matrix Dr is 
   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09IX.html000077500000000000000000000325471201767322700161130ustar00rootroot00000000000000 AB09IX - SLICOT Library Routine Documentation

AB09IX

Accuracy enhanced balancing related model reduction

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using the square-root or
  balancing-free square-root Balance & Truncate (B&T) or
  Singular Perturbation Approximation (SPA) model reduction methods.
  The computation of truncation matrices TI and T is based on
  the Cholesky factor S of a controllability Grammian P = S*S'
  and the Cholesky factor R of an observability Grammian Q = R'*R,
  where S and R are given upper triangular matrices.

  For the B&T approach, the matrices of the reduced order system
  are computed using the truncation formulas:

       Ar = TI * A * T ,  Br = TI * B ,  Cr = C * T .     (1)

  For the SPA approach, the matrices of a minimal realization
  (Am,Bm,Cm) are computed using the truncation formulas:

       Am = TI * A * T ,  Bm = TI * B ,  Cm = C * T .     (2)

  Am, Bm, Cm and D serve further for computing the SPA of the given
  system.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root B&T method;
          = 'F':  use the balancing-free square-root B&T method;
          = 'S':  use the square-root SPA method;
          = 'P':  use the balancing-free square-root SPA method.

  FACT    CHARACTER*1
          Specifies whether or not, on entry, the matrix A is in a
          real Schur form, as follows:
          = 'S':  A is in a real Schur form;
          = 'N':  A is a general dense square matrix.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e., the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. NR is set as follows:
          if ORDSEL = 'F', NR is equal to MIN(NR,NMINR), where NR
          is the desired order on entry and NMINR is the number of
          the Hankel singular values greater than N*EPS*S1, where
          EPS is the machine precision (see LAPACK Library Routine
          DLAMCH) and S1 is the largest Hankel singular value
          (computed in HSV(1));
          NR can be further reduced to ensure HSV(NR) > HSV(NR+1);
          if ORDSEL = 'A', NR is equal to the number of Hankel
          singular values greater than MAX(TOL1,N*EPS*S1).

  SCALEC  (input) DOUBLE PRECISION
          Scaling factor for the Cholesky factor S of the
          controllability Grammian, i.e., S/SCALEC is used to
          compute the Hankel singular values.  SCALEC > 0.

  SCALEO  (input) DOUBLE PRECISION
          Scaling factor for the Cholesky factor R of the
          observability Grammian, i.e., R/SCALEO is used to
          compute the Hankel singular values.  SCALEO > 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A. If FACT = 'S',
          A is in a real Schur form.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, if JOB = 'S' or JOB = 'P', the leading P-by-M
          part of this array must contain the original input/output
          matrix D.
          On exit, if INFO = 0 and JOB = 'S' or JOB = 'P', the
          leading P-by-M part of this array contains the
          input/output matrix Dr of the reduced order system.
          If JOB = 'B' or JOB = 'F', this array is not referenced.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= 1,        if JOB = 'B' or JOB = 'F';
          LDD >= MAX(1,P), if JOB = 'S' or JOB = 'P'.

  TI      (input/output) DOUBLE PRECISION array, dimension (LDTI,N)
          On entry, the leading N-by-N upper triangular part of
          this array must contain the Cholesky factor S of a
          controllability Grammian P = S*S'.
          On exit, if INFO = 0, and NR > 0, the leading NMINR-by-N
          part of this array contains the left truncation matrix
          TI in (1), for the B&T approach, or in (2), for the
          SPA approach.

  LDTI    INTEGER
          The leading dimension of array TI.  LDTI >= MAX(1,N).

  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
          On entry, the leading N-by-N upper triangular part of
          this array must contain the Cholesky factor R of an
          observability Grammian Q = R'*R.
          On exit, if INFO = 0, and NR > 0, the leading N-by-NMINR
          part of this array contains the right truncation matrix
          T in (1), for the B&T approach, or in (2), for the
          SPA approach.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  NMINR   (output) INTEGER
          The number of Hankel singular values greater than
          MAX(TOL2,N*EPS*S1).
          Note: If S and R are the Cholesky factors of the
          controllability and observability Grammians of the
          original system (A,B,C,D), respectively, then NMINR is
          the order of a minimal realization of the original system.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the Hankel singular values,
          ordered decreasingly. The Hankel singular values are
          singular values of the product R*S.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of the reduced system.
          For model reduction, the recommended value lies in the
          interval [0.00001,0.001].
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = N*EPS*S1, where EPS is the machine precision
          (see LAPACK Library Routine DLAMCH) and S1 is the largest
          Hankel singular value (computed in HSV(1)).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the system.
          The recommended value is TOL2 = N*EPS*S1.
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0, and ORDSEL = 'A', then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension LIWORK, where
          LIWORK = 0,   if JOB = 'B';
          LIWORK = N,   if JOB = 'F';
          LIWORK = 2*N, if JOB = 'S' or 'P'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, 2*N*N + 5*N, N*MAX(M,P) ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NMINR, the order of a minimal realization of
                the given system; in this case, the resulting NR is
                set automatically to NMINR;
          = 2:  with ORDSEL = 'F', the selected order NR corresponds
                to repeated singular values, which are neither all
                included nor all excluded from the reduced model;
                in this case, the resulting NR is set automatically
                to the largest value such that HSV(NR) > HSV(NR+1).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the computation of Hankel singular values failed.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                             (3)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09IX determines for
  the given system (3), the matrices of a reduced NR order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t),                         (4)

  by using the square-root or balancing-free square-root
  Balance & Truncate (B&T) or Singular Perturbation Approximation
  (SPA) model reduction methods.

  The projection matrices TI and T are determined using the
  Cholesky factors S and R of a controllability Grammian P and an
  observability Grammian Q.
  The Hankel singular values HSV(1), ...., HSV(N) are computed as
  singular values of the product R*S.

  If JOB = 'B', the square-root Balance & Truncate technique
  of [1] is used.

  If JOB = 'F', the balancing-free square-root version of the
  Balance & Truncate technique [2] is used.

  If JOB = 'S', the square-root version of the Singular Perturbation
  Approximation method [3,4] is used.

  If JOB = 'P', the balancing-free square-root version of the
  Singular Perturbation Approximation method [3,4] is used.
References 
  [1] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [2] Varga A.
      Efficient minimal realization procedure based on balancing.
      Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
      A. El Moudni, P. Borne, S. G. Tzafestas (Eds.),
      Vol. 2, pp. 42-46.

  [3] Liu Y. and Anderson B.D.O.
      Singular Perturbation Approximation of balanced systems.
      Int. J. Control, Vol. 50, pp. 1379-1405, 1989.

  [4] Varga A.
      Balancing-free square-root algorithm for computing singular
      perturbation approximations.
      Proc. 30-th CDC, Brighton, Dec. 11-13, 1991,
      Vol. 2, pp. 1062-1065.
Numerical Aspects 
  The implemented method relies on accuracy enhancing square-root
  or balancing-free square-root methods.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09IY.html000077500000000000000000000372351201767322700161130ustar00rootroot00000000000000 AB09IY - SLICOT Library Routine Documentation

AB09IY

Cholesky factors of the frequency-weighted controllability and observability Grammians

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute for given state-space representations
  (A,B,C,0), (AV,BV,CV,DV), and (AW,BW,CW,DW) of the
  transfer-function matrices G, V and W, respectively,
  the Cholesky factors of the frequency-weighted
  controllability and observability Grammians corresponding
  to a frequency-weighted model reduction problem.
  G, V and W must be stable transfer-function matrices with
  the state matrices A, AV, and AW in real Schur form.
  It is assumed that the state space realizations (AV,BV,CV,DV)
  and (AW,BW,CW,DW) are minimal. In case of possible pole-zero
  cancellations in forming V*G and/or G*W, the parameters for the
  choice of frequency-weighted Grammians ALPHAO and/or ALPHAC,
  respectively, must be different from 1.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the systems as follows:
          = 'C':  G, V and W are continuous-time systems;
          = 'D':  G, V and W are discrete-time systems.

  JOBC    CHARACTER*1
          Specifies the choice of frequency-weighted controllability
          Grammian as follows:
          = 'S': choice corresponding to a combination method [4]
                 of the approaches of Enns [1] and Lin-Chiu [2,3];
          = 'E': choice corresponding to the stability enhanced
                 modified combination method of [4].

  JOBO    CHARACTER*1
          Specifies the choice of frequency-weighted observability
          Grammian as follows:
          = 'S': choice corresponding to a combination method [4]
                 of the approaches of Enns [1] and Lin-Chiu [2,3];
          = 'E': choice corresponding to the stability enhanced
                 modified combination method of [4].

  WEIGHT  CHARACTER*1
          Specifies the type of frequency weighting, as follows:
          = 'N':  no weightings are used (V = I, W = I);
          = 'L':  only left weighting V is used (W = I);
          = 'R':  only right weighting W is used (V = I);
          = 'B':  both left and right weightings V and W are used.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation of G, i.e.,
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrix B and
          the number of rows of the matrices CW and DW.  M >= 0.
          M represents the dimension of the input vector of the
          system with the transfer-function matrix G and
          also the dimension of the output vector of the system
          with the transfer-function matrix W.

  P       (input) INTEGER
          The number of rows of the matrix C and the
          number of columns of the matrices BV and DV.  P >= 0.
          P represents the dimension of the output vector of the
          system with the transfer-function matrix G and
          also the dimension of the input vector of the system
          with the transfer-function matrix V.

  NV      (input) INTEGER
          The order of the matrix AV. Also the number of rows of
          the matrix BV and the number of columns of the matrix CV.
          NV represents the dimension of the state vector of the
          system with the transfer-function matrix V.  NV >= 0.

  PV      (input) INTEGER
          The number of rows of the matrices CV and DV.  PV >= 0.
          PV represents the dimension of the output vector of the
          system with the transfer-function matrix V.

  NW      (input) INTEGER
          The order of the matrix AW. Also the number of rows of
          the matrix BW and the number of columns of the matrix CW.
          NW represents the dimension of the state vector of the
          system with the transfer-function matrix W.  NW >= 0.

  MW      (input) INTEGER
          The number of columns of the matrices BW and DW.  MW >= 0.
          MW represents the dimension of the input vector of the
          system with the transfer-function matrix W.

  ALPHAC  (input) DOUBLE PRECISION
          Combination method parameter for defining the
          frequency-weighted controllability Grammian (see METHOD);
          ABS(ALPHAC) <= 1.

  ALPHAO  (input) DOUBLE PRECISION
          Combination method parameter for defining the
          frequency-weighted observability Grammian (see METHOD);
          ABS(ALPHAO) <= 1.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must
          contain the state matrix A (of the system with the
          transfer-function matrix G) in a real Schur form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  AV      (input) DOUBLE PRECISION array, dimension (LDAV,NV)
          If WEIGHT = 'L' or 'B', the leading NV-by-NV part of this
          array must contain the state matrix AV (of the system with
          the transfer-function matrix V) in a real Schur form.
          AV is not referenced if WEIGHT = 'R' or 'N'.

  LDAV    INTEGER
          The leading dimension of array AV.
          LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDAV >= 1,         if WEIGHT = 'R' or 'N'.

  BV      (input) DOUBLE PRECISION array, dimension (LDBV,P)
          If WEIGHT = 'L' or 'B', the leading NV-by-P part of this
          array must contain the input matrix BV of the system with
          the transfer-function matrix V.
          BV is not referenced if WEIGHT = 'R' or 'N'.

  LDBV    INTEGER
          The leading dimension of array BV.
          LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDBV >= 1,         if WEIGHT = 'R' or 'N'.

  CV      (input) DOUBLE PRECISION array, dimension (LDCV,NV)
          If WEIGHT = 'L' or 'B', the leading PV-by-NV part of this
          array must contain the output matrix CV of the system with
          the transfer-function matrix V.
          CV is not referenced if WEIGHT = 'R' or 'N'.

  LDCV    INTEGER
          The leading dimension of array CV.
          LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B';
          LDCV >= 1,         if WEIGHT = 'R' or 'N'.

  DV      (input) DOUBLE PRECISION array, dimension (LDDV,P)
          If WEIGHT = 'L' or 'B', the leading PV-by-P part of this
          array must contain the feedthrough matrix DV of the system
          with the transfer-function matrix V.
          DV is not referenced if WEIGHT = 'R' or 'N'.

  LDDV    INTEGER
          The leading dimension of array DV.
          LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B';
          LDDV >= 1,         if WEIGHT = 'R' or 'N'.

  AW      (input) DOUBLE PRECISION array, dimension (LDAW,NW)
          If WEIGHT = 'R' or 'B', the leading NW-by-NW part of this
          array must contain the state matrix AW (of the system with
          the transfer-function matrix W) in a real Schur form.
          AW is not referenced if WEIGHT = 'L' or 'N'.

  LDAW    INTEGER
          The leading dimension of array AW.
          LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDAW >= 1,         if WEIGHT = 'L' or 'N'.

  BW      (input) DOUBLE PRECISION array, dimension (LDBW,MW)
          If WEIGHT = 'R' or 'B', the leading NW-by-MW part of this
          array must contain the input matrix BW of the system with
          the transfer-function matrix W.
          BW is not referenced if WEIGHT = 'L' or 'N'.

  LDBW    INTEGER
          The leading dimension of array BW.
          LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDBW >= 1,         if WEIGHT = 'L' or 'N'.

  CW      (input) DOUBLE PRECISION array, dimension (LDCW,NW)
          If WEIGHT = 'R' or 'B', the leading M-by-NW part of this
          array must contain the output matrix CW of the system with
          the transfer-function matrix W.
          CW is not referenced if WEIGHT = 'L' or 'N'.

  LDCW    INTEGER
          The leading dimension of array CW.
          LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDCW >= 1,        if WEIGHT = 'L' or 'N'.

  DW      (input) DOUBLE PRECISION array, dimension (LDDW,MW)
          If WEIGHT = 'R' or 'B', the leading M-by-MW part of this
          array must contain the feedthrough matrix DW of the system
          with the transfer-function matrix W.
          DW is not referenced if WEIGHT = 'L' or 'N'.

  LDDW    INTEGER
          The leading dimension of array DW.
          LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDDW >= 1,        if WEIGHT = 'L' or 'N'.

  SCALEC  (output) DOUBLE PRECISION
          Scaling factor for the controllability Grammian in (1)
          or (3). See METHOD.

  SCALEO  (output) DOUBLE PRECISION
          Scaling factor for the observability Grammian in (2)
          or (4). See METHOD.

  S       (output) DOUBLE PRECISION array, dimension (LDS,N)
          The leading N-by-N upper triangular part of this array
          contains the Cholesky factor S of the frequency-weighted
          cotrollability Grammian P = S*S'. See METHOD.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,N).

  R       (output) DOUBLE PRECISION array, dimension (LDR,N)
          The leading N-by-N upper triangular part of this array
          contains the Cholesky factor R of the frequency-weighted
          observability Grammian Q = R'*R. See METHOD.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, LLEFT, LRIGHT ),
          where
          LLEFT  = (N+NV)*(N+NV+MAX(N+NV,PV)+5)
                           if WEIGHT = 'L' or 'B' and PV > 0;
          LLEFT  = N*(P+5) if WEIGHT = 'R' or 'N' or  PV = 0;
          LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5)
                           if WEIGHT = 'R' or 'B' and MW > 0;
          LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or  MW = 0.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the state matrices A and/or AV are not stable or
                not in a real Schur form;
          = 2:  if the state matrices A and/or AW are not stable or
                not in a real Schur form;
          = 3:  eigenvalues computation failure.
Method 
  Let Pi = Si*Si' and Qo = Ro'*Ro be the Cholesky factored
  controllability and observability Grammians satisfying
  in the continuous-time case

         Ai*Pi + Pi*Ai' +  scalec^2*Bi*Bi' = 0,       (1)

         Ao'*Qo + Qo*Ao +  scaleo^2*Co'*Co = 0,       (2)

  and in the discrete-time case

         Ai*Pi*Ai' - Pi +  scalec^2*Bi*Bi' = 0,       (3)

         Ao'*Qo*Ao - Qo +  scaleo^2*Co'*Co = 0,       (4)

  where

        Ai = ( A  B*Cw ) ,   Bi = ( B*Dw ) ,
             ( 0   Aw  )          (  Bw  )

        Ao = (  A   0  ) ,   Co = ( Dv*C  Cv ) .
             ( Bv*C Av )

  Consider the partitioned Grammians

        Pi = ( P11  P12 )   and    Qo = ( Q11  Q12 ) ,
             ( P12' P22 )               ( Q12' Q22 )

  where P11 and Q11 are the leading N-by-N parts of Pi and Qo,
  respectively, and let P0 and Q0 be non-negative definite matrices
  defined in the combination method [4]
                                     -1
         P0 = P11 - ALPHAC**2*P12*P22 *P21 ,
                                     -1
         Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21.

  The frequency-weighted controllability and observability
  Grammians, P and Q, respectively, are defined as follows:
  P = P0 if JOBC = 'S' (standard combination method [4]);
  P = P1 >= P0 if JOBC = 'E', where P1 is the controllability
  Grammian defined to enforce stability for a modified combination
  method of [4];
  Q = Q0 if JOBO = 'S' (standard combination method [4]);
  Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability
  Grammian defined to enforce stability for a modified combination
  method of [4].

  If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of
  Grammians corresponds to the method of Enns [1], while if
  ALPHAC = ALPHAO = 1, the choice of Grammians corresponds to the
  method of Lin and Chiu [2,3].

  The routine computes directly the Cholesky factors S and R
  such that P = S*S' and Q = R'*R according to formulas
  developed in [4]. No matrix inversions are involved.
References 
  [1] Enns, D.
      Model reduction with balanced realizations: An error bound
      and a frequency weighted generalization.
      Proc. CDC, Las Vegas, pp. 127-132, 1984.

  [2] Lin, C.-A. and Chiu, T.-Y.
      Model reduction via frequency-weighted balanced realization.
      Control Theory and Advanced Technology, vol. 8,
      pp. 341-351, 1992.

  [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G.
      New results on frequency weighted balanced reduction
      technique.
      Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995.

  [4] Varga, A. and Anderson, B.D.O.
      Square-root balancing-free methods for the frequency-weighted
      balancing related model reduction.
      (report in preparation)
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09JD.html000077500000000000000000001032631201767322700160620ustar00rootroot00000000000000 AB09JD - SLICOT Library Routine Documentation

AB09JD

Frequency-weighted Hankel norm approximation with invertible weights

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using the frequency
  weighted optimal Hankel-norm approximation method.
  The Hankel norm of the weighted error

        op(V)*(G-Gr)*op(W)

  is minimized, where G and Gr are the transfer-function matrices
  of the original and reduced systems, respectively, V and W are
  invertible transfer-function matrices representing the left and
  right frequency weights, and op(X) denotes X, inv(X), conj(X) or
  conj(inv(X)). V and W are specified by their state space
  realizations (AV,BV,CV,DV) and (AW,BW,CW,DW), respectively.
  When minimizing ||V*(G-Gr)*W||, V and W must be antistable.
  When minimizing inv(V)*(G-Gr)*inv(W), V and W must have only
  antistable zeros.
  When minimizing conj(V)*(G-Gr)*conj(W), V and W must be stable.
  When minimizing conj(inv(V))*(G-Gr)*conj(inv(W)), V and W must
  be minimum-phase.
  If the original system is unstable, then the frequency weighted
  Hankel-norm approximation is computed only for the
  ALPHA-stable part of the system.

  For a transfer-function matrix G, conj(G) denotes the conjugate
  of G given by G'(-s) for a continuous-time system or G'(1/z)
  for a discrete-time system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOBV    CHARACTER*1
          Specifies the left frequency-weighting as follows:
          = 'N':  V = I;
          = 'V':  op(V) = V;
          = 'I':  op(V) = inv(V);
          = 'C':  op(V) = conj(V);
          = 'R':  op(V) = conj(inv(V)).

  JOBW    CHARACTER*1
          Specifies the right frequency-weighting as follows:
          = 'N':  W = I;
          = 'W':  op(W) = W;
          = 'I':  op(W) = inv(W);
          = 'C':  op(W) = conj(W);
          = 'R':  op(W) = conj(inv(W)).

  JOBINV  CHARACTER*1
          Specifies the computational approach to be used as
          follows:
          = 'N':  use the inverse free descriptor system approach;
          = 'I':  use the inversion based standard approach;
          = 'A':  switch automatically to the inverse free
                  descriptor approach in case of badly conditioned
                  feedthrough matrices in V or W (see METHOD).

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e., the order of the matrix A.  N >= 0.

  NV      (input) INTEGER
          The order of the realization of the left frequency
          weighting V, i.e., the order of the matrix AV.  NV >= 0.

  NW      (input) INTEGER
          The order of the realization of the right frequency
          weighting W, i.e., the order of the matrix AW.  NW >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. For a system with NU ALPHA-unstable
          eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
          NR is set as follows: if ORDSEL = 'F', NR is equal to
          NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the
          multiplicity of the Hankel singular value HSV(NR-NU+1),
          NR is the desired order on entry, and NMIN is the order
          of a minimal realization of the ALPHA-stable part of the
          given system; NMIN is determined as the number of Hankel
          singular values greater than NS*EPS*HNORM(As,Bs,Cs), where
          EPS is the machine precision (see LAPACK Library Routine
          DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the
          ALPHA-stable part of the weighted system (computed in
          HSV(1));
          if ORDSEL = 'A', NR is the sum of NU and the number of
          Hankel singular values greater than
          MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system in a real Schur form.
          The resulting A has a block-diagonal form with two blocks.
          For a system with NU ALPHA-unstable eigenvalues and
          NS ALPHA-stable eigenvalues (NU+NS = N), the leading
          NU-by-NU block contains the unreduced part of A
          corresponding to ALPHA-unstable eigenvalues.
          The trailing (NR+NS-N)-by-(NR+NS-N) block contains
          the reduced part of A corresponding to ALPHA-stable
          eigenvalues.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  AV      (input/output) DOUBLE PRECISION array, dimension (LDAV,NV)
          On entry, if JOBV <> 'N', the leading NV-by-NV part of
          this array must contain the state matrix AV of a state
          space realization of the left frequency weighting V.
          On exit, if JOBV <> 'N', and INFO = 0, the leading
          NV-by-NV part of this array contains the real Schur form
          of AV.
          AV is not referenced if JOBV = 'N'.

  LDAV    INTEGER
          The leading dimension of the array AV.
          LDAV >= MAX(1,NV), if JOBV <> 'N';
          LDAV >= 1,         if JOBV =  'N'.

  BV      (input/output) DOUBLE PRECISION array, dimension (LDBV,P)
          On entry, if JOBV <> 'N', the leading NV-by-P part of
          this array must contain the input matrix BV of a state
          space realization of the left frequency weighting V.
          On exit, if JOBV <> 'N', and INFO = 0, the leading
          NV-by-P part of this array contains the transformed
          input matrix BV corresponding to the transformed AV.
          BV is not referenced if JOBV = 'N'.

  LDBV    INTEGER
          The leading dimension of the array BV.
          LDBV >= MAX(1,NV), if JOBV <> 'N';
          LDBV >= 1,         if JOBV =  'N'.

  CV      (input/output) DOUBLE PRECISION array, dimension (LDCV,NV)
          On entry, if JOBV <> 'N', the leading P-by-NV part of
          this array must contain the output matrix CV of a state
          space realization of the left frequency weighting V.
          On exit, if JOBV <> 'N', and INFO = 0, the leading
          P-by-NV part of this array contains the transformed output
          matrix CV corresponding to the transformed AV.
          CV is not referenced if JOBV = 'N'.

  LDCV    INTEGER
          The leading dimension of the array CV.
          LDCV >= MAX(1,P), if JOBV <> 'N';
          LDCV >= 1,        if JOBV =  'N'.

  DV      (input) DOUBLE PRECISION array, dimension (LDDV,P)
          If JOBV <> 'N', the leading P-by-P part of this array
          must contain the feedthrough matrix DV of a state space
          realization of the left frequency weighting V.
          DV is not referenced if JOBV = 'N'.

  LDDV    INTEGER
          The leading dimension of the array DV.
          LDDV >= MAX(1,P), if JOBV <> 'N';
          LDDV >= 1,        if JOBV =  'N'.

  AW      (input/output) DOUBLE PRECISION array, dimension (LDAW,NW)
          On entry, if JOBW <> 'N', the leading NW-by-NW part of
          this array must contain the state matrix AW of a state
          space realization of the right frequency weighting W.
          On exit, if JOBW <> 'N', and INFO = 0, the leading
          NW-by-NW part of this array contains the real Schur form
          of AW.
          AW is not referenced if JOBW = 'N'.

  LDAW    INTEGER
          The leading dimension of the array AW.
          LDAW >= MAX(1,NW), if JOBW <> 'N';
          LDAW >= 1,         if JOBW =  'N'.

  BW      (input/output) DOUBLE PRECISION array, dimension (LDBW,M)
          On entry, if JOBW <> 'N', the leading NW-by-M part of
          this array must contain the input matrix BW of a state
          space realization of the right frequency weighting W.
          On exit, if JOBW <> 'N', and INFO = 0, the leading
          NW-by-M part of this array contains the transformed
          input matrix BW corresponding to the transformed AW.
          BW is not referenced if JOBW = 'N'.

  LDBW    INTEGER
          The leading dimension of the array BW.
          LDBW >= MAX(1,NW), if JOBW <> 'N';
          LDBW >= 1,         if JOBW =  'N'.

  CW      (input/output) DOUBLE PRECISION array, dimension (LDCW,NW)
          On entry, if JOBW <> 'N', the leading M-by-NW part of
          this array must contain the output matrix CW of a state
          space realization of the right frequency weighting W.
          On exit, if JOBW <> 'N', and INFO = 0, the leading
          M-by-NW part of this array contains the transformed output
          matrix CW corresponding to the transformed AW.
          CW is not referenced if JOBW = 'N'.

  LDCW    INTEGER
          The leading dimension of the array CW.
          LDCW >= MAX(1,M), if JOBW <> 'N';
          LDCW >= 1,        if JOBW =  'N'.

  DW      (input) DOUBLE PRECISION array, dimension (LDDW,M)
          If JOBW <> 'N', the leading M-by-M part of this array
          must contain the feedthrough matrix DW of a state space
          realization of the right frequency weighting W.
          DW is not referenced if JOBW = 'N'.

  LDDW    INTEGER
          The leading dimension of the array DW.
          LDDW >= MAX(1,M), if JOBW <> 'N';
          LDDW >= 1,        if JOBW =  'N'.

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of this array contain
          the Hankel singular values, ordered decreasingly, of the
          projection G1s of op(V)*G1*op(W) (see METHOD), where G1
          is the ALPHA-stable part of the original system.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(G1s), where c is a constant in the
          interval [0.00001,0.001], and HNORM(G1s) is the
          Hankel-norm of the projection G1s of op(V)*G1*op(W)
          (see METHOD), computed in HSV(1).
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = NS*EPS*HNORM(G1s), where NS is the number of
          ALPHA-stable eigenvalues of A and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.
          TOL1 < 1.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the ALPHA-stable part of the given system.
          The recommended value is TOL2 = NS*EPS*HNORM(G1s).
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
          TOL2 < 1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = MAX(1,M,c,d),    if DICO = 'C',
          LIWORK = MAX(1,N,M,c,d),  if DICO = 'D', where
             c = 0,                          if JOBV =  'N',
             c = MAX(2*P,NV+P+N+6,2*NV+P+2), if JOBV <> 'N',
             d = 0,                          if JOBW =  'N',
             d = MAX(2*M,NW+M+N+6,2*NW+M+2), if JOBW <> 'N'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where
          for NVP = NV+P and NWM = NW+M we have
          LDW1 = 0 if JOBV =  'N' and
          LDW1 = 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 ) )
                   if JOBV <> 'N',
          LDW2 = 0 if JOBW =  'N' and
          LDW2 = 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 ) )
                   if JOBW <> 'N',
          LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2,
          LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) +
                 MAX( 3*M+1, MIN(N,M)+P ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                system. In this case, the resulting NR is set equal
                to NSMIN.
          = 2:  with ORDSEL = 'F', the selected order NR is less
                than the order of the ALPHA-unstable part of the
                given system. In this case NR is set equal to the
                order of the ALPHA-unstable part.
Error Indicator 
  INFO    INTEGER
          =  0:  successful exit;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  the computation of the ordered real Schur form of A
                 failed;
          =  2:  the separation of the ALPHA-stable/unstable
                 diagonal blocks failed because of very close
                 eigenvalues;
          =  3:  the reduction of AV to a real Schur form failed;
          =  4:  the reduction of AW to a real Schur form failed;
          =  5:  the reduction to generalized Schur form of the
                 descriptor pair corresponding to the inverse of V
                 failed;
          =  6:  the reduction to generalized Schur form of the
                 descriptor pair corresponding to the inverse of W
                 failed;
          =  7:  the computation of Hankel singular values failed;
          =  8:  the computation of stable projection in the
                 Hankel-norm approximation algorithm failed;
          =  9:  the order of computed stable projection in the
                 Hankel-norm approximation algorithm differs
                 from the order of Hankel-norm approximation;
          = 10:  the reduction of AV-BV*inv(DV)*CV to a
                 real Schur form failed;
          = 11:  the reduction of AW-BW*inv(DW)*CW to a
                 real Schur form failed;
          = 12:  the solution of the Sylvester equation failed
                 because the poles of V (if JOBV = 'V') or of
                 conj(V) (if JOBV = 'C') are not distinct from
                 the poles of G1 (see METHOD);
          = 13:  the solution of the Sylvester equation failed
                 because the poles of W (if JOBW = 'W') or of
                 conj(W) (if JOBW = 'C') are not distinct from
                 the poles of G1 (see METHOD);
          = 14:  the solution of the Sylvester equation failed
                 because the zeros of V (if JOBV = 'I') or of
                 conj(V) (if JOBV = 'R') are not distinct from
                 the poles of G1sr (see METHOD);
          = 15:  the solution of the Sylvester equation failed
                 because the zeros of W (if JOBW = 'I') or of
                 conj(W) (if JOBW = 'R') are not distinct from
                 the poles of G1sr (see METHOD);
          = 16:  the solution of the generalized Sylvester system
                 failed because the zeros of V (if JOBV = 'I') or
                 of conj(V) (if JOBV = 'R') are not distinct from
                 the poles of G1sr (see METHOD);
          = 17:  the solution of the generalized Sylvester system
                 failed because the zeros of W (if JOBW = 'I') or
                 of conj(W) (if JOBW = 'R') are not distinct from
                 the poles of G1sr (see METHOD);
          = 18:  op(V) is not antistable;
          = 19:  op(W) is not antistable;
          = 20:  V is not invertible;
          = 21:  W is not invertible.
Method 
  Let G be the transfer-function matrix of the original
  linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                          (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09JD determines
  the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t),                      (2)

  such that the corresponding transfer-function matrix Gr minimizes
  the Hankel-norm of the frequency-weighted error

          op(V)*(G-Gr)*op(W).                            (3)

  For minimizing (3) with op(V) = V and op(W) = W, V and W are
  assumed to have poles distinct from those of G, while with
  op(V) = conj(V) and op(W) = conj(W), conj(V) and conj(W) are
  assumed to have poles distinct from those of G. For minimizing (3)
  with op(V) = inv(V) and op(W) = inv(W), V and W are assumed to
  have zeros distinct from the poles of G, while with
  op(V) = conj(inv(V)) and op(W) = conj(inv(W)), conj(V) and conj(W)
  are assumed to have zeros distinct from the poles of G.

  Note: conj(G) = G'(-s) for a continuous-time system and
        conj(G) = G'(1/z) for a discrete-time system.

  The following procedure is used to reduce G (see [1]):

  1) Decompose additively G as

       G = G1 + G2,

     such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and
     G2 = (A2,B2,C2,0) has only ALPHA-unstable poles.

  2) Compute G1s, the projection of op(V)*G1*op(W) containing the
     poles of G1, using explicit formulas [4] or the inverse-free
     descriptor system formulas of [5].

  3) Determine G1sr, the optimal Hankel-norm approximation of G1s,
     of order r.

  4) Compute G1r, the projection of inv(op(V))*G1sr*inv(op(W))
     containing the poles of G1sr, using explicit formulas [4]
     or the inverse-free descriptor system formulas of [5].

  5) Assemble the reduced model Gr as

        Gr = G1r + G2.

  To reduce the weighted ALPHA-stable part G1s at step 3, the
  optimal Hankel-norm approximation method of [2], based on the
  square-root balancing projection formulas of [3], is employed.

  The optimal weighted approximation error satisfies

       HNORM[op(V)*(G-Gr)*op(W)] >= S(r+1),

  where S(r+1) is the (r+1)-th Hankel singular value of G1s, the
  transfer-function matrix computed at step 2 of the above
  procedure, and HNORM(.) denotes the Hankel-norm.
References 
  [1] Latham, G.A. and Anderson, B.D.O.
      Frequency-weighted optimal Hankel-norm approximation of stable
      transfer functions.
      Systems & Control Letters, Vol. 5, pp. 229-236, 1985.

  [2] Glover, K.
      All optimal Hankel norm approximation of linear
      multivariable systems and their L-infinity error bounds.
      Int. J. Control, Vol. 36, pp. 1145-1193, 1984.

  [3] Tombs, M.S. and Postlethwaite, I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [4] Varga, A.
      Explicit formulas for an efficient implementation
      of the frequency-weighting model reduction approach.
      Proc. 1993 European Control Conference, Groningen, NL,
      pp. 693-696, 1993.

  [5] Varga, A.
      Efficient and numerically reliable implementation of the
      frequency-weighted Hankel-norm approximation model reduction
      approach.
      Proc. 2001 ECC, Porto, Portugal, 2001.
Numerical Aspects 
  The implemented methods rely on an accuracy enhancing square-root
  technique.
Further Comments 
  None
Example

Program Text 

*     AB09JD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, NVMAX, NVPMAX, NWMAX, NWMMAX, PMAX
      PARAMETER        ( MMAX = 20, NMAX = 20, NVMAX = 10, NWMAX = 10,
     $                   PMAX = 20, NVPMAX = NVMAX + PMAX,
     $                   NWMMAX = NWMAX + MMAX )
      INTEGER          LDA, LDAV, LDAW, LDB, LDBV, LDBW,
     $                 LDC, LDCV, LDCW, LDD, LDDV, LDDW
      PARAMETER        ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX,
     $                   LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX,
     $                   LDC = PMAX, LDCV = PMAX,  LDCW = MMAX,
     $                   LDD = PMAX, LDDV = PMAX,  LDDW = MMAX )
      INTEGER          LIW1, LIW2, LIW3, LIWORK
      PARAMETER        ( LIW1 = 2*MAX( MMAX, PMAX ),
     $                   LIW2 = MAX( NVPMAX, NWMMAX ) + NMAX + 6,
     $                   LIW3 = MAX( 2*NVMAX + PMAX + 2,
     $                               2*NWMAX + MMAX + 2 ) )
      PARAMETER        ( LIWORK = MAX( LIW1, LIW2, LIW3 ) )
      INTEGER          LDW1, LDW2, LDW3, LDW4, LDWORK
      PARAMETER        ( LDW1 = 2*NVPMAX*( NVPMAX + PMAX ) + PMAX*PMAX +
     $                          MAX( 2*NVPMAX*NVPMAX +
     $                               MAX( 11*NVPMAX + 16, PMAX*NVPMAX ),
     $                               NVPMAX*NMAX +
     $                               MAX( NVPMAX*NMAX + NMAX*NMAX,
     $                                    PMAX*NMAX, PMAX*MMAX ) ) )
      PARAMETER        ( LDW2 = 2*NWMMAX*( NWMMAX + MMAX ) + MMAX*MMAX +
     $                          MAX( 2*NWMMAX*NWMMAX +
     $                               MAX( 11*NWMMAX + 16, MMAX*NWMMAX ),
     $                               NWMMAX*NMAX +
     $                               MAX( NWMMAX*NMAX + NMAX*NMAX,
     $                                    MMAX*NMAX, PMAX*MMAX ) ) )
      PARAMETER        ( LDW3 = NMAX*( 2*NMAX + MAX( NMAX, MMAX, PMAX )
     $                                 + 5 ) + ( NMAX*( NMAX + 1 ) )/2 )
      PARAMETER        ( LDW4 = NMAX*( MMAX + PMAX + 2 ) + 2*MMAX*PMAX +
     $                          MIN( NMAX, MMAX ) +
     $                          MAX( 3*MMAX + 1,
     $                               MIN( NMAX, MMAX ) + PMAX ) )
      PARAMETER        ( LDWORK = MAX( LDW1, LDW2, LDW3, LDW4 ) )
*     .. Local Scalars ..
      LOGICAL          LEFTW, RIGHTW
      DOUBLE PRECISION ALPHA, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NR, NS, NV, NW, P
      CHARACTER*1      DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX),
     $                 B(LDB,MMAX), BV(LDBV,PMAX),  BW(LDBW,MMAX),
     $                 C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX),
     $                 D(LDD,MMAX), DV(LDDV,PMAX),  DW(LDDW,MMAX),
     $                 DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB09JD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NV, NW, NR, ALPHA, TOL1, TOL2,
     $                      JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL
      LEFTW  = .NOT.LSAME( JOBV, 'N' )
      RIGHTW = .NOT.LSAME( JOBW, 'N' )
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               IF( LEFTW ) THEN
                  IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN
                     WRITE ( NOUT, FMT = 99986 ) NV
                  ELSE
                     IF( NV.GT.0 ) THEN
                        READ ( NIN, FMT = * )
     $                     ( ( AV(I,J), J = 1,NV ), I = 1,NV )
                        READ ( NIN, FMT = * )
     $                     ( ( BV(I,J), J = 1,P  ), I = 1,NV )
                        READ ( NIN, FMT = * )
     $                     ( ( CV(I,J), J = 1,NV ), I = 1,P )
                     END IF
                     IF( LEFTW )
     $                  READ ( NIN, FMT = * )
     $                     ( ( DV(I,J), J = 1,P ), I = 1,P )
                  END IF
               END IF
               IF( RIGHTW ) THEN
                  IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN
                     WRITE ( NOUT, FMT = 99985 ) NW
                  ELSE
                     IF( NW.GT.0 ) THEN
                        READ ( NIN, FMT = * )
     $                     ( ( AW(I,J), J = 1,NW ), I = 1,NW )
                        READ ( NIN, FMT = * )
     $                     ( ( BW(I,J), J = 1,M  ), I = 1,NW )
                        READ ( NIN, FMT = * )
     $                     ( ( CW(I,J), J = 1,NW ), I = 1,M )
                     END IF
                     READ ( NIN, FMT = * )
     $                     ( ( DW(I,J), J = 1,M  ), I = 1,M )
                  END IF
               END IF
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99994 ) IWARN
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS )
                  IF( NR.GT.0 ) THEN
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20 I = 1, NR
                        WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 40 I = 1, NR
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99992 )
                     DO 60 I = 1, P
                        WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60                CONTINUE
                  END IF
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09JD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09JD = ',I2)
99997 FORMAT (/' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' IWARN on exit from AB09JD = ',I2)
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable',
     $         ' part are')
99986 FORMAT (/' NV is out of range.',/' NV = ',I5)
99985 FORMAT (/' NW is out of range.',/' NW = ',I5)
      END
Program Data 
 AB09JD EXAMPLE PROGRAM DATA (Continuous system)
  6     1     1     2   0     0   0.0  1.E-1  1.E-14    V   N   I   C    S   A
   -3.8637   -7.4641   -9.1416   -7.4641   -3.8637   -1.0000
    1.0000         0         0         0         0         0
         0    1.0000         0         0         0         0
         0         0    1.0000         0         0         0
         0         0         0    1.0000         0         0
         0         0         0         0    1.0000         0
         1
         0
         0
         0
         0
         0
         0         0         0         0         0         1
         0
    0.2000   -1.0000
    1.0000         0
     1
     0
   -1.8000         0
     1
Program Results 
 AB09JD EXAMPLE PROGRAM RESULTS


 The order of reduced model =  4

 The Hankel singular values of weighted ALPHA-stable part are
   2.6790   2.1589   0.8424   0.1929   0.0219   0.0011

 The reduced state dynamics matrix Ar is 
  -0.2391   0.3072   1.1630   1.1967
  -2.9709  -0.2391   2.6270   3.1027
   0.0000   0.0000  -0.5137  -1.2842
   0.0000   0.0000   0.1519  -0.5137

 The reduced input/state matrix Br is 
  -1.0497
  -3.7052
   0.8223
   0.7435

 The reduced state/output matrix Cr is 
  -0.4466   0.0143  -0.4780  -0.2013

 The reduced input/output matrix Dr is 
   0.0219

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09JV.html000077500000000000000000000341371201767322700161070ustar00rootroot00000000000000 AB09JV - SLICOT Library Routine Documentation

AB09JV

State-space representation of a projection of a left weighted transfer-function matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct a state-space representation (A,BS,CS,DS) of the
  projection of V*G or conj(V)*G containing the poles of G, from the
  state-space representations (A,B,C,D) and (AV-lambda*EV,BV,CV,DV),
  of the transfer-function matrices G and V, respectively.
  G is assumed to be a stable transfer-function matrix and
  the state matrix A must be in a real Schur form.
  When computing the stable projection of V*G, it is assumed
  that G and V have completely distinct poles.
  When computing the stable projection of conj(V)*G, it is assumed
  that G and conj(V) have completely distinct poles.

  Note: For a transfer-function matrix G, conj(G) denotes the
  conjugate of G given by G'(-s) for a continuous-time system or
  G'(1/z) for a discrete-time system.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the projection to be computed as follows:
          = 'V':  compute the projection of V*G containing
                  the poles of G;
          = 'C':  compute the projection of conj(V)*G containing
                  the poles of G.

  DICO    CHARACTER*1
          Specifies the type of the systems as follows:
          = 'C':  G and V are continuous-time systems;
          = 'D':  G and V are discrete-time systems.

  JOBEV   CHARACTER*1
          Specifies whether EV is a general square or an identity
          matrix as follows:
          = 'G':  EV is a general square matrix;
          = 'I':  EV is the identity matrix.

  STBCHK  CHARACTER*1
          Specifies whether stability/antistability of V is to be
          checked as follows:
          = 'C':  check stability if JOB = 'C' or antistability if
                  JOB = 'V';
          = 'N':  do not check stability or antistability.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector of the system with
          the transfer-function matrix G.  N >= 0.

  M       (input) INTEGER
          The dimension of the input vector of the system with
          the transfer-function matrix G.  M >= 0.

  P       (input) INTEGER
          The dimension of the output vector of the system with the
          transfer-function matrix G, and also the dimension of
          the input vector if JOB = 'V', or of the output vector
          if JOB = 'C', of the system with the transfer-function
          matrix V.  P >= 0.

  NV      (input) INTEGER
          The dimension of the state vector of the system with
          the transfer-function matrix V.  NV >= 0.

  PV      (input) INTEGER
          The dimension of the output vector, if JOB = 'V', or
          of the input vector, if JOB = 'C', of the system with
          the transfer-function matrix V.  PV >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the system with the transfer-function
          matrix G in a real Schur form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain
          the input/state matrix B of the system with the
          transfer-function matrix G. The matrix BS is equal to B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C of the system with the
          transfer-function matrix G.
          On exit, if INFO = 0, the leading PV-by-N part of this
          array contains the output matrix CS of the projection of
          V*G, if JOB = 'V', or of conj(V)*G, if JOB = 'C'.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,P,PV).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the feedthrough matrix D of the system with the
          transfer-function matrix G.
          On exit, if INFO = 0, the leading PV-by-M part of
          this array contains the feedthrough matrix DS of the
          projection of V*G, if JOB = 'V', or of conj(V)*G,
          if JOB = 'C'.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,P,PV).

  AV      (input/output) DOUBLE PRECISION array, dimension (LDAV,NV)
          On entry, the leading NV-by-NV part of this array must
          contain the state matrix AV of the system with the
          transfer-function matrix V.
          On exit, if INFO = 0, the leading NV-by-NV part of this
          array contains a condensed matrix as follows:
          if JOBEV = 'I', it contains the real Schur form of AV;
          if JOBEV = 'G' and JOB = 'V', it contains a quasi-upper
          triangular matrix representing the real Schur matrix
          in the real generalized Schur form of the pair (AV,EV);
          if JOBEV = 'G', JOB = 'C' and DICO = 'C', it contains a
          quasi-upper triangular matrix corresponding to the
          generalized real Schur form of the pair (AV',EV');
          if JOBEV = 'G', JOB = 'C' and DICO = 'D', it contains an
          upper triangular matrix corresponding to the generalized
          real Schur form of the pair (EV',AV').

  LDAV    INTEGER
          The leading dimension of the array AV.  LDAV >= MAX(1,NV).

  EV      (input/output) DOUBLE PRECISION array, dimension (LDEV,NV)
          On entry, if JOBEV = 'G', the leading NV-by-NV part of
          this array must contain the descriptor matrix EV of the
          system with the transfer-function matrix V.
          If JOBEV = 'I', EV is assumed to be an identity matrix
          and is not referenced.
          On exit, if INFO = 0 and JOBEV = 'G', the leading NV-by-NV
          part of this array contains a condensed matrix as follows:
          if JOB = 'V', it contains an upper triangular matrix
          corresponding to the real generalized Schur form of the
          pair (AV,EV);
          if JOB = 'C' and DICO = 'C', it contains an upper
          triangular matrix corresponding to the generalized real
          Schur form of the pair (AV',EV');
          if JOB = 'C' and DICO = 'D', it contains a quasi-upper
          triangular matrix corresponding to the generalized
          real Schur form of the pair (EV',AV').

  LDEV    INTEGER
          The leading dimension of the array EV.
          LDEV >= MAX(1,NV), if JOBEV = 'G';
          LDEV >= 1,         if JOBEV = 'I'.

  BV      (input/output) DOUBLE PRECISION array,
          dimension (LDBV,MBV), where MBV = P, if JOB = 'V', and
          MBV = PV, if JOB = 'C'.
          On entry, the leading NV-by-MBV part of this array must
          contain the input matrix BV of the system with the
          transfer-function matrix V.
          On exit, if INFO = 0, the leading NV-by-MBV part of this
          array contains Q'*BV, where Q is the orthogonal matrix
          that reduces AV to the real Schur form or the left
          orthogonal matrix used to reduce the pair (AV,EV),
          (AV',EV') or (EV',AV') to the generalized real Schur form.

  LDBV    INTEGER
          The leading dimension of the array BV.  LDBV >= MAX(1,NV).

  CV      (input/output) DOUBLE PRECISION array, dimension (LDCV,NV)
          On entry, the leading PCV-by-NV part of this array must
          contain the output matrix CV of the system with the
          transfer-function matrix V, where PCV = PV, if JOB = 'V',
          or PCV = P, if JOB = 'C'.
          On exit, if INFO = 0, the leading PCV-by-NV part of this
          array contains CV*Q, where Q is the orthogonal matrix that
          reduces AV to the real Schur form, or CV*Z, where Z is the
          right orthogonal matrix used to reduce the pair (AV,EV),
          (AV',EV') or (EV',AV') to the generalized real Schur form.

  LDCV    INTEGER
          The leading dimension of the array CV.
          LDCV >= MAX(1,PV) if JOB = 'V';
          LDCV >= MAX(1,P)  if JOB = 'C'.

  DV      (input) DOUBLE PRECISION array,
          dimension (LDDV,MBV), where MBV = P, if JOB = 'V', and
          MBV = PV, if JOB = 'C'.
          The leading PCV-by-MBV part of this array must contain
          the feedthrough matrix DV of the system with the
          transfer-function matrix V, where PCV = PV, if JOB = 'V',
          or PCV = P, if JOB = 'C'.

  LDDV    INTEGER
          The leading dimension of the array DV.
          LDDV >= MAX(1,PV) if JOB = 'V';
          LDDV >= MAX(1,P)  if JOB = 'C'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK =   0,    if JOBEV = 'I';
          LIWORK = NV+N+6, if JOBEV = 'G'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= LW1, if JOBEV = 'I',
          LDWORK >= LW2, if JOBEV = 'G', where
            LW1 = MAX( 1, NV*(NV+5), NV*N + MAX( a, PV*N, PV*M ) )
                  a = 0,    if DICO = 'C' or  JOB = 'V',
                  a = 2*NV, if DICO = 'D' and JOB = 'C';
            LW2 = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ),
                       NV*N + MAX( NV*N+N*N, PV*N, PV*M ) ).
          For good performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          =  0:  successful exit;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  the reduction of the pair (AV,EV) to the real
                 generalized Schur form failed (JOBEV = 'G'),
                 or the reduction of the matrix AV to the real
                 Schur form failed (JOBEV = 'I);
          =  2:  the solution of the Sylvester equation failed
                 because the matrix A and the pencil AV-lambda*EV
                 have common eigenvalues (if JOB = 'V'), or the
                 pencil -AV-lambda*EV and A have common eigenvalues
                 (if JOB = 'C' and DICO = 'C'), or the pencil
                 AV-lambda*EV has an eigenvalue which is the
                 reciprocal of one of eigenvalues of A
                 (if JOB = 'C' and DICO = 'D');
          =  3:  the solution of the Sylvester equation failed
                 because the matrices A and AV have common
                 eigenvalues (if JOB = 'V'), or the matrices A
                 and -AV have common eigenvalues (if JOB = 'C' and
                 DICO = 'C'), or the matrix A has an eigenvalue
                 which is the reciprocal of one of eigenvalues of AV
                 (if JOB = 'C' and DICO = 'D');
          =  4:  JOB = 'V' and the pair (AV,EV) has not completely
                 unstable generalized eigenvalues, or JOB = 'C' and
                 the pair (AV,EV) has not completely stable
                 generalized eigenvalues.
Method 
  If JOB = 'V', the matrices of the stable projection of V*G are
  computed as

    BS = B,  CS = CV*X + DV*C,  DS = DV*D,

  where X satisfies the generalized Sylvester equation

    AV*X - EV*X*A + BV*C = 0.

  If JOB = 'C', the matrices of the stable projection of conj(V)*G
  are computed using the following formulas:

  - for a continuous-time system, the matrices BS, CS and DS of
    the stable projection are computed as

      BS = B,  CS = BV'*X + DV'*C,  DS = DV'*D,

    where X satisfies the generalized Sylvester equation

      AV'*X + EV'*X*A + CV'*C = 0.

  - for a discrete-time system, the matrices BS, CS and DS of
    the stable projection are computed as

      BS = B,  CS = BV'*X*A + DV'*C,  DS = DV'*D + BV'*X*B,

    where X satisfies the generalized Sylvester equation

      EV'*X - AV'*X*A = CV'*C.
References 
  [1] Varga, A.
      Efficient and numerically reliable implementation of the
      frequency-weighted Hankel-norm approximation model reduction
      approach.
      Proc. 2001 ECC, Porto, Portugal, 2001.

  [2] Zhou, K.
      Frequency-weighted H-infinity norm and optimal Hankel norm
      model reduction.
      IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995.
Numerical Aspects 
  The implemented methods rely on numerically stable algorithms.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09JW.html000077500000000000000000000341241201767322700161040ustar00rootroot00000000000000 AB09JW - SLICOT Library Routine Documentation

AB09JW

State-space representation of a projection of a right weighted transfer-function matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct a state-space representation (A,BS,CS,DS) of the
  projection of G*W or G*conj(W) containing the poles of G, from the
  state-space representations (A,B,C,D) and (AW-lambda*EW,BW,CW,DW),
  of the transfer-function matrices G and W, respectively.
  G is assumed to be a stable transfer-function matrix and
  the state matrix A must be in a real Schur form.
  When computing the stable projection of G*W, it is assumed
  that G and W have completely distinct poles.
  When computing the stable projection of G*conj(W), it is assumed
  that G and conj(W) have completely distinct poles.

  Note: For a transfer-function matrix G, conj(G) denotes the
  conjugate of G given by G'(-s) for a continuous-time system or
  G'(1/z) for a discrete-time system.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the projection to be computed as follows:
          = 'W':  compute the projection of G*W containing
                  the poles of G;
          = 'C':  compute the projection of G*conj(W) containing
                  the poles of G.

  DICO    CHARACTER*1
          Specifies the type of the systems as follows:
          = 'C':  G and W are continuous-time systems;
          = 'D':  G and W are discrete-time systems.

  JOBEW   CHARACTER*1
          Specifies whether EW is a general square or an identity
          matrix as follows:
          = 'G':  EW is a general square matrix;
          = 'I':  EW is the identity matrix.

  STBCHK  CHARACTER*1
          Specifies whether stability/antistability of W is to be
          checked as follows:
          = 'C':  check stability if JOB = 'C' or antistability if
                  JOB = 'W';
          = 'N':  do not check stability or antistability.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector of the system with
          the transfer-function matrix G.  N >= 0.

  M       (input) INTEGER
          The dimension of the input vector of the system with
          the transfer-function matrix G, and also the dimension
          of the output vector if JOB = 'W', or of the input vector
          if JOB = 'C', of the system with the transfer-function
          matrix W.  M >= 0.

  P       (input) INTEGER
          The dimension of the output vector of the system with the
          transfer-function matrix G.  P >= 0.

  NW      (input) INTEGER
          The dimension of the state vector of the system with the
          transfer-function matrix W.  NW >= 0.

  MW      (input) INTEGER
          The dimension of the input vector, if JOB = 'W', or of
          the output vector, if JOB = 'C', of the system with the
          transfer-function matrix W.  MW >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the system with the transfer-function
          matrix G in a real Schur form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array,
          dimension (LDB,MAX(M,MW))
          On entry, the leading N-by-M part of this array must
          contain the input matrix B of the system with the
          transfer-function matrix G.
          On exit, if INFO = 0, the leading N-by-MW part of this
          array contains the input matrix BS of the projection of
          G*W, if JOB = 'W', or of G*conj(W), if JOB = 'C'.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain
          the output/state matrix C of the system with the
          transfer-function matrix G. The matrix CS is equal to C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array,
          dimension (LDB,MAX(M,MW))
          On entry, the leading P-by-M part of this array must
          contain the feedthrough matrix D of the system with
          the transfer-function matrix G.
          On exit, if INFO = 0, the leading P-by-MW part of
          this array contains the feedthrough matrix DS of the
          projection of G*W, if JOB = 'W', or of G*conj(W),
          if JOB = 'C'.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,P).

  AW      (input/output) DOUBLE PRECISION array, dimension (LDAW,NW)
          On entry, the leading NW-by-NW part of this array must
          contain the state matrix AW of the system with the
          transfer-function matrix W.
          On exit, if INFO = 0, the leading NW-by-NW part of this
          array contains a condensed matrix as follows:
          if JOBEW = 'I', it contains the real Schur form of AW;
          if JOBEW = 'G' and JOB = 'W', it contains a quasi-upper
          triangular matrix representing the real Schur matrix
          in the real generalized Schur form of the pair (AW,EW);
          if JOBEW = 'G', JOB = 'C' and DICO = 'C', it contains a
          quasi-upper triangular matrix corresponding to the
          generalized real Schur form of the pair (AW',EW');
          if JOBEW = 'G', JOB = 'C' and DICO = 'D', it contains an
          upper triangular matrix corresponding to the generalized
          real Schur form of the pair (EW',AW').

  LDAW    INTEGER
          The leading dimension of the array AW.  LDAW >= MAX(1,NW).

  EW      (input/output) DOUBLE PRECISION array, dimension (LDEW,NW)
          On entry, if JOBEW = 'G', the leading NW-by-NW part of
          this array must contain the descriptor matrix EW of the
          system with the transfer-function matrix W.
          If JOBEW = 'I', EW is assumed to be an identity matrix
          and is not referenced.
          On exit, if INFO = 0 and JOBEW = 'G', the leading NW-by-NW
          part of this array contains a condensed matrix as follows:
          if JOB = 'W', it contains an upper triangular matrix
          corresponding to the real generalized Schur form of the
          pair (AW,EW);
          if JOB = 'C' and DICO = 'C', it contains an upper
          triangular matrix corresponding to the generalized real
          Schur form of the pair (AW',EW');
          if JOB = 'C' and DICO = 'D', it contains a quasi-upper
          triangular matrix corresponding to the generalized
          real Schur form of the pair (EW',AW').

  LDEW    INTEGER
          The leading dimension of the array EW.
          LDEW >= MAX(1,NW), if JOBEW = 'G';
          LDEW >= 1,         if JOBEW = 'I'.

  BW      (input/output) DOUBLE PRECISION array,
          dimension (LDBW,MBW), where MBW = MW, if JOB = 'W', and
          MBW = M, if JOB = 'C'.
          On entry, the leading NW-by-MBW part of this array must
          contain the input matrix BW of the system with the
          transfer-function matrix W.
          On exit, if INFO = 0, the leading NW-by-MBW part of this
          array contains Q'*BW, where Q is the orthogonal matrix
          that reduces AW to the real Schur form or the left
          orthogonal matrix used to reduce the pair (AW,EW),
          (AW',EW') or (EW',AW') to the generalized real Schur form.

  LDBW    INTEGER
          The leading dimension of the array BW.  LDBW >= MAX(1,NW).

  CW      (input/output) DOUBLE PRECISION array, dimension (LDCW,NW)
          On entry, the leading PCW-by-NW part of this array must
          contain the output matrix CW of the system with the
          transfer-function matrix W, where PCW = M if JOB = 'W' or
          PCW = MW if JOB = 'C'.
          On exit, if INFO = 0, the leading PCW-by-NW part of this
          array contains CW*Q, where Q is the orthogonal matrix that
          reduces AW to the real Schur form, or CW*Z, where Z is the
          right orthogonal matrix used to reduce the pair (AW,EW),
          (AW',EW') or (EW',AW') to the generalized real Schur form.

  LDCW    INTEGER
          The leading dimension of the array CW.
          LDCW >= MAX(1,PCW), where PCW = M if JOB = 'W', or
          PCW = MW if JOB = 'C'.

  DW      (input) DOUBLE PRECISION array,
          dimension (LDDW,MBW), where MBW = MW if JOB = 'W', and
          MBW = M if JOB = 'C'.
          The leading PCW-by-MBW part of this array must contain
          the feedthrough matrix DW of the system with the
          transfer-function matrix W, where PCW = M if JOB = 'W',
          or PCW = MW if JOB = 'C'.

  LDDW    INTEGER
          LDDW >= MAX(1,PCW), where PCW = M if JOB = 'W', or
          PCW = MW if JOB = 'C'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK =   0,    if JOBEW = 'I';
          LIWORK = NW+N+6, if JOBEW = 'G'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= LW1, if JOBEW = 'I',
          LDWORK >= LW2, if JOBEW = 'G', where
            LW1 = MAX( 1, NW*(NW+5), NW*N + MAX( a, N*MW, P*MW ) )
                  a = 0,    if DICO = 'C' or  JOB = 'W',
                  a = 2*NW, if DICO = 'D' and JOB = 'C';
            LW2 = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ),
                       NW*N + MAX( NW*N+N*N, MW*N, P*MW ) ).
          For good performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          =  0:  successful exit;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  the reduction of the pair (AW,EW) to the real
                 generalized Schur form failed (JOBEW = 'G'),
                 or the reduction of the matrix AW to the real
                 Schur form failed (JOBEW = 'I);
          =  2:  the solution of the Sylvester equation failed
                 because the matrix A and the pencil AW-lambda*EW
                 have common eigenvalues (if JOB = 'W'), or the
                 pencil -AW-lambda*EW and A have common eigenvalues
                 (if JOB = 'C' and DICO = 'C'), or the pencil
                 AW-lambda*EW has an eigenvalue which is the
                 reciprocal of one of eigenvalues of A
                 (if JOB = 'C' and DICO = 'D');
          =  3:  the solution of the Sylvester equation failed
                 because the matrices A and AW have common
                 eigenvalues (if JOB = 'W'), or the matrices A
                 and -AW have common eigenvalues (if JOB = 'C' and
                 DICO = 'C'), or the matrix A has an eigenvalue
                 which is the reciprocal of one of eigenvalues of AW
                 (if JOB = 'C' and DICO = 'D');
          =  4:  JOB = 'W' and the pair (AW,EW) has not completely
                 unstable generalized eigenvalues, or JOB = 'C' and
                 the pair (AW,EW) has not completely stable
                 generalized eigenvalues.
Method 
  If JOB = 'W', the matrices of the stable projection of G*W are
  computed as

    BS = B*DW + Y*BW,  CS = C,  DS = D*DW,

  where Y satisfies the generalized Sylvester equation

    -A*Y*EW + Y*AW + B*CW = 0.

  If JOB = 'C', the matrices of the stable projection of G*conj(W)
  are computed using the following formulas:

  - for a continuous-time system, the matrices BS, CS and DS of
    the stable projection are computed as

      BS = B*DW' + Y*CW',  CS = C,  DS = D*DW',

    where Y satisfies the generalized Sylvester equation

      A*Y*EW' + Y*AW' + B*BW' = 0.

  - for a discrete-time system, the matrices BS, CS and DS of
    the stable projection are computed as

      BS = B*DW' + A*Y*CW',  CS = C,  DS = D*DW' + C*Y*CW',

    where Y satisfies the generalized Sylvester equation

      Y*EW' - A*Y*AW' = B*BW'.
References 
  [1] Varga, A.
      Efficient and numerically reliable implementation of the
      frequency-weighted Hankel-norm approximation model reduction
      approach.
      Proc. 2001 ECC, Porto, Portugal, 2001.

  [2] Zhou, K.
      Frequency-weighted H-infinity norm and optimal Hankel norm
      model reduction.
      IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995.
Numerical Aspects 
  The implemented methods rely on numerically stable algorithms.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09JX.html000077500000000000000000000110471201767322700161040ustar00rootroot00000000000000 AB09JX - SLICOT Library Routine Documentation

AB09JX

Check stability/antistability of finite eigenvalues

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To check stability/antistability of finite eigenvalues with
  respect to a given stability domain.
Specification 
      SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED,
     $                   TOLINF, INFO )
C     .. Scalar Arguments ..
      CHARACTER        DICO, EVTYPE, STDOM
      INTEGER          INFO, N
      DOUBLE PRECISION ALPHA, TOLINF
C     .. Array Arguments ..
      DOUBLE PRECISION ED(*), EI(*), ER(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the stability domain as follows:
          = 'C':  for a continuous-time system;
          = 'D':  for a discrete-time system.

  STDOM   CHARACTER*1
          Specifies whether the domain of interest is of stability
          type (left part of complex plane or inside of a circle)
          or of instability type (right part of complex plane or
          outside of a circle) as follows:
          = 'S':  stability type domain;
          = 'U':  instability type domain.

  EVTYPE  CHARACTER*1
          Specifies whether the eigenvalues arise from a standard
          or a generalized eigenvalue problem as follows:
          = 'S':  standard eigenvalue problem;
          = 'G':  generalized eigenvalue problem;
          = 'R':  reciprocal generalized eigenvalue problem.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of vectors ER, EI and ED.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          Specifies the boundary of the domain of interest for the
          eigenvalues. For a continuous-time system
          (DICO = 'C'), ALPHA is the boundary value for the real
          parts of eigenvalues, while for a discrete-time system
          (DICO = 'D'), ALPHA >= 0 represents the boundary value for
          the moduli of eigenvalues.

  ER, EI, (input) DOUBLE PRECISION arrays, dimension (N)
  ED      If EVTYPE = 'S', ER(j) + EI(j)*i, j = 1,...,N, are
          the eigenvalues of a real matrix.
          ED is not referenced and is implicitly considered as
          a vector having all elements equal to one.
          If EVTYPE = 'G' or EVTYPE = 'R', (ER(j) + EI(j)*i)/ED(j),
          j = 1,...,N, are the generalized eigenvalues of a pair of
          real matrices. If ED(j) is zero, then the j-th generalized
          eigenvalue is infinite.
          Complex conjugate pairs of eigenvalues must appear
          consecutively.
Tolerances 
  TOLINF  DOUBLE PRECISION
          If EVTYPE = 'G' or 'R', TOLINF contains the tolerance for
          detecting infinite generalized eigenvalues.
          0 <= TOLINF < 1.
Error Indicator 
  INFO    INTEGER
          =  0:  successful exit, i.e., all eigenvalues lie within
                 the domain of interest defined by DICO, STDOM
                 and ALPHA;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  some eigenvalues lie outside the domain of interest
                 defined by DICO, STDOM and ALPHA.
Method 
  The domain of interest for an eigenvalue lambda is defined by the
  parameters ALPHA, DICO and STDOM as follows:
     - for a continuous-time system (DICO = 'C'):
            Real(lambda) < ALPHA if STDOM = 'S';
            Real(lambda) > ALPHA if STDOM = 'U';
     - for a discrete-time system (DICO = 'D'):
            Abs(lambda) < ALPHA if STDOM = 'S';
            Abs(lambda) > ALPHA if STDOM = 'U'.
  If EVTYPE = 'R', the same conditions apply for 1/lambda.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09KD.html000077500000000000000000000765671201767322700161030ustar00rootroot00000000000000 AB09KD - SLICOT Library Routine Documentation

AB09KD

Frequency-weighted Hankel-norm approximation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using the frequency
  weighted optimal Hankel-norm approximation method.
  The Hankel norm of the weighted error

        V*(G-Gr)*W    or    conj(V)*(G-Gr)*conj(W)

  is minimized, where G and Gr are the transfer-function matrices
  of the original and reduced systems, respectively, and V and W
  are the transfer-function matrices of the left and right frequency
  weights, specified by their state space realizations (AV,BV,CV,DV)
  and (AW,BW,CW,DW), respectively. When minimizing the weighted
  error V*(G-Gr)*W, V and W must be antistable transfer-function
  matrices. When minimizing conj(V)*(G-Gr)*conj(W), V and W must be
  stable transfer-function matrices.
  Additionally, V and W must be invertible transfer-function
  matrices, with the feedthrough matrices DV and DW invertible.
  If the original system is unstable, then the frequency weighted
  Hankel-norm approximation is computed only for the
  ALPHA-stable part of the system.

  For a transfer-function matrix G, conj(G) denotes the conjugate
  of G given by G'(-s) for a continuous-time system or G'(1/z)
  for a discrete-time system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the frequency-weighting problem as follows:
          = 'N':  solve min||V*(G-Gr)*W||_H;
          = 'C':  solve min||conj(V)*(G-Gr)*conj(W)||_H.

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  WEIGHT  CHARACTER*1
          Specifies the type of frequency weighting, as follows:
          = 'N':  no weightings are used (V = I, W = I);
          = 'L':  only left weighting V is used (W = I);
          = 'R':  only right weighting W is used (V = I);
          = 'B':  both left and right weightings V and W are used.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e., the order of the matrix A.  N >= 0.

  NV      (input) INTEGER
          The order of the realization of the left frequency
          weighting V, i.e., the order of the matrix AV.  NV >= 0.

  NW      (input) INTEGER
          The order of the realization of the right frequency
          weighting W, i.e., the order of the matrix AW.  NW >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of
          the resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. For a system with NU ALPHA-unstable
          eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
          NR is set as follows: if ORDSEL = 'F', NR is equal to
          NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the
          multiplicity of the Hankel singular value HSV(NR-NU+1),
          NR is the desired order on entry, and NMIN is the order
          of a minimal realization of the ALPHA-stable part of the
          given system; NMIN is determined as the number of Hankel
          singular values greater than NS*EPS*HNORM(As,Bs,Cs), where
          EPS is the machine precision (see LAPACK Library Routine
          DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the
          ALPHA-stable part of the weighted system (computed in
          HSV(1));
          if ORDSEL = 'A', NR is the sum of NU and the number of
          Hankel singular values greater than
          MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the
          reduced order system in a real Schur form.
          The resulting A has a block-diagonal form with two blocks.
          For a system with NU ALPHA-unstable eigenvalues and
          NS ALPHA-stable eigenvalues (NU+NS = N), the leading
          NU-by-NU block contains the unreduced part of A
          corresponding to ALPHA-unstable eigenvalues.
          The trailing (NR+NS-N)-by-(NR+NS-N) block contains
          the reduced part of A corresponding to ALPHA-stable
          eigenvalues.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  AV      (input/output) DOUBLE PRECISION array, dimension (LDAV,NV)
          On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV
          part of this array must contain the state matrix AV of a
          state space realization of the left frequency weighting V.
          On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
          NV-by-NV part of this array contains a real Schur form
          of the state matrix of a state space realization of the
          inverse of V.
          AV is not referenced if WEIGHT = 'R' or 'N'.

  LDAV    INTEGER
          The leading dimension of the array AV.
          LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDAV >= 1,         if WEIGHT = 'R' or 'N'.

  BV      (input/output) DOUBLE PRECISION array, dimension (LDBV,P)
          On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part
          of this array must contain the input matrix BV of a state
          space realization of the left frequency weighting V.
          On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
          NV-by-P part of this array contains the input matrix of a
          state space realization of the inverse of V.
          BV is not referenced if WEIGHT = 'R' or 'N'.

  LDBV    INTEGER
          The leading dimension of the array BV.
          LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDBV >= 1,         if WEIGHT = 'R' or 'N'.

  CV      (input/output) DOUBLE PRECISION array, dimension (LDCV,NV)
          On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part
          of this array must contain the output matrix CV of a state
          space realization of the left frequency weighting V.
          On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
          P-by-NV part of this array contains the output matrix of a
          state space realization of the inverse of V.
          CV is not referenced if WEIGHT = 'R' or 'N'.

  LDCV    INTEGER
          The leading dimension of the array CV.
          LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B';
          LDCV >= 1,        if WEIGHT = 'R' or 'N'.

  DV      (input/output) DOUBLE PRECISION array, dimension (LDDV,P)
          On entry, if WEIGHT = 'L' or 'B', the leading P-by-P part
          of this array must contain the feedthrough matrix DV of a
          state space realization of the left frequency weighting V.
          On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
          P-by-P part of this array contains the feedthrough matrix
          of a state space realization of the inverse of V.
          DV is not referenced if WEIGHT = 'R' or 'N'.

  LDDV    INTEGER
          The leading dimension of the array DV.
          LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B';
          LDDV >= 1,        if WEIGHT = 'R' or 'N'.

  AW      (input/output) DOUBLE PRECISION array, dimension (LDAW,NW)
          On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW
          part of this array must contain the state matrix AW of
          a state space realization of the right frequency
          weighting W.
          On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
          NW-by-NW part of this array contains a real Schur form of
          the state matrix of a state space realization of the
          inverse of W.
          AW is not referenced if WEIGHT = 'L' or 'N'.

  LDAW    INTEGER
          The leading dimension of the array AW.
          LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDAW >= 1,         if WEIGHT = 'L' or 'N'.

  BW      (input/output) DOUBLE PRECISION array, dimension (LDBW,M)
          On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part
          of this array must contain the input matrix BW of a state
          space realization of the right frequency weighting W.
          On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
          NW-by-M part of this array contains the input matrix of a
          state space realization of the inverse of W.
          BW is not referenced if WEIGHT = 'L' or 'N'.

  LDBW    INTEGER
          The leading dimension of the array BW.
          LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDBW >= 1,         if WEIGHT = 'L' or 'N'.

  CW      (input/output) DOUBLE PRECISION array, dimension (LDCW,NW)
          On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part
          of this array must contain the output matrix CW of a state
          space realization of the right frequency weighting W.
          On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
          M-by-NW part of this array contains the output matrix of a
          state space realization of the inverse of W.
          CW is not referenced if WEIGHT = 'L' or 'N'.

  LDCW    INTEGER
          The leading dimension of the array CW.
          LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDCW >= 1,        if WEIGHT = 'L' or 'N'.

  DW      (input/output) DOUBLE PRECISION array, dimension (LDDW,M)
          On entry, if WEIGHT = 'R' or 'B', the leading M-by-M part
          of this array must contain the feedthrough matrix DW of
          a state space realization of the right frequency
          weighting W.
          On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
          M-by-M part of this array contains the feedthrough matrix
          of a state space realization of the inverse of W.
          DW is not referenced if WEIGHT = 'L' or 'N'.

  LDDW    INTEGER
          The leading dimension of the array DW.
          LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDDW >= 1,        if WEIGHT = 'L' or 'N'.

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of this array contain
          the Hankel singular values, ordered decreasingly, of the
          ALPHA-stable part of the weighted original system.
          HSV(1) is the Hankel norm of the ALPHA-stable weighted
          subsystem.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the
          interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the
          Hankel-norm of the ALPHA-stable part of the weighted
          original system (computed in HSV(1)).
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of
          ALPHA-stable eigenvalues of A and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the ALPHA-stable part of the given system.
          The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs).
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = MAX(1,M,c),      if DICO = 'C',
          LIWORK = MAX(1,N,M,c),    if DICO = 'D',
          where  c = 0,             if WEIGHT = 'N',
                 c = 2*P,           if WEIGHT = 'L',
                 c = 2*M,           if WEIGHT = 'R',
                 c = MAX(2*M,2*P),  if WEIGHT = 'B'.
          On exit, if INFO = 0, IWORK(1) contains NMIN, the order of
          the computed minimal realization.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where
          LDW1 = 0 if WEIGHT = 'R' or 'N' and
          LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) )
                 if WEIGHT = 'L' or WEIGHT = 'B',
          LDW2 = 0 if WEIGHT = 'L' or 'N' and
          LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) )
                 if WEIGHT = 'R' or WEIGHT = 'B', with
             a = 0,    b = 0,     if DICO = 'C' or  JOB = 'N',
             a = 2*NV, b = 2*NW,  if DICO = 'D' and JOB = 'C';
          LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2,
          LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) +
                 MAX( 3*M+1, MIN(N,M)+P ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                system; in this case, the resulting NR is set equal
                to NSMIN;
          = 2:  with ORDSEL = 'F', the selected order NR is less
                than the order of the ALPHA-unstable part of the
                given system; in this case NR is set equal to the
                order of the ALPHA-unstable part.
Error Indicator 
  INFO    INTEGER
          =  0:  successful exit;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  the computation of the ordered real Schur form of A
                 failed;
          =  2:  the separation of the ALPHA-stable/unstable
                 diagonal blocks failed because of very close
                 eigenvalues;
          =  3:  the reduction of AV or AV-BV*inv(DV)*CV to a
                 real Schur form failed;
          =  4:  the reduction of AW or AW-BW*inv(DW)*CW to a
                 real Schur form failed;
          =  5:  JOB = 'N' and AV is not antistable, or
                 JOB = 'C' and AV is not stable;
          =  6:  JOB = 'N' and AW is not antistable, or
                 JOB = 'C' and AW is not stable;
          =  7:  the computation of Hankel singular values failed;
          =  8:  the computation of stable projection in the
                 Hankel-norm approximation algorithm failed;
          =  9:  the order of computed stable projection in the
                 Hankel-norm approximation algorithm differs
                 from the order of Hankel-norm approximation;
          = 10:  DV is singular;
          = 11:  DW is singular;
          = 12:  the solution of the Sylvester equation failed
                 because the zeros of V (if JOB = 'N') or of conj(V)
                 (if JOB = 'C') are not distinct from the poles
                 of G1sr (see METHOD);
          = 13:  the solution of the Sylvester equation failed
                 because the zeros of W (if JOB = 'N') or of conj(W)
                 (if JOB = 'C') are not distinct from the poles
                 of G1sr (see METHOD).
Method 
  Let G be the transfer-function matrix of the original
  linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                          (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09KD determines
  the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t),                      (2)

  such that the corresponding transfer-function matrix Gr minimizes
  the Hankel-norm of the frequency-weighted error

          V*(G-Gr)*W,                                    (3)
  or
          conj(V)*(G-Gr)*conj(W).                        (4)

  For minimizing (3), V and W are assumed to be antistable, while
  for minimizing (4), V and W are assumed to be stable transfer-
  function matrices.

  Note: conj(G) = G'(-s) for a continuous-time system and
        conj(G) = G'(1/z) for a discrete-time system.

  The following procedure is used to reduce G (see [1]):

  1) Decompose additively G as

       G = G1 + G2,

     such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and
     G2 = (A2,B2,C2,0) has only ALPHA-unstable poles.

  2) Compute G1s, the stable projection of V*G1*W or
     conj(V)*G1*conj(W), using explicit formulas [4].

  3) Determine G1sr, the optimal Hankel-norm approximation of G1s
     of order r.

  4) Compute G1r, the stable projection of either inv(V)*G1sr*inv(W)
     or conj(inv(V))*G1sr*conj(inv(W)), using explicit formulas [4].

  5) Assemble the reduced model Gr as

        Gr = G1r + G2.

  To reduce the weighted ALPHA-stable part G1s at step 3, the
  optimal Hankel-norm approximation method of [2], based on the
  square-root balancing projection formulas of [3], is employed.

  The optimal weighted approximation error satisfies

       HNORM[V*(G-Gr)*W] = S(r+1),
  or
       HNORM[conj(V)*(G-Gr)*conj(W)] = S(r+1),

  where S(r+1) is the (r+1)-th Hankel singular value of G1s, the
  transfer-function matrix computed at step 2 of the above
  procedure, and HNORM(.) denotes the Hankel-norm.
References 
  [1] Latham, G.A. and Anderson, B.D.O.
      Frequency-weighted optimal Hankel-norm approximation of stable
      transfer functions.
      Systems & Control Letters, Vol. 5, pp. 229-236, 1985.

  [2] Glover, K.
      All optimal Hankel norm approximation of linear
      multivariable systems and their L-infinity error bounds.
      Int. J. Control, Vol. 36, pp. 1145-1193, 1984.

  [3] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [4] Varga A.
      Explicit formulas for an efficient implementation
      of the frequency-weighting model reduction approach.
      Proc. 1993 European Control Conference, Groningen, NL,
      pp. 693-696, 1993.
Numerical Aspects 
  The implemented methods rely on an accuracy enhancing square-root
  technique.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09KD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, NVMAX, NWMAX, PMAX
      PARAMETER        ( MMAX = 20, NMAX = 20, NVMAX = 10, NWMAX = 10,
     $                   PMAX = 20 )
      INTEGER          LDA, LDAV, LDAW, LDB, LDBV, LDBW,
     $                 LDC, LDCV, LDCW, LDD, LDDV, LDDW
      PARAMETER        ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX,
     $                   LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX,
     $                   LDC = PMAX, LDCV = PMAX,  LDCW = MMAX,
     $                   LDD = PMAX, LDDV = PMAX,  LDDW = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAX( MMAX, PMAX ) )
      INTEGER          LDW1, LDW2, LDW3, LDW4, LDWORK
      PARAMETER        ( LDW1 = MAX( NVMAX*( NVMAX + 5 ), NVMAX*NMAX +
     $                          MAX( 2*NVMAX, PMAX*NMAX, PMAX*MMAX ) ))
      PARAMETER        ( LDW2 = MAX( NWMAX*( NWMAX + 5 ), NWMAX*NMAX +
     $                          MAX( 2*NWMAX, MMAX*NMAX, PMAX*MMAX ) ))
      PARAMETER        ( LDW3 = NMAX*( 2*NMAX + MAX( NMAX, MMAX, PMAX )
     $                                 + 5 ) + ( NMAX*( NMAX + 1 ) )/2 )
      PARAMETER        ( LDW4 = NMAX*( MMAX + PMAX + 2 ) + 2*MMAX*PMAX +
     $                          MIN( NMAX, MMAX ) +
     $                          MAX( 3*MMAX + 1,
     $                               MIN( NMAX, MMAX ) + PMAX ) )
      PARAMETER        ( LDWORK = MAX( LDW1, LDW2, LDW3, LDW4 ) )
*     .. Local Scalars ..
      LOGICAL          LEFTW, RIGHTW
      DOUBLE PRECISION ALPHA, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NR, NS, NV, NW, P
      CHARACTER*1      DICO, EQUIL, JOB, ORDSEL, WEIGHT
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX),
     $                 B(LDB,MMAX), BV(LDBV,PMAX),  BW(LDBW,MMAX),
     $                 C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX),
     $                 D(LDD,MMAX), DV(LDDV,PMAX),  DW(LDDW,MMAX),
     $                 DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB09KD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NV, NW, NR, ALPHA, TOL1, TOL2,
     $                      JOB, DICO, WEIGHT, EQUIL, ORDSEL
      LEFTW  = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' )
      RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' )
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF( P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               IF( LEFTW .OR. NV.GT.0 ) THEN
                  IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN
                     WRITE ( NOUT, FMT = 99986 ) NV
                  ELSE
                     IF( NV.GT.0 ) THEN
                        READ ( NIN, FMT = * )
     $                    ( ( AV(I,J), J = 1,NV ), I = 1,NV )
                        READ ( NIN, FMT = * )
     $                    ( ( BV(I,J), J = 1,P ), I = 1, NV )
                        READ ( NIN, FMT = * )
     $                    ( ( CV(I,J), J = 1,NV ), I = 1,P )
                     END IF
                     IF( LEFTW )  READ ( NIN, FMT = * )
     $                    ( ( DV(I,J), J = 1,P ), I = 1,P )
                  END IF
               END IF
               IF( RIGHTW ) THEN
                  IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN
                     WRITE ( NOUT, FMT = 99985 ) NW
                  ELSE
                     IF( NW.GT.0 ) THEN
                        READ ( NIN, FMT = * )
     $                    ( ( AW(I,J), J = 1,NW ), I = 1,NW )
                        READ ( NIN, FMT = * )
     $                    ( ( BW(I,J), J = 1,M ), I = 1, NW )
                        READ ( NIN, FMT = * )
     $                    ( ( CW(I,J), J = 1,NW ), I = 1,M )
                     END IF
                     READ ( NIN, FMT = * )
     $                    ( ( DW(I,J), J = 1,M ), I = 1,M )
                  END IF
               END IF
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99984 ) IWARN
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09KD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09KD = ',I2)
99997 FORMAT (/' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable',
     $         ' part are')
99986 FORMAT (/' NV is out of range.',/' NV = ',I5)
99985 FORMAT (/' NW is out of range.',/' NW = ',I5)
99984 FORMAT (' IWARN on exit from AB09KD = ',I2)
      END
Program Data 
 AB09KD EXAMPLE PROGRAM DATA (Continuous system)
  6     1     1     2   0   0   0.0  1.E-1  1.E-14    N   C    L    S     A
   -3.8637   -7.4641   -9.1416   -7.4641   -3.8637   -1.0000
    1.0000         0         0         0         0         0
         0    1.0000         0         0         0         0
         0         0    1.0000         0         0         0
         0         0         0    1.0000         0         0
         0         0         0         0    1.0000         0
         1
         0
         0
         0
         0
         0
         0         0         0         0         0         1
         0
    0.2000   -1.0000
    1.0000         0
     1
     0
   -1.8000         0
     1
Program Results 
 AB09KD EXAMPLE PROGRAM RESULTS


 The order of reduced model =  4

 The Hankel singular values of weighted ALPHA-stable part are
   2.6790   2.1589   0.8424   0.1929   0.0219   0.0011

 The reduced state dynamics matrix Ar is 
  -0.2391   0.3072   1.1630   1.1967
  -2.9709  -0.2391   2.6270   3.1027
   0.0000   0.0000  -0.5137  -1.2842
   0.0000   0.0000   0.1519  -0.5137

 The reduced input/state matrix Br is 
  -1.0497
  -3.7052
   0.8223
   0.7435

 The reduced state/output matrix Cr is 
  -0.4466   0.0143  -0.4780  -0.2013

 The reduced input/output matrix Dr is 
   0.0219

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09KX.html000077500000000000000000000366641201767322700161210ustar00rootroot00000000000000 AB09KX - SLICOT Library Routine Documentation

AB09KX

Stable projection of V G W or conj(V) G conj(W)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct a state-space representation (A,BS,CS,DS) of the
  stable projection of V*G*W or conj(V)*G*conj(W) from the
  state-space representations (A,B,C,D), (AV,BV,CV,DV), and
  (AW,BW,CW,DW) of the transfer-function matrices G, V and W,
  respectively. G is assumed to be a stable transfer-function
  matrix and the state matrix A must be in a real Schur form.
  When computing the stable projection of V*G*W, V and W are assumed
  to be completely unstable transfer-function matrices.
  When computing the stable projection of conj(V)*G*conj(W),
  V and W are assumed to be stable transfer-function matrices.

  For a transfer-function matrix G, conj(G) denotes the conjugate
  of G given by G'(-s) for a continuous-time system or G'(1/z)
  for a discrete-time system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies which projection to be computed as follows:
          = 'N':  compute the stable projection of V*G*W;
          = 'C':  compute the stable projection of
                  conj(V)*G*conj(W).

  DICO    CHARACTER*1
          Specifies the type of the systems as follows:
          = 'C':  G, V and W are continuous-time systems;
          = 'D':  G, V and W are discrete-time systems.

  WEIGHT  CHARACTER*1
          Specifies the type of frequency weighting, as follows:
          = 'N':  no weightings are used (V = I, W = I);
          = 'L':  only left weighting V is used (W = I);
          = 'R':  only right weighting W is used (V = I);
          = 'B':  both left and right weightings V and W are used.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. Also the number of rows of
          the matrix B and the number of columns of the matrix C.
          N represents the dimension of the state vector of the
          system with the transfer-function matrix G.  N >= 0.

  NV      (input) INTEGER
          The order of the matrix AV. Also the number of rows of
          the matrix BV and the number of columns of the matrix CV.
          NV represents the dimension of the state vector of the
          system with the transfer-function matrix V.  NV >= 0.

  NW      (input) INTEGER
          The order of the matrix AW. Also the number of rows of
          the matrix BW and the number of columns of the matrix CW.
          NW represents the dimension of the state vector of the
          system with the transfer-function matrix W.  NW >= 0.

  M       (input) INTEGER
          The number of columns of the matrices B, D, BW and DW
          and number of rows of the matrices CW and DW.  M >= 0.
          M represents the dimension of input vectors of the
          systems with the transfer-function matrices G and W and
          also the dimension of the output vector of the system
          with the transfer-function matrix W.

  P       (input) INTEGER
          The number of rows of the matrices C, D, CV and DV and the
          number of columns of the matrices BV and DV.  P >= 0.
          P represents the dimension of output vectors of the
          systems with the transfer-function matrices G and V and
          also the dimension of the input vector of the system
          with the transfer-function matrix V.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must
          contain the state matrix A of the system with the
          transfer-function matrix G in a real Schur form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B of the system with the
          transfer-function matrix G.
          On exit, if INFO = 0, the leading N-by-M part of this
          array contains the input matrix BS of the stable
          projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W)
          if JOB = 'C'.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C of the system with the
          transfer-function matrix G.
          On exit, if INFO = 0, the leading P-by-N part of this
          array contains the output matrix CS of the stable
          projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W)
          if JOB = 'C'.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the feedthrough matrix D of the system with the
          transfer-function matrix G.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the feedthrough matrix DS of the stable
          projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W)
          if JOB = 'C'.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,P).

  AV      (input/output) DOUBLE PRECISION array, dimension (LDAV,NV)
          On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV
          part of this array must contain the state matrix AV of
          the system with the transfer-function matrix V.
          On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
          NV-by-NV part of this array contains a real Schur form
          of AV.
          AV is not referenced if WEIGHT = 'R' or 'N'.

  LDAV    INTEGER
          The leading dimension of the array AV.
          LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDAV >= 1,         if WEIGHT = 'R' or 'N'.

  BV      (input/output) DOUBLE PRECISION array, dimension (LDBV,P)
          On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part
          of this array must contain the input matrix BV of the
          system with the transfer-function matrix V.
          On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
          NV-by-P part of this array contains the transformed input
          matrix BV.
          BV is not referenced if WEIGHT = 'R' or 'N'.

  LDBV    INTEGER
          The leading dimension of the array BV.
          LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
          LDBV >= 1,         if WEIGHT = 'R' or 'N'.

  CV      (input/output) DOUBLE PRECISION array, dimension (LDCV,NV)
          On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part
          of this array must contain the output matrix CV of the
          system with the transfer-function matrix V.
          On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading
          P-by-NV part of this array contains the transformed output
          matrix CV.
          CV is not referenced if WEIGHT = 'R' or 'N'.

  LDCV    INTEGER
          The leading dimension of the array CV.
          LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B';
          LDCV >= 1,        if WEIGHT = 'R' or 'N'.

  DV      (input) DOUBLE PRECISION array, dimension (LDDV,P)
          If WEIGHT = 'L' or 'B', the leading P-by-P part of this
          array must contain the feedthrough matrix DV of the system
          with the transfer-function matrix V.
          DV is not referenced if WEIGHT = 'R' or 'N'.

  LDDV    INTEGER
          The leading dimension of the array DV.
          LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B';
          LDDV >= 1,        if WEIGHT = 'R' or 'N'.

  AW      (input/output) DOUBLE PRECISION array, dimension (LDAW,NW)
          On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW
          part of this array must contain the state matrix AW of
          the system with the transfer-function matrix W.
          On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
          NW-by-NW part of this array contains a real Schur form
          of AW.
          AW is not referenced if WEIGHT = 'L' or 'N'.

  LDAW    INTEGER
          The leading dimension of the array AW.
          LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDAW >= 1,         if WEIGHT = 'L' or 'N'.

  BW      (input/output) DOUBLE PRECISION array, dimension (LDBW,M)
          On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part
          of this array must contain the input matrix BW of the
          system with the transfer-function matrix W.
          On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
          NW-by-M part of this array contains the transformed input
          matrix BW.
          BW is not referenced if WEIGHT = 'L' or 'N'.

  LDBW    INTEGER
          The leading dimension of the array BW.
          LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
          LDBW >= 1,         if WEIGHT = 'L' or 'N'.

  CW      (input/output) DOUBLE PRECISION array, dimension (LDCW,NW)
          On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part
          of this array must contain the output matrix CW of the
          system with the transfer-function matrix W.
          On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading
          M-by-NW part of this array contains the transformed output
          matrix CW.
          CW is not referenced if WEIGHT = 'L' or 'N'.

  LDCW    INTEGER
          The leading dimension of the array CW.
          LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDCW >= 1,        if WEIGHT = 'L' or 'N'.

  DW      (input) DOUBLE PRECISION array, dimension (LDDW,M)
          If WEIGHT = 'R' or 'B', the leading M-by-M part of this
          array must contain the feedthrough matrix DW of the system
          with the transfer-function matrix W.
          DW is not referenced if WEIGHT = 'L' or 'N'.

  LDDW    INTEGER
          The leading dimension of the array DW.
          LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B';
          LDDW >= 1,        if WEIGHT = 'L' or 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, LDW1, LDW2 ), where
            LDW1 = 0 if WEIGHT = 'R' or 'N' and
            LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) )
                   if WEIGHT = 'L' or WEIGHT = 'B',
            LDW2 = 0 if WEIGHT = 'L' or 'N' and
            LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) )
                   if WEIGHT = 'R' or WEIGHT = 'B',
            a = 0,    b = 0,     if DICO = 'C' or  JOB = 'N',
            a = 2*NV, b = 2*NW,  if DICO = 'D' and JOB = 'C'.
          For good performance, LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          =  0:  no warning;
          =  1:  JOB = 'N' and AV is not completely unstable, or
                 JOB = 'C' and AV is not stable;
          =  2:  JOB = 'N' and AW is not completely unstable, or
                 JOB = 'C' and AW is not stable;
          =  3:  both above conditions appear.
Error Indicator 
  INFO    INTEGER
          =  0:  successful exit;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  the reduction of AV to a real Schur form failed;
          =  2:  the reduction of AW to a real Schur form failed;
          =  3:  the solution of the Sylvester equation failed
                 because the matrices A and AV have common
                 eigenvalues (if JOB = 'N'), or -AV and A have
                 common eigenvalues (if JOB = 'C' and DICO = 'C'),
                 or AV has an eigenvalue which is the reciprocal of
                 one of the eigenvalues of A (if JOB = 'C' and
                 DICO = 'D');
          =  4:  the solution of the Sylvester equation failed
                 because the matrices A and AW have common
                 eigenvalues (if JOB = 'N'), or -AW and A have
                 common eigenvalues (if JOB = 'C' and DICO = 'C'),
                 or AW has an eigenvalue which is the reciprocal of
                 one of the eigenvalues of A (if JOB = 'C' and
                 DICO = 'D').
Method 
  The matrices of the stable projection of V*G*W are computed as

    BS = B*DW + Y*BW,  CS = CV*X + DV*C,  DS = DV*D*DW,

  where X and Y satisfy the continuous-time Sylvester equations

    AV*X - X*A  + BV*C = 0,
    -A*Y + Y*AW + B*CW = 0.

  The matrices of the stable projection of conj(V)*G*conj(W) are
  computed using the explicit formulas established in [1].

  For a continuous-time system, the matrices BS, CS and DS of
  the stable projection are computed as

    BS = B*DW' + Y*CW',  CS = BV'*X + DV'*C,  DS = DV'*D*DW',

  where X and Y satisfy the continuous-time Sylvester equations

    AV'*X + X*A   + CV'*C = 0,
      A*Y + Y*AW' + B*BW' = 0.

  For a discrete-time system, the matrices BS, CS and DS of
  the stable projection are computed as

    BS = B*DW' + A*Y*CW',  CS = BV'*X*A + DV'*C,
    DS = DV'*D*DW' + BV'*X*B*DW' + DV'*C*Y*CW' + BV'*X*A*Y*CW',

  where X and Y satisfy the discrete-time Sylvester equations

    AV'*X*A + CV'*C = X,
    A*Y*AW' + B*BW' = Y.
References 
  [1] Varga A.
      Explicit formulas for an efficient implementation
      of the frequency-weighting model reduction approach.
      Proc. 1993 European Control Conference, Groningen, NL,
      pp. 693-696, 1993.
Numerical Aspects 
  The implemented methods rely on numerically stable algorithms.
Further Comments 
  The matrix A must be stable, but its stability is not checked by
  this routine.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB09MD.html000077500000000000000000000413211201767322700160610ustar00rootroot00000000000000 AB09MD - SLICOT Library Routine Documentation

AB09MD

Balance & Truncate model reduction for the stable part of a system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr) for an original
  state-space representation (A,B,C) by using either the square-root
  or the balancing-free square-root Balance & Truncate (B & T)
  model reduction method for the ALPHA-stable part of the system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root Balance & Truncate method;
          = 'N':  use the balancing-free square-root
                  Balance & Truncate method.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. For a system with NU ALPHA-unstable
          eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
          NR is set as follows: if ORDSEL = 'F', NR is equal to
          NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order
          on entry, and NMIN is the order of a minimal realization
          of the ALPHA-stable part of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable
          part of the given system (computed in HSV(1));
          if ORDSEL = 'A', NR is the sum of NU and the number of
          Hankel singular values greater than
          MAX(TOL,NS*EPS*HNORM(As,Bs,Cs)).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the reduced
          order system.
          The resulting A has a block-diagonal form with two blocks.
          For a system with NU ALPHA-unstable eigenvalues and
          NS ALPHA-stable eigenvalues (NU+NS = N), the leading
          NU-by-NU block contains the unreduced part of A
          corresponding to ALPHA-unstable eigenvalues in an
          upper real Schur form.
          The trailing (NR+NS-N)-by-(NR+NS-N) block contains
          the reduced part of A corresponding to ALPHA-stable
          eigenvalues.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of HSV contain the
          Hankel singular values of the ALPHA-stable part of the
          original system ordered decreasingly.
          HSV(1) is the Hankel norm of the ALPHA-stable subsystem.
Tolerances 
  TOL     DOUBLE PRECISION
          If ORDSEL = 'A', TOL contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL = c*HNORM(As,Bs,Cs), where c is a constant in the
          interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the
          Hankel-norm of the ALPHA-stable part of the given system
          (computed in HSV(1)).
          If TOL <= 0 on entry, the used default value is
          TOL = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of
          ALPHA-stable eigenvalues of A and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          This value is appropriate to compute a minimal realization
          of the ALPHA-stable part.
          If ORDSEL = 'F', the value of TOL is ignored.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = 0, if JOB = 'B';
          LIWORK = N, if JOB = 'N'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                system. In this case, the resulting NR is set equal
                to NSMIN.
          = 2:  with ORDSEL = 'F', the selected order NR is less
                than the order of the ALPHA-unstable part of the
                given system. In this case NR is set equal to the
                order of the ALPHA-unstable part.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the computation of the ordered real Schur form of A
                failed;
          = 2:  the separation of the ALPHA-stable/unstable diagonal
                blocks failed because of very close eigenvalues;
          = 3:  the computation of Hankel singular values failed.
Method 
  Let be the following linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t)                               (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09MD determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t)                             (2)

  such that

  HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  The following procedure is used to reduce a given G:

  1) Decompose additively G as

       G = G1 + G2

     such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and
     G2 = (Au,Bu,Cu) has only ALPHA-unstable poles.

  2) Determine G1r, a reduced order approximation of the
     ALPHA-stable part G1.

  3) Assemble the reduced model Gr as

        Gr = G1r + G2.

  To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root
  Balance & Truncate method of [1] is used, and for an ALPHA-stable
  continuous-time system (DICO = 'C'), the resulting reduced model
  is balanced. For ALPHA-stable systems, setting TOL < 0, the
  routine can be used to compute balanced minimal state-space
  realizations.

  If JOB = 'N', the balancing-free square-root version of the
  Balance & Truncate method [2] is used to reduce the ALPHA-stable
  part G1.
References 
  [1] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [2] Varga A.
      Efficient minimal realization procedure based on balancing.
      Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
      A. El Moudui, P. Borne, S. G. Tzafestas (Eds.),
      Vol. 2, pp. 42-46.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( 2*NMAX +
     $                            MAX( NMAX, MMAX, PMAX ) + 5 ) +
     $                            ( NMAX*( NMAX + 1 ) )/2 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, TOL
      INTEGER          I, INFO, IWARN, J, M, N, NR, NS, P
      CHARACTER*1      DICO, EQUIL, JOB, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL, DICO, JOB, EQUIL,
     $                      ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find a reduced ssr for (A,B,C).
               CALL AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR,
     $                      ALPHA, A, LDA, B, LDB, C, LDC, NS, HSV,
     $                      TOL, IWORK, DWORK, LDWORK, IWARN, INFO)
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS )
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09MD = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are')
      END
Program Data 
 AB09MD EXAMPLE PROGRAM DATA (Continuous system)
  7  2   3   0   -.6D0 1.D-1  C  N  N  A
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
Program Results 
 AB09MD EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values of ALPHA-stable part are
   1.9178   0.8621   0.7666   0.0336   0.0246

 The reduced state dynamics matrix Ar is 
  -0.5181  -1.1084   0.0000   0.0000   0.0000
   8.8157  -0.5181   0.0000   0.0000   0.0000
   0.0000   0.0000   0.5124   0.0000   1.7910
   0.0000   0.0000   0.0000  -1.4460   0.0000
   0.0000   0.0000  -4.2167   0.0000  -2.9900

 The reduced input/state matrix Br is 
  -1.2837   1.2837
  -0.7522   0.7522
  -0.7447  -0.7447
   1.9275  -1.9275
  -3.6872  -3.6872

 The reduced state/output matrix Cr is 
  -0.1380  -0.6445  -0.6582  -0.5771   0.2222
   0.6246   0.0196   0.0000   0.4131   0.0000
   0.1380   0.6445  -0.6582   0.5771   0.2222

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB09ND.html000077500000000000000000000441321201767322700160650ustar00rootroot00000000000000 AB09ND - SLICOT Library Routine Documentation

AB09ND

Singular perturbation approximation based model reduction for the stable part of a system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order model (Ar,Br,Cr,Dr) for an original
  state-space representation (A,B,C,D) by using either the
  square-root or the balancing-free square-root Singular
  Perturbation Approximation (SPA) model reduction method for the
  ALPHA-stable part of the system.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOB     CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root SPA method;
          = 'N':  use the balancing-free square-root SPA method.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NR is fixed;
          = 'A':  the resulting order NR is automatically determined
                  on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NR      (input/output) INTEGER
          On entry with ORDSEL = 'F', NR is the desired order of the
          resulting reduced order system.  0 <= NR <= N.
          On exit, if INFO = 0, NR is the order of the resulting
          reduced order model. For a system with NU ALPHA-unstable
          eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N),
          NR is set as follows: if ORDSEL = 'F', NR is equal to
          NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order
          on entry, and NMIN is the order of a minimal realization
          of the ALPHA-stable part of the given system; NMIN is
          determined as the number of Hankel singular values greater
          than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine
          precision (see LAPACK Library Routine DLAMCH) and
          HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable
          part of the given system (computed in HSV(1));
          if ORDSEL = 'A', NR is the sum of NU and the number of
          Hankel singular values greater than
          MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading NR-by-NR part of this
          array contains the state dynamics matrix Ar of the reduced
          order system.
          The resulting A has a block-diagonal form with two blocks.
          For a system with NU ALPHA-unstable eigenvalues and
          NS ALPHA-stable eigenvalues (NU+NS = N), the leading
          NU-by-NU block contains the unreduced part of A
          corresponding to ALPHA-unstable eigenvalues in an
          upper real Schur form.
          The trailing (NR+NS-N)-by-(NR+NS-N) block contains
          the reduced part of A corresponding to ALPHA-stable
          eigenvalues.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading NR-by-M part of this
          array contains the input/state matrix Br of the reduced
          order system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-NR part of this
          array contains the state/output matrix Cr of the reduced
          order system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original input/output matrix D.
          On exit, if INFO = 0, the leading P-by-M part of this
          array contains the input/output matrix Dr of the reduced
          order system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of HSV contain the
          Hankel singular values of the ALPHA-stable part of the
          original system ordered decreasingly.
          HSV(1) is the Hankel norm of the ALPHA-stable subsystem.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of reduced system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the
          interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the
          Hankel-norm of the ALPHA-stable part of the given system
          (computed in HSV(1)).
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of
          ALPHA-stable eigenvalues of A and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          This value is appropriate to compute a minimal realization
          of the ALPHA-stable part.
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the ALPHA-stable part of the given system.
          The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs).
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0, then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension MAX(1,2*N)
          On exit, if INFO = 0, IWORK(1) contains the order of the
          minimal realization of the ALPHA-stable part of the
          system.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                system. In this case, the resulting NR is set equal
                to NSMIN.
          = 2:  with ORDSEL = 'F', the selected order NR is less
                than the order of the ALPHA-unstable part of the
                given system. In this case NR is set equal to the
                order of the ALPHA-unstable part.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the computation of the ordered real Schur form of A
                failed;
          = 2:  the separation of the ALPHA-stable/unstable diagonal
                blocks failed because of very close eigenvalues;
          = 3:  the computation of Hankel singular values failed.
Method 
  Let be the following linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t)                           (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system. The subroutine AB09ND determines for
  the given system (1), the matrices of a reduced order system

       d[z(t)] = Ar*z(t) + Br*u(t)
       yr(t)   = Cr*z(t) + Dr*u(t)                       (2)

  such that

  HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)],

  where G and Gr are transfer-function matrices of the systems
  (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the
  infinity-norm of G.

  The following procedure is used to reduce a given G:

  1) Decompose additively G as

       G = G1 + G2

     such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and
     G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles.

  2) Determine G1r, a reduced order approximation of the
     ALPHA-stable part G1.

  3) Assemble the reduced model Gr as

        Gr = G1r + G2.

  To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root
  balancing-based SPA method of [1] is used, and for an ALPHA-stable
  system, the resulting reduced model is balanced.

  If JOB = 'N', the balancing-free square-root SPA method of [2]
  is used to reduce the ALPHA-stable part G1.
  By setting TOL1 = TOL2, the routine can be used to compute
  Balance & Truncate approximations as well.
References 
  [1] Liu Y. and Anderson B.D.O.
      Singular Perturbation Approximation of Balanced Systems,
      Int. J. Control, Vol. 50, pp. 1379-1405, 1989.

  [2] Varga A.
      Balancing-free square-root algorithm for computing
      singular perturbation approximations.
      Proc. 30-th IEEE CDC,  Brighton, Dec. 11-13, 1991,
      Vol. 2, pp. 1062-1065.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB09ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                 LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( 2*NMAX +
     $                            MAX( NMAX, MMAX, PMAX ) + 5 ) +
     $                            ( NMAX*( NMAX + 1 ) )/2 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NR, NS, P
      CHARACTER*1      DICO, EQUIL, JOB, ORDSEL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         AB09ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2,
     $                      DICO, JOB, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS )
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB09ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB09ND = ',I2)
99997 FORMAT (' The order of reduced model = ',I2)
99996 FORMAT (/' The reduced state dynamics matrix Ar is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' The reduced input/output matrix Dr is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are')
      END
Program Data 
 AB09ND EXAMPLE PROGRAM DATA (Continuous system)
  7  2   3   0   -.6D0 1.D-1  1.E-14  C  N  N  A
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 AB09ND EXAMPLE PROGRAM RESULTS

 The order of reduced model =  5

 The Hankel singular values of ALPHA-stable part are
   1.9178   0.8621   0.7666   0.0336   0.0246

 The reduced state dynamics matrix Ar is 
  -0.5181  -1.1084   0.0000   0.0000   0.0000
   8.8157  -0.5181   0.0000   0.0000   0.0000
   0.0000   0.0000   0.5847   0.0000   1.9230
   0.0000   0.0000   0.0000  -1.6606   0.0000
   0.0000   0.0000  -4.3823   0.0000  -3.2922

 The reduced input/state matrix Br is 
  -1.2837   1.2837
  -0.7522   0.7522
  -0.6379  -0.6379
   2.0656  -2.0656
  -3.9315  -3.9315

 The reduced state/output matrix Cr is 
  -0.1380  -0.6445  -0.6416  -0.6293   0.2526
   0.6246   0.0196   0.0000   0.4107   0.0000
   0.1380   0.6445  -0.6416   0.6293   0.2526

 The reduced input/output matrix Dr is 
   0.0582  -0.0090
   0.0015  -0.0015
  -0.0090   0.0582

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB13AD.html000077500000000000000000000273161201767322700160500ustar00rootroot00000000000000 AB13AD - SLICOT Library Routine Documentation

AB13AD

Hankel-norm of a stable projection

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Hankel-norm of the ALPHA-stable projection of the
  transfer-function matrix G of the state-space system (A,B,C).
Specification 
      DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A,
     $                                  LDA, B, LDB, C, LDC, NS, HSV,
     $                                  DWORK, LDWORK, INFO )
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(*)
Function Value 
  AB13AD  DOUBLE PRECISION
          The Hankel-norm of the ALPHA-stable projection of G
          (if INFO = 0).
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation, i.e. the
          order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix A. For a continuous-time
          system (DICO = 'C'), ALPHA <= 0 is the boundary value for
          the real parts of eigenvalues, while for a discrete-time
          system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary
          (see the Note below).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, if INFO = 0, the leading N-by-N part of this
          array contains the state dynamics matrix A in a block
          diagonal real Schur form with its eigenvalues reordered
          and separated. The resulting A has two diagonal blocks.
          The leading NS-by-NS part of A has eigenvalues in the
          ALPHA-stability domain and the trailing (N-NS) x (N-NS)
          part has eigenvalues outside the ALPHA-stability domain.
          Note: The ALPHA-stability domain is defined either
                as the open half complex plane left to ALPHA,
                for a continous-time system (DICO = 'C'), or the
                interior of the ALPHA-radius circle centered in the
                origin, for a discrete-time system (DICO = 'D').

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, if INFO = 0, the leading N-by-M part of this
          array contains the input/state matrix B of the transformed
          system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, if INFO = 0, the leading P-by-N part of this
          array contains the state/output matrix C of the
          transformed system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  NS      (output) INTEGER
          The dimension of the ALPHA-stable subsystem.

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, the leading NS elements of HSV contain the
          Hankel singular values of the ALPHA-stable part of the
          original system ordered decreasingly.
          HSV(1) is the Hankel norm of the ALPHA-stable subsystem.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the computation of the ordered real Schur form of A
                failed;
          = 2:  the separation of the ALPHA-stable/unstable diagonal
                blocks failed because of very close eigenvalues;
          = 3:  the computed ALPHA-stable part is just stable,
                having stable eigenvalues very near to the imaginary
                axis (if DICO = 'C') or to the unit circle
                (if DICO = 'D');
          = 4:  the computation of Hankel singular values failed.
Method 
  Let be the following linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t)                               (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system, and let G be the corresponding
  transfer-function matrix. The following procedure is used to
  compute the Hankel-norm of the ALPHA-stable projection of G:

  1) Decompose additively G as

       G = G1 + G2

     such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and
     G2 = (Au,Bu,Cu) has only ALPHA-unstable poles.
     For the computation of the additive decomposition, the
     algorithm presented in [1] is used.

  2) Compute the Hankel-norm of ALPHA-stable projection G1 as the
     the maximum Hankel singular value of the system (As,Bs,Cs).
     The computation of the Hankel singular values is performed
     by using the square-root method of [2].
References 
  [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J.
      Synthesis of positive real multivariable feedback systems,
      Int. J. Control, Vol. 45, pp. 817-842, 1987.

  [2] Tombs, M.S. and Postlethwaite, I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
Numerical Aspects 
  The implemented method relies on a square-root technique.
                                  3
  The algorithms require about 17N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     AB13AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( MAX( NMAX, MMAX, PMAX ) + 5 )
     $                        + ( NMAX*( NMAX + 1 ) )/2 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, SHNORM
      INTEGER          I, INFO, J, M, N, NS, P
      CHARACTER*1      DICO, EQUIL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), HSV(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION AB13AD
      EXTERNAL         AB13AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Compute the Hankel-norm of the ALPHA-stable projection of
*              (A,B,C).
               SHNORM = AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, LDA, B,
     $                          LDB, C, LDC, NS, HSV, DWORK, LDWORK,
     $                          INFO)
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) SHNORM
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS )
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB13AD = ',I2)
99997 FORMAT (' The Hankel-norm of the ALPHA-projection = ',1PD14.5)
99995 FORMAT (20(1X,F8.4))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of ALPHA-projection are')
      END
Program Data 
 AB13AD EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3   0.0  C  N
 -0.04165  0.0000  4.9200  -4.9200  0.0000  0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000  0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000 -0.5450  0.0000  0.0000
  0.0000   0.0000  0.0000   4.9200 -0.04165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000 -5.2100 -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000  3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
Program Results 
 AB13AD EXAMPLE PROGRAM RESULTS

 The Hankel-norm of the ALPHA-projection =    2.51388D+00

 The Hankel singular values of ALPHA-projection are
   2.5139   2.0846   1.9178   0.7666   0.5473   0.0253   0.0246

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB13AX.html000077500000000000000000000120011201767322700160550ustar00rootroot00000000000000 AB13AX - SLICOT Library Routine Documentation

AB13AX

Hankel-norm of a stable system with the state dynamics matrix in real Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Hankel-norm of the transfer-function matrix G of
  a stable state-space system (A,B,C). The state dynamics matrix A
  of the given system is an upper quasi-triangular matrix in
  real Schur form.
Specification 
      DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB,
     $                                  C, LDC, HSV, DWORK, LDWORK,
     $                                  INFO )
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(*)
Function Value 
  AB13AX  DOUBLE PRECISION
          The Hankel-norm of G (if INFO = 0).
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation, i.e. the
          order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state dynamics matrix A in a real Schur canonical form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, this array contains the Hankel singular
          values of the given system ordered decreasingly.
          HSV(1) is the Hankel norm of the given system.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the state matrix A is not stable (if DICO = 'C')
                or not convergent (if DICO = 'D');
          = 2:  the computation of Hankel singular values failed.
Method 
  Let be the stable linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t)                               (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system, and let G be the corresponding
  transfer-function matrix. The Hankel-norm of G is computed as the
  the maximum Hankel singular value of the system (A,B,C).
  The computation of the Hankel singular values is performed
  by using the square-root method of [1].
References 
  [1] Tombs M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
Numerical Aspects 
  The implemented method relies on a square-root technique.
                                  3
  The algorithms require about 17N  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB13BD.html000077500000000000000000000314631201767322700160470ustar00rootroot00000000000000 AB13BD - SLICOT Library Routine Documentation

AB13BD

H2 or L2 norm of a system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the H2 or L2 norm of the transfer-function matrix G
  of the system (A,B,C,D). G must not have poles on the imaginary
  axis, for a continuous-time system, or on the unit circle, for
  a discrete-time system. If the H2-norm is computed, the system
  must be stable.
Specification 
      DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA,
     $                                  B, LDB, C, LDC, D, LDD, NQ, TOL,
     $                                  DWORK, LDWORK, IWARN, INFO)
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(*)
Function Value 
  AB13BD   DOUBLE PRECISION
           The H2-norm of G, if JOBN = 'H', or the L2-norm of G,
           if JOBN = 'L' (if INFO = 0).
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBN    CHARACTER*1
          Specifies the norm to be computed as follows:
          = 'H':  the H2-norm;
          = 'L':  the L2-norm.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A, the number of rows of the
          matrix B, and the number of columns of the matrix C.
          N represents the dimension of the state vector.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrices B and D.
          M represents the dimension of input vector.  M >= 0.

  P       (input) INTEGER
          The number of rows of the matrices C and D.
          P represents the dimension of output vector.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix of the system.
          On exit, the leading NQ-by-NQ part of this array contains
          the state dynamics matrix (in a real Schur form) of the
          numerator factor Q of the right coprime factorization with
          inner denominator of G (see METHOD).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix of the system.
          On exit, the leading NQ-by-M part of this array contains
          the input/state matrix of the numerator factor Q of the
          right coprime factorization with inner denominator of G
          (see METHOD).

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix of the system.
          On exit, the leading P-by-NQ part of this array contains
          the state/output matrix of the numerator factor Q of the
          right coprime factorization with inner denominator of G
          (see METHOD).

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the input/output matrix of the system.
          If DICO = 'C', D must be a null matrix.
          On exit, the leading P-by-M part of this array contains
          the input/output matrix of the numerator factor Q of
          the right coprime factorization with inner denominator
          of G (see METHOD).

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NQ      (output) INTEGER
          The order of the resulting numerator Q of the right
          coprime factorization with inner denominator of G (see
          METHOD).
          Generally, NQ = N - NS, where NS is the number of
          uncontrollable unstable eigenvalues.
Tolerances 
  TOL     DOUBLE PRECISION
          The absolute tolerance level below which the elements of
          B are considered zero (used for controllability tests).
          If the user sets TOL <= 0, then an implicitly computed,
          default tolerance, defined by  TOLDEF = N*EPS*NORM(B),
          is used instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH) and NORM(B) denotes
          the 1-norm of B.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LDWORK >= MAX( 1, M*(N+M) + MAX( N*(N+5), M*(M+2), 4*P ),
                            N*( MAX( N, P ) + 4 ) + MIN( N, P ) ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = K:  K violations of the numerical stability condition
                occured during the assignment of eigenvalues in
                computing the right coprime factorization with inner
                denominator of G (see the SLICOT subroutine SB08DD).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the reordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + B*F)*Z
                along the diagonal (see SLICOT routine SB08DD);
          = 3:  if DICO = 'C' and the matrix A has a controllable
                eigenvalue on the imaginary axis, or DICO = 'D'
                and A has a controllable eigenvalue on the unit
                circle;
          = 4:  the solution of Lyapunov equation failed because
                the equation is singular;
          = 5:  if DICO = 'C' and D is a nonzero matrix;
          = 6:  if JOBN = 'H' and the system is unstable.
Method 
  The subroutine is based on the algorithms proposed in [1] and [2].

  If the given transfer-function matrix G is unstable, then a right
  coprime factorization with inner denominator of G is first
  computed
            -1
     G = Q*R  ,

  where Q and R are stable transfer-function matrices and R is
  inner. If G is stable, then Q = G and R = I.
  Let (AQ,BQ,CQ,DQ) be the state-space representation of Q.

  If DICO = 'C', then the L2-norm of G is computed as

     NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ)),

  where X satisfies the continuous-time Lyapunov equation

     AQ'*X + X*AQ + CQ'*CQ = 0.

  If DICO = 'D', then the l2-norm of G is computed as

     NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ+DQ'*DQ)),

  where X satisfies the discrete-time Lyapunov equation

     AQ'*X*AQ - X + CQ'*CQ = 0.
References 
  [1] Varga A.
      On computing 2-norms of transfer-function matrices.
      Proc. 1992 ACC, Chicago, June 1992.

  [2] Varga A.
      A Schur method for computing coprime factorizations with
      inner denominators and applications in model reduction.
      Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
Numerical Aspects 
                                         3
  The algorithm requires no more than 14N  floating point
  operations.
Further Comments 
  None
Example

Program Text 

*     AB13BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( MMAX*( NMAX + MMAX ) +
     $                                 MAX( NMAX*( NMAX + 5 ),
     $                                      MMAX*( MMAX + 2 ), 4*PMAX ),
     $                                 NMAX*( MAX( NMAX, PMAX ) + 4 ) +
     $                                 MIN( NMAX, PMAX ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION S2NORM, TOL
      INTEGER          I, INFO, IWARN, J, M, N, NQ, P
      CHARACTER*1      DICO, JOBN
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION AB13BD
      EXTERNAL         AB13BD, LSAME
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P )
*              Compute the H2 or L2 norm of (A,B,C,D).
               S2NORM = AB13BD( DICO, JOBN, N, M, P, A, LDA, B, LDB,
     *                          C, LDC, D, LDD, NQ, TOL, DWORK, LDWORK,
     *                          IWARN, INFO)
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( LSAME( JOBN, 'H' ) ) THEN
                     WRITE ( NOUT, FMT = 99997 ) S2NORM
                  ELSE
                     WRITE ( NOUT, FMT = 99996 ) S2NORM
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB13BD = ',I2)
99997 FORMAT (' The H2-norm of the system = ',1PD14.5)
99996 FORMAT (' The L2-norm of the system = ',1PD14.5)
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 AB13BD EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3   1.E-10 C L
 -0.04165  0.0000  4.9200   0.4920  0.0000   0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000   0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000   0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000  0.0545   0.0000  0.0000
  0.0000   0.0000  0.0000  -0.49200 0.004165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000  0.5210  -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000   3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 AB13BD EXAMPLE PROGRAM RESULTS

 The L2-norm of the system =    7.93948D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB13CD.html000077500000000000000000000224261201767322700160470ustar00rootroot00000000000000 AB13CD - SLICOT Library Routine Documentation

AB13CD

H-infinity norm of a continuous-time stable system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the H-infinity norm of the continuous-time stable
  system

                       | A | B |
                G(s) = |---|---| .
                       | C | D |
Specification 
      DOUBLE PRECISION FUNCTION AB13CD( N, M, NP, A, LDA, B, LDB, C,
     $                                  LDC, D, LDD, TOL, IWORK, DWORK,
     $                                  LDWORK, CWORK, LCWORK, BWORK,
     $                                  INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LCWORK, LDD, LDWORK, M, N,
     $                   NP
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      COMPLEX*16         CWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK( * )
      LOGICAL            BWORK( * )
Function Value 
  AB13CD  DOUBLE PRECISION
          If INFO = 0, the H-infinity norm of the system, HNORM,
          i.e., the peak gain of the frequency response (as measured
          by the largest singular value in the MIMO case).
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used to set the accuracy in determining the
          norm.
Workspace 
  IWORK   INTEGER array, dimension N

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK, and DWORK(2) contains the frequency where the
          gain of the frequency response achieves its peak value
          HNORM.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= max(2,4*N*N+2*M*M+3*M*N+M*NP+2*(N+NP)*NP+10*N+
                          6*max(M,NP)).
          For good performance, LDWORK must generally be larger.

  CWORK   COMPLEX*16 array, dimension (LCWORK)
          On exit, if INFO = 0, CWORK(1) contains the optimal value
          of LCWORK.

  LCWORK  INTEGER
          The dimension of the array CWORK.
          LCWORK >= max(1,(N+M)*(N+NP)+3*max(M,NP)).
          For good performance, LCWORK must generally be larger.

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the system is unstable;
          = 2:  the tolerance is too small (the algorithm for
                computing the H-infinity norm did not converge);
          = 3:  errors in computing the eigenvalues of A or of the
                Hamiltonian matrix (the QR algorithm did not
                converge);
          = 4:  errors in computing singular values.
Method 
  The routine implements the method presented in [1].
References 
  [1] Bruinsma, N.A. and Steinbuch, M.
      A fast algorithm to compute the Hinfinity-norm of a transfer
      function matrix.
      Systems & Control Letters, vol. 14, pp. 287-293, 1990.
Numerical Aspects 
  If the algorithm does not converge (INFO = 2), the tolerance must
  be increased.
Further Comments 
  None
Example

Program Text 

*     AB13CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LCWORK
      PARAMETER        ( LCWORK = ( NMAX + MMAX )*( NMAX + PMAX ) +
     $                              3*MAX( MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*NMAX*NMAX + 2*MMAX*MMAX +
     $                            2*PMAX*PMAX + 3*NMAX*MMAX +
     $                            2*NMAX*PMAX + MMAX*PMAX + 10*NMAX +
     $                            6*MAX( MMAX, PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FPEAK, HNORM, TOL
      INTEGER          I, INFO, J, M, N, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK)
      COMPLEX*16       CWORK( LCWORK )
*     .. External Functions ..
      DOUBLE PRECISION AB13CD
      EXTERNAL         AB13CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) TOL
*        Computing the Hinf norm
         HNORM = AB13CD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, TOL,
     $                   IWORK, DWORK, LDWORK, CWORK, LCWORK, BWORK,
     $                   INFO )
*
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99991 ) HNORM
            FPEAK = DWORK(2)
            WRITE ( NOUT, FMT = 99996 )
            WRITE ( NOUT, FMT = 99991 ) FPEAK
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from AB13CD =',I2)
99997 FORMAT (/' The H_infty norm of the system is'/)
99996 FORMAT (/' The peak frequency is'/)
99992 FORMAT (10(1X,F8.4))
99991 FORMAT (D17.10)
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
      END
Program Data 
 AB13CD EXAMPLE PROGRAM DATA
   6     1     1   
   0.0  1.0     0.0   0.0      0.0  0.0
  -0.5 -0.0002  0.0   0.0      0.0  0.0
   0.0  0.0     0.0   1.0      0.0  0.0
   0.0  0.0    -1.0  -0.00002  0.0  0.0
   0.0  0.0     0.0   0.0      0.0  1.0
   0.0  0.0     0.0   0.0     -2.0 -0.000002
   1.0 
   0.0  
   1.0 
   0.0 
   1.0 
   0.0
   1.0  0.0  1.0  0.0  1.0  0.0
   0.0
 0.000000001
Program Results 
 AB13CD EXAMPLE PROGRAM RESULTS


 The H_infty norm of the system is

 0.5000000006D+06

 The peak frequency is

 0.1414213562D+01

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB13DD.html000077500000000000000000000372771201767322700160620ustar00rootroot00000000000000 AB13DD - SLICOT Library Routine Documentation

AB13DD

L-infinity norm of a state space system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the L-infinity norm of a continuous-time or
  discrete-time system, either standard or in the descriptor form,

                                  -1
     G(lambda) = C*( lambda*E - A ) *B + D .

  The norm is finite if and only if the matrix pair (A,E) has no
  eigenvalue on the boundary of the stability domain, i.e., the
  imaginary axis, or the unit circle, respectively. It is assumed
  that the matrix E is nonsingular.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          DICO, EQUIL, JOBD, JOBE
      INTEGER            INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK,
     $                   M, N, P
      DOUBLE PRECISION   TOL
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(  * )
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system, as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBE    CHARACTER*1
          Specifies whether E is a general square or an identity
          matrix, as follows:
          = 'G':  E is a general square matrix;
          = 'I':  E is the identity matrix.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the system (A,E,B,C) or (A,B,C), as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  P       (input) INTEGER
          The row size of the matrix C.  P >= 0.

  FPEAK   (input/output) DOUBLE PRECISION array, dimension (2)
          On entry, this parameter must contain an estimate of the
          frequency where the gain of the frequency response would
          achieve its peak value. Setting FPEAK(2) = 0 indicates an
          infinite frequency. An accurate estimate could reduce the
          number of iterations of the iterative algorithm. If no
          estimate is available, set FPEAK(1) = 0, and FPEAK(2) = 1.
          FPEAK(1) >= 0, FPEAK(2) >= 0.
          On exit, if INFO = 0, this array contains the frequency
          OMEGA, where the gain of the frequency response achieves
          its peak value GPEAK, i.e.,

              || G ( j*OMEGA ) || = GPEAK ,  if DICO = 'C', or

                      j*OMEGA
              || G ( e       ) || = GPEAK ,  if DICO = 'D',

          where OMEGA = FPEAK(1), if FPEAK(2) > 0, and OMEGA is
          infinite, if FPEAK(2) = 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state dynamics matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          If JOBE = 'G', the leading N-by-N part of this array must
          contain the descriptor matrix E of the system.
          If JOBE = 'I', then E is assumed to be the identity
          matrix and is not referenced.

  LDE     INTEGER
          The leading dimension of the array E.
          LDE >= MAX(1,N), if JOBE = 'G';
          LDE >= 1,        if JOBE = 'I'.

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          If JOBD = 'D', the leading P-by-M part of this array must
          contain the direct transmission matrix D.
          The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P), if JOBD = 'D';
          LDD >= 1,        if JOBD = 'Z'.

  GPEAK   (output) DOUBLE PRECISION array, dimension (2)
          The L-infinity norm of the system, i.e., the peak gain
          of the frequency response (as measured by the largest
          singular value in the MIMO case), coded in the same way
          as FPEAK.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used to set the accuracy in determining the
          norm.  0 <= TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= K, where K can be computed using the following
          pseudo-code (or the Fortran code included in the routine)

             d = 6*MIN(P,M);
             c = MAX( 4*MIN(P,M) + MAX(P,M), d );
             if ( MIN(P,M) = 0 ) then
                K = 1;
             else if( N = 0 or B = 0 or C = 0 ) then
                if( JOBD = 'D' ) then
                   K = P*M + c;
                else
                   K = 1;
                end
             else
                if ( DICO = 'D' ) then
                   b = 0;  e = d;
                else
                   b = N*(N+M);  e = c;
                   if ( JOBD = Z' ) then  b = b + P*M;  end
                end
                if ( JOBD = 'D' ) then
                   r = P*M;
                   if ( JOBE = 'I', DICO = 'C',
                        N > 0, B <> 0, C <> 0 ) then
                      K = P*P + M*M;
                      r = r + N*(P+M);
                   else
                      K = 0;
                   end
                   K = K + r + c;  r = r + MIN(P,M);
                else
                   r = 0;  K = 0;
                end
                r = r + N*(N+P+M);
                if ( JOBE = 'G' ) then
                   r = r + N*N;
                   if ( EQUIL = 'S' ) then
                      K = MAX( K, r + 9*N );
                   end
                   K = MAX( K, r + 4*N + MAX( M, 2*N*N, N+b+e ) );
                else
                   K = MAX( K, r + N +
                               MAX( M, P, N*N+2*N, 3*N+b+e ) );
                end
                w = 0;
                if ( JOBE = 'I', DICO = 'C' ) then
                   w = r + 4*N*N + 11*N;
                   if ( JOBD = 'D' ) then
                      w = w + MAX(M,P) + N*(P+M);
                   end
                end
                if ( JOBE = 'E' or DICO = 'D' or JOBD = 'D' ) then
                   w = MAX( w, r + 6*N + (2*N+P+M)*(2*N+P+M) +
                            MAX( 2*(N+P+M), 8*N*N + 16*N ) );
                end
                K = MAX( 1, K, w, r + 2*N + e );
             end

          For good performance, LDWORK must generally be larger.

          An easily computable upper bound is

          K = MAX( 1, 15*N*N + P*P + M*M + (6*N+3)*(P+M) + 4*P*M +
                         N*M + 22*N + 7*MIN(P,M) ).

          The smallest workspace is obtained for DICO = 'C',
          JOBE = 'I', and JOBD = 'Z', namely

          K = MAX( 1, N*N + N*P + N*M + N +
                      MAX( N*N + N*M + P*M + 3*N + c,
                           4*N*N + 10*N ) ).

          for which an upper bound is

          K = MAX( 1, 6*N*N + N*P + 2*N*M + P*M + 11*N + MAX(P,M) +
                      6*MIN(P,M) ).

  CWORK   COMPLEX*16 array, dimension (LCWORK)
          On exit, if INFO = 0, CWORK(1) contains the optimal
          LCWORK.

  LCWORK  INTEGER
          The dimension of the array CWORK.
          LCWORK >= 1,  if N = 0, or B = 0, or C = 0;
          LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)),
                        otherwise.
          For good performance, LCWORK must generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the matrix E is (numerically) singular;
          = 2:  the (periodic) QR (or QZ) algorithm for computing
                eigenvalues did not converge;
          = 3:  the SVD algorithm for computing singular values did
                not converge;
          = 4:  the tolerance is too small and the algorithm did
                not converge.
Method 
  The routine implements the method presented in [1], with
  extensions and refinements for improving numerical robustness and
  efficiency. Structure-exploiting eigenvalue computations for
  Hamiltonian matrices are used if JOBE = 'I', DICO = 'C', and the
  symmetric matrices to be implicitly inverted are not too ill-
  conditioned. Otherwise, generalized eigenvalue computations are
  used in the iterative algorithm of [1].
References 
  [1] Bruinsma, N.A. and Steinbuch, M.
      A fast algorithm to compute the Hinfinity-norm of a transfer
      function matrix.
      Systems & Control Letters, vol. 14, pp. 287-293, 1990.
Numerical Aspects 
  If the algorithm does not converge in MAXIT = 30 iterations
  (INFO = 4), the tolerance must be increased.
Further Comments 
  If the matrix E is singular, other SLICOT Library routines
  could be used before calling AB13DD, for removing the singular
  part of the system.
Example

Program Text 

*     AB13DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDB, LDC, LDD, LDE
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDE = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LCWORK
      PARAMETER        ( LCWORK = ( NMAX + MMAX )*( NMAX + PMAX ) +
     $                             2*MIN( PMAX, MMAX ) +
     $                             MAX( PMAX, MMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 15*NMAX*NMAX + PMAX*PMAX + MMAX*MMAX +
     $                            ( 6*NMAX + 3 )*( PMAX + MMAX ) +
     $                            4*PMAX*MMAX + NMAX*MMAX + 22*NMAX +
     $                            7*MIN( PMAX, MMAX ) )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )

*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, P
      CHARACTER        DICO, EQUIL, JOBD, JOBE
*     .. Local Arrays ..
      INTEGER          IWORK( LIWORK )
      DOUBLE PRECISION A( LDA, NMAX ), B( LDB, MMAX ),  C( LDC, NMAX ),
     $                 D( LDD, MMAX ), DWORK( LDWORK ), E( LDE, NMAX ),
     $                 FPEAK( 2 ), GPEAK( 2 )
      COMPLEX*16       CWORK( LCWORK )
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB13DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, FPEAK, TOL, DICO, JOBE, EQUIL, JOBD
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) P
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( JOBE, 'G' ) )
     $      READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
         IF ( LSAME( JOBD, 'D' ) )
     $      READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*        Computing the Linf norm.
         CALL 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 )
*
         IF ( INFO.EQ.0 ) THEN
            IF ( GPEAK( 2 ).EQ.ZERO ) THEN
               WRITE ( NOUT, FMT = 99991 )
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               WRITE ( NOUT, FMT = 99995 ) GPEAK( 1 )
            END IF
            IF ( FPEAK( 2 ).EQ.ZERO ) THEN
               WRITE ( NOUT, FMT = 99990 )
            ELSE
               WRITE ( NOUT, FMT = 99996 )
               WRITE ( NOUT, FMT = 99995 ) FPEAK( 1 )
            END IF
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from AB13DD =',I2)
99997 FORMAT (/' The L_infty norm of the system is'/)
99996 FORMAT (/' The peak frequency is'/)
99995 FORMAT (D17.10)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
99991 FORMAT (/' The L_infty norm of the system is infinite')
99990 FORMAT (/' The peak frequency is infinite'/)
      END
Program Data 
 AB13CD EXAMPLE PROGRAM DATA
   6     1     1     0.0     1.0   0.000000001     C     I     N     D   
   0.0  1.0     0.0   0.0      0.0  0.0
  -0.5 -0.0002  0.0   0.0      0.0  0.0
   0.0  0.0     0.0   1.0      0.0  0.0
   0.0  0.0    -1.0  -0.00002  0.0  0.0
   0.0  0.0     0.0   0.0      0.0  1.0
   0.0  0.0     0.0   0.0     -2.0 -0.000002
   1.0 
   0.0  
   1.0 
   0.0 
   1.0 
   0.0
   1.0  0.0  1.0  0.0  1.0  0.0
   0.0
Program Results 
 AB13DD EXAMPLE PROGRAM RESULTS


 The L_infty norm of the system is

 0.5000000001D+06

 The peak frequency is

 0.1414213562D+01

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB13DX.html000077500000000000000000000222101201767322700160630ustar00rootroot00000000000000 AB13DX - SLICOT Library Routine Documentation

AB13DX

Maximum singular value of a transfer-function matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the maximum singular value of a given continuous-time
  or discrete-time transfer-function matrix, either standard or in
  the descriptor form,

                                  -1
     G(lambda) = C*( lambda*E - A ) *B + D ,

  for a given complex value lambda, where lambda = j*omega, in the
  continuous-time case, and lambda = exp(j*omega), in the
  discrete-time case. The matrices A, E, B, C, and D are real
  matrices of appropriate dimensions. Matrix A must be in an upper
  Hessenberg form, and if JOBE ='G', the matrix E must be upper
  triangular. The matrices B and C must correspond to the system
  in (generalized) Hessenberg form.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          DICO, JOBD, JOBE
      INTEGER            INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK,
     $                   M, N, P
      DOUBLE PRECISION   OMEGA
C     .. Array Arguments ..
      COMPLEX*16         CWORK(  * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK(  * ), E( LDE, * )
      INTEGER            IWORK(  * )
Function Value 
  AB13DX   DOUBLE PRECISION
           The maximum singular value of G(lambda).
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system, as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBE    CHARACTER*1
          Specifies whether E is an upper triangular or an identity
          matrix, as follows:
          = 'G':  E is a general upper triangular matrix;
          = 'I':  E is the identity matrix.

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  P       (input) INTEGER
          The row size of the matrix C.  P >= 0.

  OMEGA   (input) DOUBLE PRECISION
          The frequency value for which the calculations should be
          done.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N upper Hessenberg part of this
          array must contain the state dynamics matrix A in upper
          Hessenberg form. The elements below the subdiagonal are
          not referenced.
          On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0,
          and C <> 0, the leading N-by-N upper Hessenberg part of
          this array contains the factors L and U from the LU
          factorization of A (A = P*L*U); the unit diagonal elements
          of L are not stored, L is lower bidiagonal, and P is
          stored in IWORK (see SLICOT Library routine MB02SD).
          Otherwise, this array is unchanged on exit.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          If JOBE = 'G', the leading N-by-N upper triangular part of
          this array must contain the upper triangular descriptor
          matrix E of the system. The elements of the strict lower
          triangular part of this array are not referenced.
          If JOBE = 'I', then E is assumed to be the identity
          matrix and is not referenced.

  LDE     INTEGER
          The leading dimension of the array E.
          LDE >= MAX(1,N), if JOBE = 'G';
          LDE >= 1,        if JOBE = 'I'.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the system input matrix B.
          On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0,
          C <> 0, and INFO = 0 or N+1, the leading N-by-M part of
          this array contains the solution of the system A*X = B.
          Otherwise, this array is unchanged on exit.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, if JOBD = 'D', the leading P-by-M part of this
          array must contain the direct transmission matrix D.
          On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D',
          or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or
          N+1), the contents of this array is destroyed.
          Otherwise, this array is unchanged on exit.
          This array is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P), if JOBD = 'D';
          LDD >= 1,        if JOBD = 'Z'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK), where
          LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0;
          LIWORK = 0, otherwise.
          This array contains the pivot indices in the LU
          factorization of the matrix lambda*E - A; for 1 <= i <= N,
          row i of the matrix was interchanged with row IWORK(i).

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the
          singular values of G(lambda), except for the first one,
          which is returned in the function value AB13DX.
          If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last
          MIN(P,M)-1 zero singular values of G(lambda) are not
          stored in DWORK(2), ..., DWORK(MIN(P,M)).

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= MAX(1, LDW1 + LDW2 ),
          LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0,
                         DICO = 'C', and JOBD = 'Z';
          LDW1 = 0,   otherwise;
          LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)),
                      if (N = 0, or B = 0, or C = 0) and JOBD = 'D',
                      or (N > 0, B <> 0, C <> 0, OMEGA = 0, and
                          DICO = 'C');
          LDW2 = 0,   if (N = 0, or B = 0, or C = 0) and JOBD = 'Z',
                      or MIN(P,M) = 0;
          LDW2 = 6*MIN(P,M), otherwise.
          For good performance, LDWORK must generally be larger.

  CWORK   COMPLEX*16 array, dimension (LCWORK)
          On exit, if INFO = 0, CWORK(1) contains the optimal
          LCWORK.

  LCWORK  INTEGER
          The dimension of the array CWORK.
          LCWORK >= 1, if N = 0, or B = 0, or C = 0, or (OMEGA = 0
                          and DICO = 'C') or MIN(P,M) = 0;
          LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)),
                       otherwise.
          For good performance, LCWORK must generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, U(i,i) is exactly zero; the LU
                factorization of the matrix lambda*E - A has been
                completed, but the factor U is exactly singular,
                i.e., the matrix lambda*E - A is exactly singular;
          = N+1:  the SVD algorithm for computing singular values
                did not converge.
Method 
  The routine implements standard linear algebra calculations,
  taking problem structure into account. LAPACK Library routines
  DGESVD and ZGESVD are used for finding the singular values.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AB13ED.html000077500000000000000000000207001201767322700160420ustar00rootroot00000000000000 AB13ED - SLICOT Library Routine Documentation

AB13ED

Estimating the distance from a real matrix to the nearest complex matrix with an eigenvalue on the imaginary axis, using bisection

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate beta(A), the 2-norm distance from a real matrix A to
  the nearest complex matrix with an eigenvalue on the imaginary
  axis. The estimate is given as

         LOW <= beta(A) <= HIGH,

  where either

         (1 + TOL) * LOW >= HIGH,

  or

         LOW = 0   and   HIGH = delta,

  and delta is a small number approximately equal to the square root
  of machine precision times the Frobenius norm (Euclidean norm)
  of A. If A is stable in the sense that all eigenvalues of A lie
  in the open left half complex plane, then beta(A) is the distance
  to the nearest unstable complex matrix, i.e., the complex
  stability radius.
Specification 
      SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  HIGH, LOW, TOL
      INTEGER           INFO, LDA, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  LOW     (output) DOUBLE PRECISION
          A lower bound for beta(A).

  HIGH    (output) DOUBLE PRECISION
          An upper bound for beta(A).
Tolerances 
  TOL     DOUBLE PRECISION
          Specifies the accuracy with which LOW and HIGH approximate
          beta(A). If the user sets TOL to be less than SQRT(EPS),
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH), then the tolerance is taken to be
          SQRT(EPS).
          The recommended value is TOL = 9, which gives an estimate
          of beta(A) correct to within an order of magnitude.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, 3*N*(N+1) ).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the QR algorithm (LAPACK Library routine DHSEQR)
                fails to converge; this error is very rare.
Method 
  Let beta(A) be the 2-norm distance from a real matrix A to the
  nearest complex matrix with an eigenvalue on the imaginary axis.
  It is known that beta(A) = minimum of the smallest singular
  value of (A - jwI), where I is the identity matrix and j**2 = -1,
  and the minimum is taken over all real w.
  The algorithm computes a lower bound LOW and an upper bound HIGH
  for beta(A) by a bisection method in the following way. Given a
  non-negative real number sigma, the Hamiltonian matrix H(sigma)
  is constructed:

                    |   A      -sigma*I |     | A   G  |
        H(sigma) =  |                   | :=  |        | .
                    | sigma*I    -A'    |     | F  -A' |

  It can be shown [1] that H(sigma) has an eigenvalue whose real
  part is zero if and only if sigma >= beta. Any lower and upper
  bounds on beta(A) can be improved by choosing a number between
  them and checking to see if H(sigma) has an eigenvalue with zero
  real part.  This decision is made by computing the eigenvalues of
  H(sigma) using the square reduced algorithm of Van Loan [2].
References 
  [1] Byers, R.
      A bisection method for measuring the distance of a stable
      matrix to the unstable matrices.
      SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988.

  [2] Van Loan, C.F.
      A symplectic method for approximating all the eigenvalues of a
      Hamiltonian matrix.
      Linear Algebra and its Applications, Vol 61, 233-251, 1984.
Numerical Aspects 
  Due to rounding errors the computed values of LOW and HIGH can be
  proven to satisfy

         LOW - p(n) * sqrt(e) * norm(A) <= beta(A)
  and
         beta(A) <= HIGH + p(n) * sqrt(e) * norm(A),

  where p(n) is a modest polynomial of degree 3, e is the machine
  precision and norm(A) is the Frobenius norm of A, see [1].
  The recommended value for TOL is 9 which gives an estimate of
  beta(A) correct to within an order of magnitude.
  AB13ED requires approximately 38*N**3 flops for TOL = 9.
Further Comments 
  None
Example

Program Text 

*     AB13ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX*( NMAX + 1 ) )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      DOUBLE PRECISION HIGH, LOW, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         AB13ED, UD01MD
*     ..
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
*     Read N, TOL and next A (row wise).
      READ ( NIN, FMT = * ) N, TOL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         DO 10 I = 1, N
            READ ( NIN, FMT = * ) ( A(I,J), J = 1, N )
   10    CONTINUE
*
         WRITE ( NOUT, FMT = 99998 ) N, TOL
         CALL UD01MD( N, N, 5, NOUT, A, LDA, 'Matrix A', INFO )
*
         CALL AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 ) LOW, HIGH
         ELSE
            WRITE ( NOUT, FMT = 99996 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13ED EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' N =', I4, 2X, 'TOL =', D10.3)
99997 FORMAT (' LOW  =', D18.11, /' HIGH =', D18.11)
99996 FORMAT (' INFO on exit from AB13ED = ', I2)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
AB13ED EXAMPLE PROGRAM DATA
5, 9.0D0
1.0D-01  1.0D-00  0.0D-00  0.0D-00  0.0D-00
0.0D-00  1.0D-01  1.0D-00  0.0D-00  0.0D-00
0.0D-00  0.0D-00  1.0D-01  1.0D-00  0.0D-00
0.0D-00  0.0D-00  0.0D-00  1.0D-01  1.0D-00
0.0D-00  0.0D-00  0.0D-00  0.0D-00  1.0D-01
Program Results 
 AB13ED EXAMPLE PROGRAM RESULTS

 N =   5  TOL = 0.900D+01
 Matrix A ( 5X 5)

            1              2              3              4              5
  1    0.1000000D+00  0.1000000D+01  0.0000000D+00  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.1000000D+00  0.1000000D+01  0.0000000D+00  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00  0.1000000D+00  0.1000000D+01  0.0000000D+00
  4    0.0000000D+00  0.0000000D+00  0.0000000D+00  0.1000000D+00  0.1000000D+01
  5    0.0000000D+00  0.0000000D+00  0.0000000D+00  0.0000000D+00  0.1000000D+00
 
 LOW  = 0.20929379255D-05
 HIGH = 0.20793050504D-04

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB13FD.html000077500000000000000000000212121201767322700160420ustar00rootroot00000000000000 AB13FD - SLICOT Library Routine Documentation

AB13FD

Computing the distance from a real matrix to the nearest complex matrix with an eigenvalue on the imaginary axis, using SVD

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute beta(A), the 2-norm distance from a real matrix A to
  the nearest complex matrix with an eigenvalue on the imaginary
  axis. If A is stable in the sense that all eigenvalues of A lie
  in the open left half complex plane, then beta(A) is the complex
  stability radius, i.e., the distance to the nearest unstable
  complex matrix. The value of beta(A) is the minimum of the
  smallest singular value of (A - jwI), taken over all real w.
  The value of w corresponding to the minimum is also computed.
Specification 
      SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK,
     $                   CWORK, LCWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  BETA    (output) DOUBLE PRECISION
          The computed value of beta(A), which actually is an upper
          bound.

  OMEGA   (output) DOUBLE PRECISION
          The value of w such that the smallest singular value of
          (A - jwI) equals beta(A).
Tolerances 
  TOL     DOUBLE PRECISION
          Specifies the accuracy with which beta(A) is to be
          calculated. (See the Numerical Aspects section below.)
          If the user sets TOL to be less than EPS, where EPS is the
          machine precision (see LAPACK Library Routine DLAMCH),
          then the tolerance is taken to be EPS.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.
          If DWORK(1) is not needed, the first 2*N*N entries of
          DWORK may overlay CWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, 3*N*(N+2) ).
          For optimum performance LDWORK should be larger.

  CWORK   COMPLEX*16 array, dimension (LCWORK)
          On exit, if INFO = 0, CWORK(1) returns the optimal value
          of LCWORK.
          If CWORK(1) is not needed, the first N*N entries of
          CWORK may overlay DWORK.

  LCWORK  INTEGER
          The length of the array CWORK.
          LCWORK >= MAX( 1, N*(N+3) ).
          For optimum performance LCWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the routine fails to compute beta(A) within the
                specified tolerance. Nevertheless, the returned
                value is an upper bound on beta(A);
          = 2:  either the QR or SVD algorithm (LAPACK Library
                routines DHSEQR, DGESVD or ZGESVD) fails to
                converge; this error is very rare.
Method 
  AB13FD combines the methods of [1] and [2] into a provably
  reliable, quadratically convergent algorithm. It uses the simple
  bisection strategy of [1] to find an interval which contains
  beta(A), and then switches to the modified bisection strategy of
  [2] which converges quadratically to a minimizer. Note that the
  efficiency of the strategy degrades if there are several local
  minima that are near or equal the global minimum.
References 
  [1] Byers, R.
      A bisection method for measuring the distance of a stable
      matrix to the unstable matrices.
      SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988.

  [2] Boyd, S. and Balakrishnan, K.
      A regularity result for the singular values of a transfer
      matrix and a quadratically convergent algorithm for computing
      its L-infinity norm.
      Systems and Control Letters, Vol. 15, pp. 1-7, 1990.
Numerical Aspects 
  In the presence of rounding errors, the computed function value
  BETA  satisfies

        beta(A) <= BETA + epsilon,

        BETA/(1+TOL) - delta <= MAX(beta(A), SQRT(2*N*EPS)*norm(A)),

  where norm(A) is the Frobenius norm of A,

        epsilon = p(N) * EPS * norm(A),
  and
        delta   = p(N) * SQRT(EPS) * norm(A),

  and p(N) is a low degree polynomial. It is recommended to choose
  TOL greater than SQRT(EPS). Although rounding errors can cause
  AB13FD to fail for smaller values of TOL, nevertheless, it usually
  succeeds. Regardless of success or failure, the first inequality
  holds.
Further Comments 
  None
Example

Program Text 

*     AB13FD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX*( NMAX + 2 ) )
      INTEGER          LCWORK
      PARAMETER        ( LCWORK = NMAX*( NMAX + 3 ) )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      DOUBLE PRECISION BETA, OMEGA, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK)
      COMPLEX*16       CWORK(LCWORK)
*     .. External Subroutines ..
      EXTERNAL         AB13FD, UD01MD
*     ..
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
*     Read N, TOL and next A (row wise).
      READ ( NIN, FMT = * ) N, TOL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         DO 10 I = 1, N
            READ ( NIN, FMT = * ) ( A(I,J), J = 1, N )
   10    CONTINUE
*
         WRITE ( NOUT, FMT = 99998 ) N, TOL
         CALL UD01MD( N, N, 5, NOUT, A, LDA, 'A', INFO )
*
         CALL AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, CWORK,
     $                LCWORK, INFO )
*
         IF ( INFO.NE.0 )
     $      WRITE ( NOUT, FMT = 99996 ) INFO
         WRITE ( NOUT, FMT = 99997 ) BETA, OMEGA
      END IF
*
99999 FORMAT (' AB13FD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' N =', I2, 3X, 'TOL =', D10.3)
99997 FORMAT (' Stability radius :', D18.11, /
     *        ' Minimizing omega :', D18.11)
99996 FORMAT (' INFO on exit from AB13FD = ', I2)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
AB13FD EXAMPLE PROGRAM DATA
4   0.0D-00   0.0D-00
     246.500        242.500        202.500       -197.500
    -252.500       -248.500       -207.500        202.500
    -302.500       -297.500       -248.500        242.500
    -307.500       -302.500       -252.500        246.500
Program Results 
 AB13FD EXAMPLE PROGRAM RESULTS

 N = 4   TOL = 0.000D+00
 A ( 4X 4)

            1              2              3              4
  1    0.2465000D+03  0.2425000D+03  0.2025000D+03 -0.1975000D+03
  2   -0.2525000D+03 -0.2485000D+03 -0.2075000D+03  0.2025000D+03
  3   -0.3025000D+03 -0.2975000D+03 -0.2485000D+03  0.2425000D+03
  4   -0.3075000D+03 -0.3025000D+03 -0.2525000D+03  0.2465000D+03
 
 Stability radius : 0.39196472317D-02
 Minimizing omega : 0.98966520430D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB13MD.html000077500000000000000000000227751201767322700160700ustar00rootroot00000000000000 AB13MD - SLICOT Library Routine Documentation

AB13MD

Upper bound on the structured singular value for a square complex matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an upper bound on the structured singular value for a
  given square complex matrix and a given block structure of the
  uncertainty.
Specification 
      SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D,
     $                   G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          FACT
      INTEGER            INFO, LDWORK, LDZ, LZWORK, M, N
      DOUBLE PRECISION   BOUND
C     .. Array Arguments ..
      INTEGER            ITYPE( * ), IWORK( * ), NBLOCK( * )
      COMPLEX*16         Z( LDZ, * ), ZWORK( * )
      DOUBLE PRECISION   D( * ), DWORK( * ), G( * ), X( * )
Arguments

Mode Parameters 

  FACT    CHARACTER*1
          Specifies whether or not an information from the
          previous call is supplied in the vector X.
          = 'F':  On entry, X contains information from the
                  previous call.
          = 'N':  On entry, X does not contain an information from
                  the previous call.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix Z.  N >= 0.

  Z       (input) COMPLEX*16 array, dimension (LDZ,N)
          The leading N-by-N part of this array must contain the
          complex matrix Z for which the upper bound on the
          structured singular value is to be computed.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= max(1,N).

  M       (input) INTEGER
          The number of diagonal blocks in the block structure of
          the uncertainty.  M >= 1.

  NBLOCK  (input) INTEGER array, dimension (M)
          The vector of length M containing the block structure
          of the uncertainty. NBLOCK(I), I = 1:M, is the size of
          each block.

  ITYPE   (input) INTEGER array, dimension (M)
          The vector of length M indicating the type of each block.
          For I = 1:M,
          ITYPE(I) = 1 indicates that the corresponding block is a
                       real block, and
          ITYPE(I) = 2 indicates that the corresponding block is a
                       complex block.
          NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1.

  X       (input/output) DOUBLE PRECISION array, dimension
          ( M + MR - 1 ), where MR is the number of the real blocks.
          On entry, if FACT = 'F' and NBLOCK(1) < N, this array
          must contain information from the previous call to AB13MD.
          If NBLOCK(1) = N, this array is not used.
          On exit, if NBLOCK(1) < N, this array contains information
          that can be used in the next call to AB13MD for a matrix
          close to Z.

  BOUND   (output) DOUBLE PRECISION
          The upper bound on the structured singular value.

  D, G    (output) DOUBLE PRECISION arrays, dimension (N)
          The vectors of length N containing the diagonal entries
          of the diagonal N-by-N matrices D and G, respectively,
          such that the matrix
          Z'*D^2*Z + sqrt(-1)*(G*Z-Z'*G) - BOUND^2*D^2
          is negative semidefinite.
Workspace 
  IWORK   INTEGER array, dimension MAX(4*M-2,N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11.
          For best performance
          LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 6*N + 33*M - 11 +
                    MAX( 5*N,2*N*NB )
          where NB is the optimal blocksize returned by ILAENV.

  ZWORK   COMPLEX*16 array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) contains the optimal value
          of LZWORK.

  LZWORK  INTEGER
          The dimension of the array ZWORK.
          LZWORK >= 6*N*N*M + 12*N*N + 6*M + 6*N - 3.
          For best performance
          LZWORK >= 6*N*N*M + 12*N*N + 6*M + 3*N - 3 +
                    MAX( 3*N,N*NB )
          where NB is the optimal blocksize returned by ILAENV.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the block sizes must be positive integers;
          = 2:  the sum of block sizes must be equal to N;
          = 3:  the size of a real block must be equal to 1;
          = 4:  the block type must be either 1 or 2;
          = 5:  errors in solving linear equations or in matrix
                inversion;
          = 6:  errors in computing eigenvalues or singular values.
Method 
  The routine computes the upper bound proposed in [1].
References 
  [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C.
      Robustness in the presence of mixed parametric uncertainty
      and unmodeled dynamics.
      IEEE Trans. Automatic Control, vol. AC-36, 1991, pp. 25-38.
Numerical Aspects 
  The accuracy and speed of computation depend on the value of
  the internal threshold TOL.
Further Comments 
  None
Example

Program Text 

*     AB13MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 10, MMAX = 10 )
      INTEGER          LDZ
      PARAMETER        ( LDZ = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 4*MMAX-2, NMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*NMAX*NMAX*MMAX - NMAX*NMAX +
     $                            9*MMAX*MMAX + NMAX*MMAX + 11*NMAX +
     $                            33*MMAX - 11 )
      INTEGER          LZWORK
      PARAMETER        ( LZWORK = 6*NMAX*NMAX*MMAX + 12*NMAX*NMAX +
     $                            6*MMAX + 6*NMAX - 3 )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
      DOUBLE PRECISION BOUND
*     .. Local Arrays ..
      INTEGER          ITYPE(MMAX), IWORK(LIWORK), NBLOCK(MMAX)
      DOUBLE PRECISION D(NMAX), DWORK(LDWORK), G(NMAX), X(2*MMAX-1)
      COMPLEX*16       Z(LDZ,NMAX), ZWORK(LZWORK)
*     .. External Subroutines ..
      EXTERNAL         AB13MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE
         READ ( NIN, FMT = * ) ( NBLOCK(I), I = 1, M )
         READ ( NIN, FMT = * ) ( ITYPE(I), I = 1, M )
         READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N )
*        Computing mu.
         CALL AB13MD( 'N', N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, G,
     $               IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO )
*
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99991 ) BOUND
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB13MD =',I2)
99997 FORMAT (' The value of the structured singular value is'/)
99991 FORMAT (D17.10)
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 AB13MD EXAMPLE PROGRAM DATA
   6     5
   1     1     2     1     1
   1     1     2     2     2
   (-1.0D0,6.0D0)  (2.0D0,-3.0D0)  (3.0D0,8.0D0)
   (3.0D0,8.0D0)   (-5.0D0,-9.0D0) (-6.0D0,2.0D0)
   (4.0D0,2.0D0)   (-2.0D0,5.0D0)  (-6.0D0,-7.0D0)
   (-4.0D0,11.0D0) (8.0D0,-7.0D0)  (12.0D0,-1.0D0)
   (5.0D0,-4.0D0)  (-4.0D0,-8.0D0) (1.0D0,-3.0D0)
   (-6.0D0,14.0D0) (2.0D0,-5.0D0)  (4.0D0,16.0D0)
   (-1.0D0,6.0D0)  (2.0D0,-3.0D0)  (3.0D0,8.0D0)
   (3.0D0,8.0D0)   (-5.0D0,-9.0D0) (-6.0D0,2.0D0)
   (4.0D0,2.0D0)   (-2.0D0,5.0D0)  (-6.0D0,-7.0D0)
   (-4.0D0,11.0D0) (8.0D0,-7.0D0)  (12.0D0,-1.0D0)
   (5.0D0,-4.0D0)  (-4.0D0,-8.0D0) (1.0D0,-3.0D0)
   (-6.0D0,14.0D0) (2.0D0,-5.0D0)  (4.0D0,16.0D0)
Program Results 
 AB13MD EXAMPLE PROGRAM RESULTS

 The value of the structured singular value is

 0.4174753408D+02

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AB8NXZ.html000077500000000000000000000152261201767322700161640ustar00rootroot00000000000000 AB8NXZ - SLICOT Library Routine Documentation

AB8NXZ

Construction of a reduced system (Ar,Br,Cr,Dr), having the same transmission zeros as (A,B,C,D), but with Dr of full row rank (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To extract from the (N+P)-by-(M+N) system
               ( B  A )
               ( D  C )
  an (NU+MU)-by-(M+NU) "reduced" system
               ( B' A')
               ( D' C')
  having the same transmission zeros but with D' of full row rank.
Specification 
      SUBROUTINE AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD,
     $                   NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK,
     $                   DWORK, ZWORK, LZWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of state variables.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  RO      (input/output) INTEGER
          On entry,
          = P     for the original system;
          = MAX(P-M, 0) for the pertransposed system.
          On exit, RO contains the last computed rank.

  SIGMA   (input/output) INTEGER
          On entry,
          = 0  for the original system;
          = M  for the pertransposed system.
          On exit, SIGMA contains the last computed value sigma in
          the algorithm.

  SVLMAX  (input) DOUBLE PRECISION
          During each reduction step, the rank-revealing QR
          factorization of a matrix stops when the estimated minimum
          singular value is smaller than TOL * MAX(SVLMAX,EMSV),
          where EMSV is the estimated maximum singular value.
          SVLMAX >= 0.

  ABCD    (input/output) COMPLEX*16 array, dimension (LDABCD,M+N)
          On entry, the leading (N+P)-by-(M+N) part of this array
          must contain the compound input matrix of the system.
          On exit, the leading (NU+MU)-by-(M+NU) part of this array
          contains the reduced compound input matrix of the system.

  LDABCD  INTEGER
          The leading dimension of array ABCD.
          LDABCD >= MAX(1,N+P).

  NINFZ   (input/output) INTEGER
          On entry, the currently computed number of infinite zeros.
          It should be initialized to zero on the first call.
          NINFZ >= 0.
          On exit, the number of infinite zeros.

  INFZ    (input/output) INTEGER array, dimension (N)
          On entry, INFZ(i) must contain the current number of
          infinite zeros of degree i, where i = 1,2,...,N, found in
          the previous call(s) of the routine. It should be
          initialized to zero on the first call.
          On exit, INFZ(i) contains the number of infinite zeros of
          degree i, where i = 1,2,...,N.

  KRONL   (input/output) INTEGER array, dimension (N+1)
          On entry, this array must contain the currently computed
          left Kronecker (row) indices found in the previous call(s)
          of the routine. It should be initialized to zero on the
          first call.
          On exit, the leading NKROL elements of this array contain
          the left Kronecker (row) indices.

  MU      (output) INTEGER
          The normal rank of the transfer function matrix of the
          original system.

  NU      (output) INTEGER
          The dimension of the reduced system matrix and the number
          of (finite) invariant zeros if D' is invertible.

  NKROL   (output) INTEGER
          The number of left Kronecker indices.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          NOTE that when SVLMAX > 0, the estimated ranks could be
          less than those defined above (see SVLMAX).
Workspace 
  IWORK   INTEGER array, dimension (MAX(M,P))

  DWORK   DOUBLE PRECISION array, dimension (2*MAX(M,P))

  ZWORK   COMPLEX*16 array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) returns the optimal value
          of LZWORK.

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N),
                            MIN(P,N) + MAX(3*P-1,N+P,N+M) ).
          For optimum performance LZWORK should be larger.

          If LZWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          ZWORK array, returns this value as the first entry of
          the ZWORK array, and no error message related to LZWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Svaricek, F.
      Computation of the Structural Invariants of Linear
      Multivariable Systems with an Extended Version of
      the Program ZEROS.
      System & Control Letters, 6, pp. 261-266, 1985.

  [2] Emami-Naeini, A. and Van Dooren, P.
      Computation of Zeros of Linear Multivariable Systems.
      Automatica, 18, pp. 415-430, 1982.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AG07BD.html000077500000000000000000000146571201767322700160650ustar00rootroot00000000000000 AG07BD - SLICOT Library Routine Documentation

AG07BD

Descriptor inverse of a state-space or descriptor representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the inverse (Ai-lambda*Ei,Bi,Ci,Di) of a given
  descriptor system (A-lambda*E,B,C,D).
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOBE    CHARACTER*1
          Specifies whether E is a general square or an identity
          matrix as follows:
          = 'G':  E is a general square matrix;
          = 'I':  E is the identity matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the square matrices A and E;
          also the number of rows of matrix B and the number of
          columns of matrix C.  N >= 0.

  M       (input) INTEGER
          The number of system inputs and outputs, i.e., the number
          of columns of matrices B and D and the number of rows of
          matrices C and D.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the original system.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          If JOBE = 'G', the leading N-by-N part of this array must
          contain the descriptor matrix E of the original system.
          If JOBE = 'I', then E is assumed to be the identity
          matrix and is not referenced.

  LDE     INTEGER
          The leading dimension of the array E.
          LDE >= MAX(1,N), if JOBE = 'G';
          LDE >= 1,        if JOBE = 'I'.

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input matrix B of the original system.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading M-by-N part of this array must contain the
          output matrix C of the original system.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,M).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading M-by-M part of this array must contain the
          feedthrough matrix D of the original system.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,M).

  AI      (output) DOUBLE PRECISION array, dimension (LDAI,N+M)
          The leading (N+M)-by-(N+M) part of this array contains
          the state matrix Ai of the inverse system.
          If LDAI = LDA >= N+M, then AI and A can share the same
          storage locations.

  LDAI    INTEGER
          The leading dimension of the array AI.
          LDAI >= MAX(1,N+M).

  EI      (output) DOUBLE PRECISION array, dimension (LDEI,N+M)
          The leading (N+M)-by-(N+M) part of this array contains
          the descriptor matrix Ei of the inverse system.
          If LDEI = LDE >= N+M, then EI and E can share the same
          storage locations.

  LDEI    INTEGER
          The leading dimension of the array EI.
          LDEI >= MAX(1,N+M).

  BI      (output) DOUBLE PRECISION array, dimension (LDBI,M)
          The leading (N+M)-by-M part of this array contains
          the input matrix Bi of the inverse system.
          If LDBI = LDB >= N+M, then BI and B can share the same
          storage locations.

  LDBI    INTEGER
          The leading dimension of the array BI.
          LDBI >= MAX(1,N+M).

  CI      (output) DOUBLE PRECISION array, dimension (LDCI,N+M)
          The leading M-by-(N+M) part of this array contains
          the output matrix Ci of the inverse system.
          If LDCI = LDC, CI and C can share the same storage
          locations.

  LDCI    INTEGER
          The leading dimension of the array CI.  LDCI >= MAX(1,M).

  DI      (output) DOUBLE PRECISION array, dimension (LDDI,M)
          The leading M-by-M part of this array contains
          the feedthrough matrix Di = 0 of the inverse system.
          DI and D can share the same storage locations.

  LDDI    INTEGER
          The leading dimension of the array DI.  LDDI >= MAX(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrices of the inverse system are computed with the formulas

             ( E  0 )        ( A  B )         (  0 )
        Ei = (      ) , Ai = (      ) ,  Bi = (    ),
             ( 0  0 )        ( C  D )         ( -I )

        Ci = ( 0  I ),  Di = 0.
Further Comments 
  The routine does not perform an invertibility test. This check can
  be performed by using the SLICOT routines AB08NX or AG08BY.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AG08BD.html000077500000000000000000000730661201767322700160650ustar00rootroot00000000000000 AG08BD - SLICOT Library Routine Documentation

AG08BD

Zeros and Kronecker structure of a descriptor system pencil

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To extract from the system pencil

                    ( A-lambda*E B )
        S(lambda) = (              )
                    (      C     D )

  a regular pencil Af-lambda*Ef which has the finite Smith zeros of
  S(lambda) as generalized eigenvalues. The routine also computes
  the orders of the infinite Smith zeros and determines the singular
  and infinite Kronecker structure of system pencil, i.e., the right
  and left Kronecker indices, and the multiplicities of infinite
  eigenvalues.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the system
          matrix as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A of the system.
          On exit, the leading NFZ-by-NFZ part of this array
          contains the matrix Af of the reduced pencil.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E of the system.
          On exit, the leading NFZ-by-NFZ part of this array
          contains the matrix Ef of the reduced pencil.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B of the system.
          On exit, this matrix does not contain useful information.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0;
          LDB >= 1        if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C of the system.
          On exit, this matrix does not contain useful information.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct transmission matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NFZ     (output) INTEGER
          The number of finite zeros.

  NRANK   (output) INTEGER
          The normal rank of the system pencil.

  NIZ     (output) INTEGER
          The number of infinite zeros.

  DINFZ   (output) INTEGER
          The maximal multiplicity of infinite Smith zeros.

  NKROR   (output) INTEGER
          The number of right Kronecker indices.

  NINFE   (output) INTEGER
          The number of elementary infinite blocks.

  NKROL   (output) INTEGER
          The number of left Kronecker indices.

  INFZ    (output) INTEGER array, dimension (N+1)
          The leading DINFZ elements of INFZ contain information
          on the infinite elementary divisors as follows:
          the system has INFZ(i) infinite elementary divisors of
          degree i in the Smith form, where i = 1,2,...,DINFZ.

  KRONR   (output) INTEGER array, dimension (N+M+1)
          The leading NKROR elements of this array contain the
          right Kronecker (column) indices.

  INFE    (output) INTEGER array, dimension (1+MIN(L+P,N+M))
          The leading NINFE elements of INFE contain the
          multiplicities of infinite eigenvalues.

  KRONL   (output) INTEGER array, dimension (L+P+1)
          The leading NKROL elements of this array contain the
          left Kronecker (row) indices.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL <= 0, then default tolerances are
          used instead, as follows: TOLDEF = L*N*EPS in TG01FD
          (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS
          in the rest, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH).  TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension N+max(1,M)
          On output, IWORK(1) contains the normal rank of the
          transfer function matrix.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( 4*(L+N), LDW ), if EQUIL = 'S',
          LDWORK >= LDW,                 if EQUIL = 'N', where
          LDW = max(L+P,M+N)*(M+N) + max(1,5*max(L+P,M+N)).
          For optimum performance LDWORK should be larger.

          If LDWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          DWORK array, returns this value as the first entry of
          the DWORK array, and no error message related to LDWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine extracts from the system matrix of a descriptor
  system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which
  has the finite zeros of the system as generalized eigenvalues.
  The procedure has the following main computational steps:

     (a) construct the (L+P)-by-(N+M) system pencil

          S(lambda) = ( B  A )-lambda*( 0  E );
                      ( D  C )        ( 0  0 )

     (b) reduce S(lambda) to S1(lambda) with the same finite
         zeros and right Kronecker structure but with E
         upper triangular and nonsingular;

     (c) reduce S1(lambda) to S2(lambda) with the same finite
         zeros and right Kronecker structure but with D of
         full row rank;

     (d) reduce S2(lambda) to S3(lambda) with the same finite zeros
         and with D square invertible;

     (e) perform a unitary transformation on the columns of

         S3(lambda) = (A-lambda*E   B) in order to reduce it to
                      (     C       D)

         (Af-lambda*Ef   X), with Y and Ef square invertible;
         (     0         Y)

     (f) compute the right and left Kronecker indices of the system
         matrix, which together with the multiplicities of the
         finite and infinite eigenvalues constitute the
         complete set of structural invariants under strict
         equivalence transformations of a linear system.
References 
  [1] P. Misra, P. Van Dooren and A. Varga.
      Computation of structural invariants of generalized
      state-space systems.
      Automatica, 30, pp. 1921-1936, 1994.
Numerical Aspects 
  The algorithm is backward stable (see [1]).
Further Comments 
  In order to compute the finite Smith zeros of the system
  explicitly, a call to this routine may be followed by a
  call to the LAPACK Library routines DGEGV or DGGEV.
Example

Program Text 

*     AG08BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, MMAX, NMAX, PMAX
      PARAMETER        ( LMAX = 20, MMAX = 20, NMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDAEMX, LDB, LDC, LDD, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDD = PMAX, LDE = LMAX, LDQ = 1, LDZ = 1,
     $                   LDAEMX = MAX( PMAX + LMAX, NMAX + MMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 4*( LMAX + NMAX ),  8*NMAX,
     $                                 LDAEMX*LDAEMX +
     $                                 MAX( 1, 5*LDAEMX ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          DINFZ, I, INFO, J, L, M, N, NFZ, NINFE, NIZ,
     $                 NKROL, NKROR, NRANK, P
      CHARACTER*1      EQUIL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALFI(NMAX), ALFR(NMAX),
     $                 ASAVE(LDA,NMAX), B(LDB,MMAX), BETA(NMAX),
     $                 BSAVE(LDB,MMAX), C(LDC,NMAX), CSAVE(LDC,NMAX),
     $                 D(LDD,MMAX), DSAVE(LDD,MMAX), DWORK(LDWORK),
     $                 E(LDE,NMAX), ESAVE(LDE,NMAX), Q(LDQ,1), Z(LDZ,1)
      INTEGER          INFE(1+LMAX+PMAX), INFZ(NMAX+1),
     $                 IWORK(NMAX+MMAX), KRONL(LMAX+PMAX+1),
     $                 KRONR(NMAX+MMAX+1)
*     .. External Subroutines ..
      EXTERNAL         AG08BD, DGEGV, DLACPY
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M, P, TOL, EQUIL
      IF( ( L.LT.0 .OR. L.GT.LMAX ) .OR. ( N.LT.0 .OR. N.GT.NMAX ) )
     $   THEN
         WRITE ( NOUT, FMT = 99972 ) L, N
      ELSE
         IF( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            IF( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99970 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               CALL DLACPY( 'F', L, N, A, LDA, ASAVE, LDA )
               CALL DLACPY( 'F', L, N, E, LDE, ESAVE, LDE )
               CALL DLACPY( 'F', L, M, B, LDB, BSAVE, LDB )
               CALL DLACPY( 'F', P, N, C, LDC, CSAVE, LDC )
               CALL DLACPY( 'F', P, M, D, LDD, DSAVE, LDD )
*              Compute poles (call the routine with M = 0, P = 0).
               CALL AG08BD( EQUIL, L, N, 0, 0, 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99968 ) NIZ
                  DO 10 I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99967 ) INFZ(I), I
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99958 )
     $                                      ( INFE(I), I = 1,NINFE )
                  IF( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99965 )
                  ELSE
                     WRITE ( NOUT, FMT = 99966 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 20 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 30 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
   30                CONTINUE
                     CALL DGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALFR, ALFI, BETA, Q,
     $                           LDQ, Z, LDZ, DWORK, LDWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99996 )
                        DO 40 I = 1, NFZ
                           IF( ALFI(I).EQ.ZERO ) THEN
                              WRITE ( NOUT, FMT = 99980 )
     $                                ALFR(I)/BETA(I)
                           ELSE
                              WRITE ( NOUT, FMT = 99979 )
     $                                ALFR(I)/BETA(I),
     $                                ALFI(I)/BETA(I)
                           END IF
   40                   CONTINUE
                     END IF
                  END IF
               END IF
               CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA )
               CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE )
*              Check the observability and compute the ordered set of
*              the observability indices (call the routine with M = 0).
               CALL AG08BD( EQUIL, L, N, 0, 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99964 ) NIZ
                  DO 50 I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99967 ) INFZ(I), I
   50             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99960 )
     $                                     ( INFE(I), I = 1,NINFE )
                  WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,NKROL )
                  IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99993 )
                  IF( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99957 )
                  ELSE
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 60 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
   60                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 70 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
   70                CONTINUE
                     CALL DGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALFR, ALFI, BETA, Q,
     $                           LDQ, Z, LDZ, DWORK, LDWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99996 )
                        DO 80 I = 1, NFZ
                           IF( ALFI(I).EQ.ZERO ) THEN
                              WRITE ( NOUT, FMT = 99980 )
     $                                ALFR(I)/BETA(I)
                           ELSE
                              WRITE ( NOUT, FMT = 99979 )
     $                                ALFR(I)/BETA(I),
     $                                ALFI(I)/BETA(I)
                           END IF
   80                   CONTINUE
                     END IF
                  END IF
               END IF
               CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA )
               CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE )
               CALL DLACPY( 'F', P, N, CSAVE, LDC, C, LDC )
*              Check the controllability and compute the ordered set of
*              the controllability indices (call the routine with P = 0)
               CALL AG08BD( EQUIL, L, N, M, 0, 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99963 ) NIZ
                  DO 90  I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99967 ) INFZ(I), I
   90             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99959 )
     $                                     ( INFE(I), I = 1,NINFE )
                  WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,NKROR )
                  IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99987 )
                  IF( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99956 )
                  ELSE
                     WRITE ( NOUT, FMT = 99985 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 100 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
  100                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 110 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
  110                CONTINUE
                     CALL DGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALFR, ALFI, BETA, Q,
     $                           LDQ, Z, LDZ, DWORK, LDWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99982 )
                        DO 120 I = 1, NFZ
                           IF( ALFI(I).EQ.ZERO ) THEN
                              WRITE ( NOUT, FMT = 99980 )
     $                                ALFR(I)/BETA(I)
                           ELSE
                              WRITE ( NOUT, FMT = 99979 )
     $                                ALFR(I)/BETA(I),
     $                                ALFI(I)/BETA(I)
                           END IF
  120                   CONTINUE
                     END IF
                  END IF
               END IF
               CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA )
               CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE )
               CALL DLACPY( 'F', L, M, BSAVE, LDB, B, LDB )
               CALL DLACPY( 'F', P, N, CSAVE, LDC, C, LDC )
               CALL DLACPY( 'F', P, M, DSAVE, LDD, D, LDD )
*              Compute the structural invariants of the given system.
               CALL 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( L.EQ.N ) THEN
                     WRITE ( NOUT, FMT = 99969 ) NRANK - N
                  ELSE
                     WRITE ( NOUT, FMT = 99955 ) NRANK
                  END IF
                  WRITE ( NOUT, FMT = 99984 ) NFZ
                  IF( NFZ.GT.0 ) THEN
*                    Compute the finite zeros of the given system.
*                    Workspace: need 8*NFZ.
                     WRITE ( NOUT, FMT = 99983 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 130 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
  130                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 140 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
  140                CONTINUE
                     CALL DGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALFR, ALFI, BETA, Q,
     $                           LDQ, Z, LDZ, DWORK, LDWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99981 )
                        DO 150 I = 1, NFZ
                           IF( ALFI(I).EQ.ZERO ) THEN
                              WRITE ( NOUT, FMT = 99980 )
     $                                ALFR(I)/BETA(I)
                           ELSE
                              WRITE ( NOUT, FMT = 99979 )
     $                                ALFR(I)/BETA(I),
     $                                ALFI(I)/BETA(I)
                           END IF
  150                   CONTINUE
                     END IF
                  END IF
                  WRITE ( NOUT, FMT = 99978 ) NIZ
                  DO 160 I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99977 ) INFZ(I), I
  160             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99961 )
     $                                     ( INFE(I), I = 1,NINFE )
                  WRITE ( NOUT, FMT = 99976 ) NKROR
                  IF( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 )
     $                                     ( KRONR(I), I = 1,NKROR )
                  WRITE ( NOUT, FMT = 99974 ) NKROL
                  IF( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 )
     $                                     ( KRONL(I), I = 1,NKROL )
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' AG08BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AG08BD = ',I2)
99997 FORMAT (' INFO on exit from DGEGV = ',I2)
99996 FORMAT (/'Unobservable finite eigenvalues'/
     $         ' real  part     imag  part ')
99995 FORMAT (/' The matrix Ef is ')
99994 FORMAT (/' The left Kronecker indices of [A-lambda*E;C] are ',
     $          /(20(I3,2X)))
99993 FORMAT (/' The system (A-lambda*E,C) is completely observable ')
99991 FORMAT (/' The finite output decoupling zeros are the eigenvalues'
     $       ,' of the pair (Af,Ef). ')
99990 FORMAT (/' The matrix Af is ')
99989 FORMAT (20(1X,F8.4))
99988 FORMAT (/' The right Kronecker indices of [A-lambda*E,B] are ',
     $        /( 20(I3,2X) ) )
99987 FORMAT (/' The system (A-lambda*E,B) is completely controllable ')
99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the',
     $       ' pair (Af,Ef). ')
99984 FORMAT (/' The number of finite zeros = ',I3)
99983 FORMAT (/' The finite zeros are the eigenvalues ',
     $         'of the pair (Af,Ef)')
99982 FORMAT (/'Uncontrollable finite eigenvalues'/
     $         ' real  part     imag  part ')
99981 FORMAT (/'Finite zeros'/' real  part     imag  part ')
99980 FORMAT (1X,F9.4)
99979 FORMAT (1X,F9.4,6X,F9.4)
99978 FORMAT (//' The number of infinite zeros = ',I3)
99977 FORMAT ( I4,' infinite zero(s) of order ',I3)
99976 FORMAT (/' The number of right Kronecker indices = ',I3)
99975 FORMAT (/' Right Kronecker indices of [A-lambda*E,B;C,D]'
     $         ,' are ', /(20(I3,2X)))
99974 FORMAT (/' The number of left Kronecker indices = ',I3)
99973 FORMAT (/' The left Kronecker indices of [A-lambda*E,B;C,D]'
     $         ,' are ',  /(20(I3,2X)))
99972 FORMAT (/' L or N is out of range.',/' L = ', I5, '  N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
99970 FORMAT (/' P is out of range.',/' P = ',I5)
99969 FORMAT (/' Normal rank  of transfer function matrix = ',I3)
99968 FORMAT (//' The number of infinite poles = ',I3)
99967 FORMAT ( I4,' infinite pole(s) of order ',I3)
99966 FORMAT (/' The finite poles are the eigenvalues',
     $       ' of the pair (Af,Ef). ')
99965 FORMAT (/' The system has no finite poles ')
99964 FORMAT (//' The number of unobservable infinite poles = ',I3)
99963 FORMAT (//' The number of uncontrollable infinite poles = ',I3)
99962 FORMAT (/' The number of infinite Kronecker blocks = ',I3)
99961 FORMAT (/' Multiplicities of infinite eigenvalues of '
     $         ,'[A-lambda*E,B;C,D] are ', /(20(I3,2X)))
99960 FORMAT (/' Multiplicities of infinite eigenvalues of '
     $         ,'[A-lambda*E;C] are ', /(20(I3,2X)))
99959 FORMAT (/' Multiplicities of infinite eigenvalues of '
     $         ,'[A-lambda*E,B] are ', /(20(I3,2X)))
99958 FORMAT (/' Multiplicities of infinite eigenvalues of A-lambda*E'
     $         ,' are ', /(20(I3,2X)))
99957 FORMAT (/' The system (A-lambda*E,C) has no finite output',
     $         ' decoupling zeros ')
99956 FORMAT (/' The system (A-lambda*E,B) has no finite input',
     $         ' decoupling zeros ')
99955 FORMAT (/' Normal rank  of system pencil = ',I3)
      END
Program Data 
 AG08BD EXAMPLE PROGRAM DATA
   9    9    3     3     1.e-7     N
     1     0     0     0     0     0     0     0     0
     0     1     0     0     0     0     0     0     0
     0     0     1     0     0     0     0     0     0
     0     0     0     1     0     0     0     0     0
     0     0     0     0     1     0     0     0     0
     0     0     0     0     0     1     0     0     0
     0     0     0     0     0     0     1     0     0
     0     0     0     0     0     0     0     1     0
     0     0     0     0     0     0     0     0     1
     0     0     0     0     0     0     0     0     0
     1     0     0     0     0     0     0     0     0
     0     1     0     0     0     0     0     0     0
     0     0     0     0     0     0     0     0     0
     0     0     0     1     0     0     0     0     0
     0     0     0     0     1     0     0     0     0
     0     0     0     0     0     0     0     0     0
     0     0     0     0     0     0     1     0     0
     0     0     0     0     0     0     0     1     0
    -1     0     0
     0     0     0
     0     0     0
     0    -1     0
     0     0     0
     0     0     0
     0     0    -1
     0     0     0
     0     0     0
     0     1     1     0     3     4     0     0     2
     0     1     0     0     4     0     0     2     0
     0     0     1     0    -1     4     0    -2     2
     1     2    -2
     0    -1    -2
     0     0     0
Program Results 
 AG08BD EXAMPLE PROGRAM RESULTS



 The number of infinite poles =   6
   0 infinite pole(s) of order   1
   3 infinite pole(s) of order   2

 The number of infinite Kronecker blocks =   3

 Multiplicities of infinite eigenvalues of A-lambda*E are 
  3    3    3

 The system has no finite poles 


 The number of unobservable infinite poles =   4
   0 infinite pole(s) of order   1
   2 infinite pole(s) of order   2

 The number of infinite Kronecker blocks =   3

 Multiplicities of infinite eigenvalues of [A-lambda*E;C] are 
  1    3    3

 The left Kronecker indices of [A-lambda*E;C] are 
  0    1    1

 The system (A-lambda*E,C) has no finite output decoupling zeros 


 The number of uncontrollable infinite poles =   0

 The number of infinite Kronecker blocks =   3

 Multiplicities of infinite eigenvalues of [A-lambda*E,B] are 
  1    1    1

 The right Kronecker indices of [A-lambda*E,B] are 
  2    2    2

 The system (A-lambda*E,B) has no finite input decoupling zeros 

 Normal rank  of transfer function matrix =   2

 The number of finite zeros =   1

 The finite zeros are the eigenvalues of the pair (Af,Ef)

 The matrix Af is 
   0.7705

 The matrix Ef is 
   0.7705

Finite zeros
 real  part     imag  part 
    1.0000


 The number of infinite zeros =   2
   0 infinite zero(s) of order   1
   1 infinite zero(s) of order   2

 The number of infinite Kronecker blocks =   5

 Multiplicities of infinite eigenvalues of [A-lambda*E,B;C,D] are 
  1    1    1    1    3

 The number of right Kronecker indices =   1

 Right Kronecker indices of [A-lambda*E,B;C,D] are 
  2

 The number of left Kronecker indices =   1

 The left Kronecker indices of [A-lambda*E,B;C,D] are 
  1

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AG08BY.html000077500000000000000000000216441201767322700161050ustar00rootroot00000000000000 AG08BY - SLICOT Library Routine Documentation

AG08BY

Construction of a reduced system with input/output matrix Dr of full row rank, preserving the finite Smith zeros of the descriptor system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To extract from the (N+P)-by-(M+N) descriptor system pencil

     S(lambda) = ( B   A - lambda*E  )
                 ( D        C        )

  with E nonsingular and upper triangular a
  (NR+PR)-by-(M+NR) "reduced" descriptor system pencil

                        ( Br  Ar-lambda*Er )
           Sr(lambda) = (                  )
                        ( Dr     Cr        )

  having the same finite Smith zeros as the pencil
  S(lambda) but with Dr, a PR-by-M full row rank
  left upper trapezoidal matrix, and Er, an NR-by-NR
  upper triangular nonsingular matrix.
Specification 
      SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE,
     $                   NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
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, * )
Arguments

Mode Parameters 

  FIRST   LOGICAL
          Specifies if AG08BY is called first time or it is called
          for an already reduced system, with D full column rank
          with the last M rows in upper triangular form:
          FIRST = .TRUE.,  first time called;
          FIRST = .FALSE., not first time called.
Input/Output Parameters 
  N       (input) INTEGER
          The number of rows of matrix B, the number of columns of
          matrix C and the order of square matrices A and E.
          N >= 0.

  M       (input) INTEGER
          The number of columns of matrices B and D.  M >= 0.
          M <= P if FIRST = .FALSE. .

  P       (input) INTEGER
          The number of rows of matrices C and D.  P >= 0.

  SVLMAX  (input) DOUBLE PRECISION
          During each reduction step, the rank-revealing QR
          factorization of a matrix stops when the estimated minimum
          singular value is smaller than TOL * MAX(SVLMAX,EMSV),
          where EMSV is the estimated maximum singular value.
          SVLMAX >= 0.

  ABCD    (input/output) DOUBLE PRECISION array, dimension
          (LDABCD,M+N)
          On entry, the leading (N+P)-by-(M+N) part of this array
          must contain the compound matrix
                   (  B   A  ) ,
                   (  D   C  )
          where A is an N-by-N matrix, B is an N-by-M matrix,
          C is a P-by-N matrix and D is a P-by-M matrix.
          If FIRST = .FALSE., then D must be a full column
          rank matrix with the last M rows in upper triangular form.
          On exit, the leading (NR+PR)-by-(M+NR) part of ABCD
          contains the reduced compound matrix
                    (  Br  Ar ) ,
                    (  Dr  Cr )
          where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix,
          Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank
          left upper trapezoidal matrix with the first PR columns
          in upper triangular form.

  LDABCD  INTEGER
          The leading dimension of array ABCD.
          LDABCD >= MAX(1,N+P).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the upper triangular nonsingular matrix E.
          On exit, the leading NR-by-NR part contains the reduced
          upper triangular nonsingular matrix Er.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  NR      (output) INTEGER
          The order of the reduced matrices Ar and Er; also the
          number of rows of the reduced matrix Br and the number
          of columns of the reduced matrix Cr.
          If Dr is invertible, NR is also the number of finite
          Smith zeros.

  PR      (output) INTEGER
          The rank of the resulting matrix Dr; also the number of
          rows of reduced matrices Cr and Dr.

  NINFZ   (output) INTEGER
          Number of infinite zeros.  NINFZ = 0 if FIRST = .FALSE. .

  DINFZ   (output) INTEGER
          The maximal multiplicity of infinite zeros.
          DINFZ = 0 if FIRST = .FALSE. .

  NKRONL  (output) INTEGER
          The maximal dimension of left elementary Kronecker blocks.

  INFZ    (output) INTEGER array, dimension (N)
          INFZ(i) contains the number of infinite zeros of
          degree i, where i = 1,2,...,DINFZ.
          INFZ is not referenced if FIRST = .FALSE. .

  KRONL   (output) INTEGER array, dimension (N+1)
          KRONL(i) contains the number of left elementary Kronecker
          blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL <= 0, then an implicitly computed,
          default tolerance TOLDEF = (N+P)*(N+M)*EPS,  is used
          instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH).
          NOTE that when SVLMAX > 0, the estimated ranks could be
          less than those defined above (see SVLMAX).  TOL <= 1.
Workspace 
  IWORK   INTEGER array, dimension (M)
          If FIRST = .FALSE., IWORK is not referenced.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 1, if P = 0; otherwise
          LDWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 5*P ),
                                          if FIRST = .TRUE.;
          LDWORK >= MAX( 1, N+M-1, 5*P ), if FIRST = .FALSE. .
          The second term is not needed if M = 0.
          For optimum performance LDWORK should be larger.

          If LDWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          DWORK array, returns this value as the first entry of
          the DWORK array, and no error message related to LDWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The subroutine is based on the reduction algorithm of [1].
References 
  [1] P. Misra, P. Van Dooren and A. Varga.
      Computation of structural invariants of generalized
      state-space systems.
      Automatica, 30, pp. 1921-1936, 1994.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( (P+N)*(M+N)*N )  floating point operations.
Further Comments 
  The number of infinite zeros is computed as

                DINFZ
     NINFZ =     Sum  (INFZ(i)*i) .
                 i=1
  Note that each infinite zero of multiplicity k corresponds to
  an infinite eigenvalue of multiplicity k+1.
  The multiplicities of the infinite eigenvalues can be determined
  from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows:

                  DINFZ
  - there are PR - Sum (INFZ(i)) simple infinite eigenvalues;
                   i=1

  - there are INFZ(i) infinite eigenvalues with multiplicity i+1,
    for i = 1, ..., DINFZ.

  The left Kronecker indices are:

  [ 0  0 ...  0  | 1  1  ...  1 |  .... | NKRONL  ...  NKRONL ]
  |<- KRONL(1) ->|<- KRONL(2) ->|       |<-  KRONL(NKRONL)  ->|
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/AG08BZ.html000077500000000000000000000716541201767322700161140ustar00rootroot00000000000000 AG08BZ - SLICOT Library Routine Documentation

AG08BZ

Zeros and Kronecker structure of a descriptor system pencil (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To extract from the system pencil

                    ( A-lambda*E B )
        S(lambda) = (              )
                    (      C     D )

  a regular pencil Af-lambda*Ef which has the finite Smith zeros of
  S(lambda) as generalized eigenvalues. The routine also computes
  the orders of the infinite Smith zeros and determines the singular
  and infinite Kronecker structure of system pencil, i.e., the right
  and left Kronecker indices, and the multiplicities of infinite
  eigenvalues.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the system
          matrix as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A of the system.
          On exit, the leading NFZ-by-NFZ part of this array
          contains the matrix Af of the reduced pencil.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) COMPLEX*16 array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E of the system.
          On exit, the leading NFZ-by-NFZ part of this array
          contains the matrix Ef of the reduced pencil.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) COMPLEX*16 array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B of the system.
          On exit, this matrix does not contain useful information.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0;
          LDB >= 1        if M = 0.

  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C of the system.
          On exit, this matrix does not contain useful information.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) COMPLEX*16 array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct transmission matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NFZ     (output) INTEGER
          The number of finite zeros.

  NRANK   (output) INTEGER
          The normal rank of the system pencil.

  NIZ     (output) INTEGER
          The number of infinite zeros.

  DINFZ   (output) INTEGER
          The maximal multiplicity of infinite Smith zeros.

  NKROR   (output) INTEGER
          The number of right Kronecker indices.

  NINFE   (output) INTEGER
          The number of elementary infinite blocks.

  NKROL   (output) INTEGER
          The number of left Kronecker indices.

  INFZ    (output) INTEGER array, dimension (N+1)
          The leading DINFZ elements of INFZ contain information
          on the infinite elementary divisors as follows:
          the system has INFZ(i) infinite elementary divisors of
          degree i in the Smith form, where i = 1,2,...,DINFZ.

  KRONR   (output) INTEGER array, dimension (N+M+1)
          The leading NKROR elements of this array contain the
          right Kronecker (column) indices.

  INFE    (output) INTEGER array, dimension (1+MIN(L+P,N+M))
          The leading NINFE elements of INFE contain the
          multiplicities of infinite eigenvalues.

  KRONL   (output) INTEGER array, dimension (L+P+1)
          The leading NKROL elements of this array contain the
          left Kronecker (row) indices.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL <= 0, then default tolerances are
          used instead, as follows: TOLDEF = L*N*EPS in TG01FZ
          (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS
          in the rest, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH).  TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension N+max(1,M)
          On output, IWORK(1) contains the normal rank of the
          transfer function matrix.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          LDWORK >= max(4*(L+N), 2*max(L+P,M+N))), if EQUIL = 'S',
          LDWORK >= 2*max(L+P,M+N)),               if EQUIL = 'N'.

  ZWORK   COMPLEX*16 array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) returns the optimal value
          of LZWORK.

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= max( max(L+P,M+N)*(M+N) +
                         max(min(L+P,M+N) + max(min(L,N),3*(M+N)-1),
                             3*(L+P), 1))
          For optimum performance LZWORK should be larger.

          If LZWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          ZWORK array, returns this value as the first entry of
          the ZWORK array, and no error message related to LZWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine extracts from the system matrix of a descriptor
  system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which
  has the finite zeros of the system as generalized eigenvalues.
  The procedure has the following main computational steps:

     (a) construct the (L+P)-by-(N+M) system pencil

          S(lambda) = ( B  A )-lambda*( 0  E );
                      ( D  C )        ( 0  0 )

     (b) reduce S(lambda) to S1(lambda) with the same finite
         zeros and right Kronecker structure but with E
         upper triangular and nonsingular;

     (c) reduce S1(lambda) to S2(lambda) with the same finite
         zeros and right Kronecker structure but with D of
         full row rank;

     (d) reduce S2(lambda) to S3(lambda) with the same finite zeros
         and with D square invertible;

     (e) perform a unitary transformation on the columns of

         S3(lambda) = (A-lambda*E   B) in order to reduce it to
                      (     C       D)

         (Af-lambda*Ef   X), with Y and Ef square invertible;
         (     0         Y)

     (f) compute the right and left Kronecker indices of the system
         matrix, which together with the multiplicities of the
         finite and infinite eigenvalues constitute the
         complete set of structural invariants under strict
         equivalence transformations of a linear system.
References 
  [1] P. Misra, P. Van Dooren and A. Varga.
      Computation of structural invariants of generalized
      state-space systems.
      Automatica, 30, pp. 1921-1936, 1994.
Numerical Aspects 
  The algorithm is backward stable (see [1]).
Further Comments 
  In order to compute the finite Smith zeros of the system
  explicitly, a call to this routine may be followed by a
  call to the LAPACK Library routines ZGEGV or ZGGEV.
Example

Program Text 

*     AG08BZ EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, MMAX, NMAX, PMAX
      PARAMETER        ( LMAX = 20, MMAX = 20, NMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDAEMX, LDB, LDC, LDD, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDD = PMAX, LDE = LMAX, LDQ = 1, LDZ = 1,
     $                   LDAEMX = MAX( PMAX + LMAX, NMAX + MMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 4*( LMAX + NMAX ), 2*LDAEMX,
     $                                 8*NMAX ) )
      INTEGER          LZWORK
      PARAMETER        ( LZWORK = MAX( 1, LDAEMX*LDAEMX +
     $                                 MAX( MIN( LMAX+PMAX, MMAX+NMAX )+
     $                                      MAX( MIN( LMAX, NMAX ),
     $                                           3*( MMAX+NMAX )-1 ),
     $                                      3*( LMAX+PMAX ) ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          DINFZ, I, INFO, J, L, M, N, NFZ, NINFE, NIZ,
     $                 NKROL, NKROR, NRANK, P
      CHARACTER*1      EQUIL
*     .. Local Arrays ..
      COMPLEX*16       A(LDA,NMAX), ALPHA(NMAX), ASAVE(LDA,NMAX),
     $                 B(LDB,MMAX),  BETA(NMAX), BSAVE(LDB,MMAX),
     $                 C(LDC,NMAX), CSAVE(LDC,NMAX),
     $                 D(LDD,MMAX), DSAVE(LDD,MMAX),
     $                 E(LDE,NMAX), ESAVE(LDE,NMAX), Q(LDQ,1), Z(LDZ,1),
     $                 ZWORK(LZWORK)
      DOUBLE PRECISION DWORK(LDWORK)
      INTEGER          INFE(1+LMAX+PMAX), INFZ(NMAX+1),
     $                 IWORK(NMAX+MMAX), KRONL(LMAX+PMAX+1),
     $                 KRONR(NMAX+MMAX+1)
*     .. External Subroutines ..
      EXTERNAL         AG08BZ, ZGEGV, ZLACPY
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M, P, TOL, EQUIL
      IF( ( L.LT.0 .OR. L.GT.LMAX ) .OR. ( N.LT.0 .OR. N.GT.NMAX ) )
     $   THEN
         WRITE ( NOUT, FMT = 99972 ) L, N
      ELSE
         IF( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            IF( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99970 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               CALL ZLACPY( 'F', L, N, A, LDA, ASAVE, LDA )
               CALL ZLACPY( 'F', L, N, E, LDE, ESAVE, LDE )
               CALL ZLACPY( 'F', L, M, B, LDB, BSAVE, LDB )
               CALL ZLACPY( 'F', P, N, C, LDC, CSAVE, LDC )
               CALL ZLACPY( 'F', P, M, D, LDD, DSAVE, LDD )
*              Compute poles (call the routine with M = 0, P = 0).
               CALL AG08BZ( EQUIL, L, N, 0, 0, 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99968 ) NIZ
                  DO 10 I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99967 ) INFZ(I), I
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99958 )
     $                                      ( INFE(I), I = 1,NINFE )
                  IF( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99965 )
                  ELSE
                     WRITE ( NOUT, FMT = 99966 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 20 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 30 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
   30                CONTINUE
                     CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALPHA, BETA, Q, LDQ,
     $                           Z, LDZ, ZWORK, LZWORK, DWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99996 )
                        DO 40 I = 1, NFZ
                           WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I)
   40                   CONTINUE
                     END IF
                  END IF
               END IF
               CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA )
               CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE )
*              Check the observability and compute the ordered set of
*              the observability indices (call the routine with M = 0).
               CALL AG08BZ( EQUIL, L, N, 0, 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99964 ) NIZ
                  DO 50 I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99967 ) INFZ(I), I
   50             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99960 )
     $                                     ( INFE(I), I = 1,NINFE )
                  WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,NKROL )
                  IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99993 )
                  IF( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99957 )
                  ELSE
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 60 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
   60                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 70 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
   70                CONTINUE
                     CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALPHA, BETA, Q, LDQ,
     $                           Z, LDZ, ZWORK, LZWORK, DWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99996 )
                        DO 80 I = 1, NFZ
                           WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I)
   80                   CONTINUE
                     END IF
                  END IF
               END IF
               CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA )
               CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE )
               CALL ZLACPY( 'F', P, N, CSAVE, LDC, C, LDC )
*              Check the controllability and compute the ordered set of
*              the controllability indices (call the routine with P = 0)
               CALL AG08BZ( EQUIL, L, N, M, 0, 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99963 ) NIZ
                  DO 90  I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99967 ) INFZ(I), I
   90             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99959 )
     $                                     ( INFE(I), I = 1,NINFE )
                  WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,NKROR )
                  IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99987 )
                  IF( NFZ.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99956 )
                  ELSE
                     WRITE ( NOUT, FMT = 99985 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 100 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
  100                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 110 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
  110                CONTINUE
                     CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALPHA, BETA, Q, LDQ,
     $                           Z, LDZ, ZWORK, LZWORK, DWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99982 )
                        DO 120 I = 1, NFZ
                           WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I)
  120                   CONTINUE
                     END IF
                  END IF
               END IF
               CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA )
               CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE )
               CALL ZLACPY( 'F', L, M, BSAVE, LDB, B, LDB )
               CALL ZLACPY( 'F', P, N, CSAVE, LDC, C, LDC )
               CALL ZLACPY( 'F', P, M, DSAVE, LDD, D, LDD )
*              Compute the structural invariants of the given system.
               CALL 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 )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( L.EQ.N ) THEN
                     WRITE ( NOUT, FMT = 99969 ) NRANK - N
                  ELSE
                     WRITE ( NOUT, FMT = 99955 ) NRANK
                  END IF
                  WRITE ( NOUT, FMT = 99984 ) NFZ
                  IF( NFZ.GT.0 ) THEN
*                    Compute the finite zeros of the given system.
*                    Workspace: need 8*NFZ.
                     WRITE ( NOUT, FMT = 99983 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 130 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( A(I,J), J = 1,NFZ )
  130                CONTINUE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 140 I = 1, NFZ
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( E(I,J), J = 1,NFZ )
  140                CONTINUE
                     CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A,
     $                           LDA, E, LDE, ALPHA, BETA, Q, LDQ,
     $                           Z, LDZ, ZWORK, LZWORK, DWORK, INFO )
*
                     IF( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99981 )
                        DO 150 I = 1, NFZ
                           WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I)
  150                   CONTINUE
                     END IF
                  END IF
                  WRITE ( NOUT, FMT = 99978 ) NIZ
                  DO 160 I = 1, DINFZ
                     WRITE ( NOUT, FMT = 99977 ) INFZ(I), I
  160             CONTINUE
                  WRITE ( NOUT, FMT = 99962 ) NINFE
                  IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99961 )
     $                                     ( INFE(I), I = 1,NINFE )
                  WRITE ( NOUT, FMT = 99976 ) NKROR
                  IF( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 )
     $                                     ( KRONR(I), I = 1,NKROR )
                  WRITE ( NOUT, FMT = 99974 ) NKROL
                  IF( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 )
     $                                     ( KRONL(I), I = 1,NKROL )
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' AG08BZ EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AG08BZ = ',I2)
99997 FORMAT (' INFO on exit from ZGEGV = ',I2)
99996 FORMAT (/' Unobservable finite eigenvalues'/
     $         ' real  part     imag  part ')
99995 FORMAT (/' The matrix Ef is ')
99994 FORMAT (/' The left Kronecker indices of [A-lambda*E;C] are ',
     $          /(20(I3,2X)))
99993 FORMAT (/' The system (A-lambda*E,C) is completely observable ')
99991 FORMAT (/' The finite output decoupling zeros are the eigenvalues'
     $       , ' of the pair (Af,Ef). ')
99990 FORMAT (/' The matrix Af is ')
99989 FORMAT (20(1X,F9.4,SP,F9.4,S,'i '))
99988 FORMAT (/' The right Kronecker indices of [A-lambda*E,B] are ',
     $        /( 20(I3,2X) ) )
99987 FORMAT (/' The system (A-lambda*E,B) is completely controllable ')
99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the',
     $         ' pair (Af,Ef). ')
99984 FORMAT (/' The number of finite zeros = ',I3)
99983 FORMAT (/' The finite zeros are the eigenvalues ',
     $         'of the pair (Af,Ef)')
99982 FORMAT (/' Uncontrollable finite eigenvalues'/
     $         ' real  part     imag  part ')
99981 FORMAT (/' Finite zeros'/' real  part     imag  part ')
99979 FORMAT (1X,F9.4,SP,F9.4,S,'i ')
99978 FORMAT (//' The number of infinite zeros = ',I3)
99977 FORMAT ( I4,' infinite zero(s) of order ',I3)
99976 FORMAT (/' The number of right Kronecker indices = ',I3)
99975 FORMAT (/' Right Kronecker indices of [A-lambda*E,B;C,D]'
     $         ,' are ', /(20(I3,2X)))
99974 FORMAT (/' The number of left Kronecker indices = ',I3)
99973 FORMAT (/' The left Kronecker indices of [A-lambda*E,B;C,D]'
     $         ,' are ',  /(20(I3,2X)))
99972 FORMAT (/' L or N is out of range.',/' L = ', I5, '  N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
99970 FORMAT (/' P is out of range.',/' P = ',I5)
99969 FORMAT (/' Normal rank  of transfer function matrix = ',I3)
99968 FORMAT (//' The number of infinite poles = ',I3)
99967 FORMAT ( I4,' infinite pole(s) of order ',I3)
99966 FORMAT (/' The finite poles are the eigenvalues',
     $         ' of the pair (Af,Ef). ')
99965 FORMAT (/' The system has no finite poles ')
99964 FORMAT (//' The number of unobservable infinite poles = ',I3)
99963 FORMAT (//' The number of uncontrollable infinite poles = ',I3)
99962 FORMAT (/' The number of infinite Kronecker blocks = ',I3)
99961 FORMAT (/' Multiplicities of infinite eigenvalues of '
     $         ,'[A-lambda*E,B;C,D] are ', /(20(I3,2X)))
99960 FORMAT (/' Multiplicities of infinite eigenvalues of '
     $         ,'[A-lambda*E;C] are ', /(20(I3,2X)))
99959 FORMAT (/' Multiplicities of infinite eigenvalues of '
     $         ,'[A-lambda*E,B] are ', /(20(I3,2X)))
99958 FORMAT (/' Multiplicities of infinite eigenvalues of A-lambda*E'
     $         ,' are ', /(20(I3,2X)))
99957 FORMAT (/' The system (A-lambda*E,C) has no finite output',
     $         ' decoupling zeros ')
99956 FORMAT (/' The system (A-lambda*E,B) has no finite input',
     $         ' decoupling zeros ')
99955 FORMAT (/' Normal rank  of system pencil = ',I3)
      END
Program Data 
 AG08BZ EXAMPLE PROGRAM DATA
   9    9    3     3     1.e-7     N
     1     0     0     0     0     0     0     0     0
     0     1     0     0     0     0     0     0     0
     0     0     1     0     0     0     0     0     0
     0     0     0     1     0     0     0     0     0
     0     0     0     0     1     0     0     0     0
     0     0     0     0     0     1     0     0     0
     0     0     0     0     0     0     1     0     0
     0     0     0     0     0     0     0     1     0
     0     0     0     0     0     0     0     0     1
     0     0     0     0     0     0     0     0     0
     1     0     0     0     0     0     0     0     0
     0     1     0     0     0     0     0     0     0
     0     0     0     0     0     0     0     0     0
     0     0     0     1     0     0     0     0     0
     0     0     0     0     1     0     0     0     0
     0     0     0     0     0     0     0     0     0
     0     0     0     0     0     0     1     0     0
     0     0     0     0     0     0     0     1     0
    -1     0     0
     0     0     0
     0     0     0
     0    -1     0
     0     0     0
     0     0     0
     0     0    -1
     0     0     0
     0     0     0
     0     1     1     0     3     4     0     0     2
     0     1     0     0     4     0     0     2     0
     0     0     1     0    -1     4     0    -2     2
     1     2    -2
     0    -1    -2
     0     0     0
Program Results 
 AG08BZ EXAMPLE PROGRAM RESULTS



 The number of infinite poles =   6
   0 infinite pole(s) of order   1
   3 infinite pole(s) of order   2

 The number of infinite Kronecker blocks =   3

 Multiplicities of infinite eigenvalues of A-lambda*E are 
  3    3    3

 The system has no finite poles 


 The number of unobservable infinite poles =   4
   0 infinite pole(s) of order   1
   2 infinite pole(s) of order   2

 The number of infinite Kronecker blocks =   3

 Multiplicities of infinite eigenvalues of [A-lambda*E;C] are 
  1    3    3

 The left Kronecker indices of [A-lambda*E;C] are 
  0    1    1

 The system (A-lambda*E,C) has no finite output decoupling zeros 


 The number of uncontrollable infinite poles =   0

 The number of infinite Kronecker blocks =   3

 Multiplicities of infinite eigenvalues of [A-lambda*E,B] are 
  1    1    1

 The right Kronecker indices of [A-lambda*E,B] are 
  2    2    2

 The system (A-lambda*E,B) has no finite input decoupling zeros 

 Normal rank  of transfer function matrix =   2

 The number of finite zeros =   1

 The finite zeros are the eigenvalues of the pair (Af,Ef)

 The matrix Af is 
   -0.7705  +0.0000i 

 The matrix Ef is 
   -0.7705  +0.0000i 

Finite zeros
 real  part     imag  part 
    1.0000  +0.0000i 


 The number of infinite zeros =   2
   0 infinite zero(s) of order   1
   1 infinite zero(s) of order   2

 The number of infinite Kronecker blocks =   5

 Multiplicities of infinite eigenvalues of [A-lambda*E,B;C,D] are 
  1    1    1    1    3

 The number of right Kronecker indices =   1

 Right Kronecker indices of [A-lambda*E,B;C,D] are 
  2

 The number of left Kronecker indices =   1

 The left Kronecker indices of [A-lambda*E,B;C,D] are 
  1

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/AG8BYZ.html000077500000000000000000000221461201767322700161550ustar00rootroot00000000000000 AG8BYZ - SLICOT Library Routine Documentation

AG8BYZ

Construction of a reduced system with input/output matrix Dr of full row rank, preserving the finite Smith zeros of the descriptor system (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To extract from the (N+P)-by-(M+N) descriptor system pencil

     S(lambda) = ( B   A - lambda*E  )
                 ( D        C        )

  with E nonsingular and upper triangular a
  (NR+PR)-by-(M+NR) "reduced" descriptor system pencil

                        ( Br  Ar-lambda*Er )
           Sr(lambda) = (                  )
                        ( Dr     Cr        )

  having the same finite Smith zeros as the pencil
  S(lambda) but with Dr, a PR-by-M full row rank
  left upper trapezoidal matrix, and Er, an NR-by-NR
  upper triangular nonsingular matrix.
Specification 
      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     .. 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( * )
Arguments

Mode Parameters 

  FIRST   LOGICAL
          Specifies if AG8BYZ is called first time or it is called
          for an already reduced system, with D full column rank
          with the last M rows in upper triangular form:
          FIRST = .TRUE.,  first time called;
          FIRST = .FALSE., not first time called.
Input/Output Parameters 
  N       (input) INTEGER
          The number of rows of matrix B, the number of columns of
          matrix C and the order of square matrices A and E.
          N >= 0.

  M       (input) INTEGER
          The number of columns of matrices B and D.  M >= 0.
          M <= P if FIRST = .FALSE. .

  P       (input) INTEGER
          The number of rows of matrices C and D.  P >= 0.

  SVLMAX  (input) DOUBLE PRECISION
          During each reduction step, the rank-revealing QR
          factorization of a matrix stops when the estimated minimum
          singular value is smaller than TOL * MAX(SVLMAX,EMSV),
          where EMSV is the estimated maximum singular value.
          SVLMAX >= 0.

  ABCD    (input/output) COMPLEX*16 array, dimension (LDABCD,M+N)
          On entry, the leading (N+P)-by-(M+N) part of this array
          must contain the compound matrix
                   (  B   A  ) ,
                   (  D   C  )
          where A is an N-by-N matrix, B is an N-by-M matrix,
          C is a P-by-N matrix and D is a P-by-M matrix.
          If FIRST = .FALSE., then D must be a full column
          rank matrix with the last M rows in upper triangular form.
          On exit, the leading (NR+PR)-by-(M+NR) part of ABCD
          contains the reduced compound matrix
                    (  Br  Ar ) ,
                    (  Dr  Cr )
          where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix,
          Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank
          left upper trapezoidal matrix with the first PR columns
          in upper triangular form.

  LDABCD  INTEGER
          The leading dimension of array ABCD.
          LDABCD >= MAX(1,N+P).

  E       (input/output) COMPLEX*16 array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the upper triangular nonsingular matrix E.
          On exit, the leading NR-by-NR part contains the reduced
          upper triangular nonsingular matrix Er.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  NR      (output) INTEGER
          The order of the reduced matrices Ar and Er; also the
          number of rows of the reduced matrix Br and the number
          of columns of the reduced matrix Cr.
          If Dr is invertible, NR is also the number of finite
          Smith zeros.

  PR      (output) INTEGER
          The rank of the resulting matrix Dr; also the number of
          rows of reduced matrices Cr and Dr.

  NINFZ   (output) INTEGER
          Number of infinite zeros.  NINFZ = 0 if FIRST = .FALSE. .

  DINFZ   (output) INTEGER
          The maximal multiplicity of infinite zeros.
          DINFZ = 0 if FIRST = .FALSE. .

  NKRONL  (output) INTEGER
          The maximal dimension of left elementary Kronecker blocks.

  INFZ    (output) INTEGER array, dimension (N)
          INFZ(i) contains the number of infinite zeros of
          degree i, where i = 1,2,...,DINFZ.
          INFZ is not referenced if FIRST = .FALSE. .

  KRONL   (output) INTEGER array, dimension (N+1)
          KRONL(i) contains the number of left elementary Kronecker
          blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used in rank decisions to determine the
          effective rank, which is defined as the order of the
          largest leading (or trailing) triangular submatrix in the
          QR (or RQ) factorization with column (or row) pivoting
          whose estimated condition number is less than 1/TOL.
          If the user sets TOL <= 0, then an implicitly computed,
          default tolerance TOLDEF = (N+P)*(N+M)*EPS,  is used
          instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH).
          NOTE that when SVLMAX > 0, the estimated ranks could be
          less than those defined above (see SVLMAX).  TOL <= 1.
Workspace 
  IWORK   INTEGER array, dimension (M)
          If FIRST = .FALSE., IWORK is not referenced.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          LDWORK >= 2*MAX(M,P), if FIRST = .TRUE.;
          LDWORK >= 2*P,        if FIRST = .FALSE. .

  ZWORK   COMPLEX*16 array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) returns the optimal value
          of LZWORK.

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= 1, if P = 0; otherwise
          LZWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 3*P ),
                                          if FIRST = .TRUE.;
          LZWORK >= MAX( 1, N+M-1, 3*P ), if FIRST = .FALSE. .
          The second term is not needed if M = 0.
          For optimum performance LZWORK should be larger.

          If LZWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          ZWORK array, returns this value as the first entry of
          the ZWORK array, and no error message related to LZWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The subroutine is based on the reduction algorithm of [1].
References 
  [1] P. Misra, P. Van Dooren and A. Varga.
      Computation of structural invariants of generalized
      state-space systems.
      Automatica, 30, pp. 1921-1936, 1994.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( (P+N)*(M+N)*N )  floating point operations.
Further Comments 
  The number of infinite zeros is computed as

                DINFZ
     NINFZ =     Sum  (INFZ(i)*i) .
                 i=1
  Note that each infinite zero of multiplicity k corresponds to
  an infinite eigenvalue of multiplicity k+1.
  The multiplicities of the infinite eigenvalues can be determined
  from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows:

                  DINFZ
  - there are PR - Sum (INFZ(i)) simple infinite eigenvalues;
                   i=1

  - there are INFZ(i) infinite eigenvalues with multiplicity i+1,
    for i = 1, ..., DINFZ.

  The left Kronecker indices are:

  [ 0  0 ...  0  | 1  1  ...  1 |  .... | NKRONL  ...  NKRONL ]
  |<- KRONL(1) ->|<- KRONL(2) ->|       |<-  KRONL(NKRONL)  ->|
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/BB01AD.html000077500000000000000000000603261201767322700160440ustar00rootroot00000000000000 BB01AD - SLICOT Library Routine Documentation

BB01AD

Benchmark examples for continuous-time algebraic Riccati equations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate the benchmark examples for the numerical solution of
  continuous-time algebraic Riccati equations (CAREs) of the form

    0 = Q + A'X + XA - XGX

  corresponding to the Hamiltonian matrix

         (  A   G  )
     H = (       T ).
         (  Q  -A  )

  A,G,Q,X are real N-by-N matrices, Q and G are symmetric and may
  be given in factored form

                -1 T                         T
   (I)   G = B R  B  ,           (II)   Q = C W C .

  Here, C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W
  and R are symmetric. In linear-quadratic optimal control problems,
  usually W is positive semidefinite and R positive definite.  The
  factorized form can be used if the CARE is solved using the
  deflating subspaces of the extended Hamiltonian pencil

               (  A   0   B  )       (  I   0   0  )
               (       T     )       (             )
     H - s K = (  Q   A   0  )  -  s (  0  -I   0  ) ,
               (       T     )       (             )
               (  0   B   R  )       (  0   0   0  )

  where I and 0 denote the identity and zero matrix, respectively,
  of appropriate dimensions.

  NOTE: the formulation of the CARE and the related matrix (pencils)
        used here does not include CAREs as they arise in robust
        control (H_infinity optimization).
Specification 
      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     .. Scalar Arguments ..
      INTEGER          INFO, LDA, LDB, LDC, LDG, LDQ, LDWORK, LDX, M, N,
     $                 P
      CHARACTER        DEF
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)
Arguments

Mode Parameters 

  DEF     CHARACTER
          This parameter specifies if the default parameters are
          to be used or not.
          = 'N' or 'n' : The parameters given in the input vectors
                         xPAR (x = 'D', 'I', 'B', 'CH') are used.
          = 'D' or 'd' : The default parameters for the example
                         are used.
          This parameter is not meaningful if NR(1) = 1.
Input/Output Parameters 
  NR      (input) INTEGER array, dimension (2)
          This array determines the example for which CAREX returns
          data. NR(1) is the group of examples.
          NR(1) = 1 : parameter-free problems of fixed size.
          NR(1) = 2 : parameter-dependent problems of fixed size.
          NR(1) = 3 : parameter-free problems of scalable size.
          NR(1) = 4 : parameter-dependent problems of scalable size.
          NR(2) is the number of the example in group NR(1).
          Let NEXi be the number of examples in group i. Currently,
          NEX1 = 6, NEX2 = 9, NEX3 = 2, NEX4 = 4.
          1 <= NR(1) <= 4;
          1 <= NR(2) <= NEXi , where i = NR(1).

  DPAR    (input/output) DOUBLE PRECISION array, dimension (7)
          Double precision parameter vector. For explanation of the
          parameters see [1].
          DPAR(1)           : defines the parameters
                              'delta' for NR(1) = 3,
                              'q' for NR(1).NR(2) = 4.1,
                              'a' for NR(1).NR(2) = 4.2, and
                              'mu' for NR(1).NR(2) = 4.3.
          DPAR(2)           : defines parameters
                              'r' for NR(1).NR(2) = 4.1,
                              'b' for NR(1).NR(2) = 4.2, and
                              'delta' for NR(1).NR(2) = 4.3.
          DPAR(3)           : defines parameters
                              'c' for NR(1).NR(2) = 4.2 and
                              'kappa' for NR(1).NR(2) = 4.3.
          DPAR(j), j=4,5,6,7: These arguments are only used to
                              generate Example 4.2 and define in
                              consecutive order the intervals
                              ['beta_1', 'beta_2'],
                              ['gamma_1', 'gamma_2'].
          NOTE that if DEF = 'D' or 'd', the values of DPAR entries
          on input are ignored and, on output, they are overwritten
          with the default parameters.

  IPAR    (input/output) INTEGER array, dimension (3)
          On input, IPAR(1) determines the actual state dimension,
          i.e., the order of the matrix A as follows, where
          NO = NR(1).NR(2).
          NR(1) = 1 or 2.1-2.8: IPAR(1) is ignored.
          NO = 2.9            : IPAR(1) = 1 generates the CARE for
                                optimal state feedback (default);
                                IPAR(1) = 2 generates the Kalman
                                filter CARE.
          NO = 3.1            : IPAR(1) is the number of vehicles
                                (parameter 'l' in the description
                                 in [1]).
          NO = 3.2, 4.1 or 4.2: IPAR(1) is the order of the matrix
                                A.
          NO = 4.3 or 4.4     : IPAR(1) determines the dimension of
                                the second-order system, i.e., the
                                order of the stiffness matrix for
                                Examples 4.3 and 4.4 (parameter 'l'
                                in the description in [1]).

          The order of the output matrix A is N = 2*IPAR(1) for
          Example 4.3 and N = 2*IPAR(1)-1 for Examples 3.1 and 4.4.
          NOTE that IPAR(1) is overwritten for Examples 1.1-2.8. For
          the other examples, IPAR(1) is overwritten if the default
          parameters are to be used.
          On output, IPAR(1) contains the order of the matrix A.

          On input, IPAR(2) is the number of colums in the matrix B
          in (I) (in control problems, the number of inputs of the
          system). Currently, IPAR(2) is fixed or determined by
          IPAR(1) for all examples and thus is not referenced on
          input.
          On output, IPAR(2) is the number of columns of the
          matrix B from (I).
          NOTE that currently IPAR(2) is overwritten and that
          rank(G) <= IPAR(2).

          On input, IPAR(3) is the number of rows in the matrix C
          in (II) (in control problems, the number of outputs of the
          system). Currently, IPAR(3) is fixed or determined by
          IPAR(1) for all examples and thus is not referenced on
          input.
          On output, IPAR(3) contains the number of rows of the
          matrix C in (II).
          NOTE that currently IPAR(3) is overwritten and that
          rank(Q) <= IPAR(3).

  BPAR    (input) BOOLEAN array, dimension (6)
          This array defines the form of the output of the examples
          and the storage mode of the matrices G and Q.
          BPAR(1) = .TRUE.  : G is returned.
          BPAR(1) = .FALSE. : G is returned in factored form, i.e.,
                              B and R from (I) are returned.
          BPAR(2) = .TRUE.  : The matrix returned in array G (i.e.,
                              G if BPAR(1) = .TRUE. and R if
                              BPAR(1) = .FALSE.) is stored as full
                              matrix.
          BPAR(2) = .FALSE. : The matrix returned in array G is
                              provided in packed storage mode.
          BPAR(3) = .TRUE.  : If BPAR(2) = .FALSE., the matrix
                              returned in array G is stored in upper
                              packed mode, i.e., the upper triangle
                              of a symmetric n-by-n matrix is stored
                              by columns, e.g., the matrix entry
                              G(i,j) is stored in the array entry
                              G(i+j*(j-1)/2) for i <= j.
                              Otherwise, this entry is ignored.
          BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix
                              returned in array G is stored in lower
                              packed mode, i.e., the lower triangle
                              of a symmetric n-by-n matrix is stored
                              by columns, e.g., the matrix entry
                              G(i,j) is stored in the array entry
                              G(i+(2*n-j)*(j-1)/2) for j <= i.
                              Otherwise, this entry is ignored.
          BPAR(4) = .TRUE.  : Q is returned.
          BPAR(4) = .FALSE. : Q is returned in factored form, i.e.,
                              C and W from (II) are returned.
          BPAR(5) = .TRUE.  : The matrix returned in array Q (i.e.,
                              Q if BPAR(4) = .TRUE. and W if
                              BPAR(4) = .FALSE.) is stored as full
                              matrix.
          BPAR(5) = .FALSE. : The matrix returned in array Q is
                              provided in packed storage mode.
          BPAR(6) = .TRUE.  : If BPAR(5) = .FALSE., the matrix
                              returned in array Q is stored in upper
                              packed mode (see above).
                              Otherwise, this entry is ignored.
          BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix
                              returned in array Q is stored in lower
                              packed mode (see above).
                              Otherwise, this entry is ignored.
          NOTE that there are no default values for BPAR.  If all
          entries are declared to be .TRUE., then matrices G and Q
          are returned in conventional storage mode, i.e., as
          N-by-N arrays where the array element Z(I,J) contains the
          matrix entry Z_{i,j}.

  CHPAR   (input/output) CHARACTER*255
          On input, this is the name of a data file supplied by the
          user.
          In the current version, only Example 4.4 allows a
          user-defined data file. This file must contain
          consecutively DOUBLE PRECISION vectors mu, delta, gamma,
          and kappa. The length of these vectors is determined by
          the input value for IPAR(1).
          If on entry, IPAR(1) = L, then mu and delta must each
          contain L DOUBLE PRECISION values, and gamma and kappa
          must each contain L-1 DOUBLE PRECISION values.
          On output, this string contains short information about
          the chosen example.

  VEC     (output) LOGICAL array, dimension (9)
          Flag vector which displays the availability of the output
          data:
          VEC(j), j=1,2,3, refer to N, M, and P, respectively, and
          are always .TRUE.
          VEC(4) refers to A and is always .TRUE.
          VEC(5) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors B
          and R from (I) are returned.
          VEC(6) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors C
          and W from (II) are returned.
          VEC(7) refers to G and is always .TRUE.
          VEC(8) refers to Q and is always .TRUE.
          VEC(9) refers to X and is .TRUE. if the exact solution
          matrix is available.
          NOTE that VEC(i) = .FALSE. for i = 1 to 9 if on exit
          INFO .NE. 0.

  N       (output) INTEGER
          The order of the matrices A, X, G if BPAR(1) = .TRUE., and
          Q if BPAR(4) = .TRUE.

  M       (output) INTEGER
          The number of columns in the matrix B (or the dimension of
          the control input space of the underlying dynamical
          system).

  P       (output) INTEGER
          The number of rows in the matrix C (or the dimension of
          the output space of the underlying dynamical system).

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the
          coefficient matrix A of the CARE.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          If (BPAR(1) = .FALSE.), then the leading N-by-M part of
          this array contains the matrix B of the factored form (I)
          of G. Otherwise, B is used as workspace.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= N.

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          If (BPAR(4) = .FALSE.), then the leading P-by-N part of
          this array contains the matrix C of the factored form (II)
          of Q. Otherwise, C is used as workspace.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= P, where P is the number of rows of the matrix C,
          i.e., the output value of IPAR(3). (For all examples,
          P <= N, where N equals the output value of the argument
          IPAR(1), i.e., LDC >= LDA is always safe.)

  G       (output) DOUBLE PRECISION array, dimension (NG)
          If (BPAR(2) = .TRUE.)  then NG = LDG*N.
          If (BPAR(2) = .FALSE.) then NG = N*(N+1)/2.
          If (BPAR(1) = .TRUE.), then array G contains the
          coefficient matrix G of the CARE.
          If (BPAR(1) = .FALSE.), then array G contains the 'control
          weighting matrix' R of G's factored form as in (I). (For
          all examples, M <= N.) The symmetric matrix contained in
          array G is stored according to BPAR(2) and BPAR(3).

  LDG     INTEGER
          If conventional storage mode is used for G, i.e.,
          BPAR(2) = .TRUE., then G is stored like a 2-dimensional
          array with leading dimension LDG. If packed symmetric
          storage mode is used, then LDG is not referenced.
          LDG >= N if BPAR(2) = .TRUE..

  Q       (output) DOUBLE PRECISION array, dimension (NQ)
          If (BPAR(5) = .TRUE.)  then NQ = LDQ*N.
          If (BPAR(5) = .FALSE.) then NQ = N*(N+1)/2.
          If (BPAR(4) = .TRUE.), then array Q contains the
          coefficient matrix Q of the CARE.
          If (BPAR(4) = .FALSE.), then array Q contains the 'output
          weighting matrix' W of Q's factored form as in (II).
          The symmetric matrix contained in array Q is stored
          according to BPAR(5) and BPAR(6).

  LDQ     INTEGER
          If conventional storage mode is used for Q, i.e.,
          BPAR(5) = .TRUE., then Q is stored like a 2-dimensional
          array with leading dimension LDQ. If packed symmetric
          storage mode is used, then LDQ is not referenced.
          LDQ >= N if BPAR(5) = .TRUE..

  X       (output) DOUBLE PRECISION array, dimension (LDX,IPAR(1))
          If an exact solution is available (NR = 1.1, 1.2, 2.1,
          2.3-2.6, 3.2), then the leading N-by-N part of this array
          contains the solution matrix X in conventional storage
          mode. Otherwise, X is not referenced.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= 1, and
          LDX >= N if NR = 1.1, 1.2, 2.1, 2.3-2.6, 3.2.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= N*MAX(4,N).
Error Indicator 
  INFO    INTEGER
          = 0 : successful exit;
          < 0 : if INFO = -i, the i-th argument had an illegal
                value;
          = 1 : data file could not be opened or had wrong format;
          = 2 : division by zero;
          = 3 : G can not be computed as in (I) due to a singular R
                matrix.
References 
  [1] Abels, J. and Benner, P.
      CAREX - A Collection of Benchmark Examples for Continuous-Time
      Algebraic Riccati Equations (Version 2.0).
      SLICOT Working Note 1999-14, November 1999. Available from
      http://www.win.tue.nl/niconet/NIC2/reports.html.

  This is an updated and extended version of

  [2] Benner, P., Laub, A.J., and Mehrmann, V.
      A Collection of Benchmark Examples for the Numerical Solution
      of Algebraic Riccati Equations I: Continuous-Time Case.
      Technical Report SPC 95_22, Fak. f. Mathematik,
      TU Chemnitz-Zwickau (Germany), October 1995.
Numerical Aspects 
  If the original data as taken from the literature is given via
  matrices G and Q, but factored forms are requested as output, then
  these factors are obtained from Cholesky or LDL' decompositions of
  G and Q, i.e., the output data will be corrupted by roundoff
  errors.
Further Comments 
  Some benchmark examples read data from the data files provided
  with the collection.
Example

Program Text 

*     BB01AD EXAMPLE PROGRAM TEXT
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, PMAX
      PARAMETER        ( MMAX = 100, NMAX = 100, PMAX = 100 )
      INTEGER          LDA, LDB, LDC, LDG, LDQ, LDX
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDG = NMAX, LDQ = NMAX, LDX = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*MAX( 4, NMAX ) )
*     .. Local Scalars ..
      CHARACTER        DEF
      INTEGER          I, INFO, ISYMM, J, LBPAR, LDPAR, LIPAR, M, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), B(LDB,MMAX), C(LDC, NMAX),
     $                 DPAR(7), DWORK(LDWORK), G(LDG, NMAX),
     $                 Q(LDQ, NMAX), X(LDX, NMAX)
      INTEGER          IPAR(3), NR(2)
      LOGICAL          BPAR(6), VEC(9)
      CHARACTER        CHPAR(255)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         BB01AD, MA02DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ( NIN, FMT = '()' )
      READ( NIN, FMT = * ) DEF
      READ( NIN, FMT = * ) ( NR(I), I = 1, 2 )
      IF( LSAME( DEF, 'N' ) ) THEN
        READ( NIN, FMT = * ) LBPAR
        IF( LBPAR.GT.0 )  READ( NIN, FMT = * ) ( BPAR(I), I = 1, LBPAR )
        READ( NIN, FMT = * ) LDPAR
        IF( LDPAR.GT.0 )  READ( NIN, FMT = * ) ( DPAR(I), I = 1, LDPAR )
        READ( NIN, FMT = * ) LIPAR
        IF( LIPAR.GT.0 )  READ( NIN, FMT = * ) ( IPAR(I), I = 1, LIPAR )
      END IF
*     Generate benchmark example
      CALL BB01AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, A,
     $             LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, DWORK,
     $             LDWORK, INFO )
*
      IF( INFO.NE.0 ) THEN
        WRITE( NOUT, FMT = 99998 ) INFO
      ELSE
        WRITE( NOUT, FMT = * ) CHPAR(1:70)
        WRITE( NOUT, FMT = 99997 ) N
        WRITE( NOUT, FMT = 99996 ) M
        WRITE( NOUT, FMT = 99995 ) P
        WRITE( NOUT, FMT = 99994 )
        DO 10  I = 1, N
          WRITE( NOUT, FMT = 99979 ) ( A(I,J), J = 1, N )
   10   CONTINUE
        IF( VEC(5) ) THEN
          WRITE( NOUT, FMT = 99993 )
          DO 20  I = 1, N
            WRITE( NOUT, FMT = 99979 ) ( B(I,J), J = 1, M )
   20     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99992 )
        END IF
        IF( VEC(6) ) THEN
          WRITE( NOUT,FMT = 99991 )
          DO 30  I = 1, P
            WRITE( NOUT, FMT = 99979 ) ( C(I,J), J = 1, N )
   30     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99990 )
        END IF
        IF( .NOT.VEC(5) ) THEN
          WRITE( NOUT, FMT = 99989 )
          IF( .NOT.BPAR(2) ) THEN
            ISYMM = ( N * ( N + 1 ) ) / 2
            CALL DCOPY( ISYMM, G, 1, DWORK, 1 )
            IF( BPAR(3) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', N, G, LDG, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', N, G, LDG, DWORK )
            END IF
          END IF
          DO 40  I = 1, N
            WRITE( NOUT, FMT = 99979 ) ( G(I,J), J = 1, N )
   40     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99988 )
        END IF
        IF( .NOT.VEC(6) ) THEN
          IF( .NOT. BPAR(5) ) THEN
            ISYMM = ( N * ( N + 1 ) ) / 2
            CALL DCOPY( ISYMM, Q, 1, DWORK, 1 )
            IF( BPAR(6) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', N, Q, LDQ, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', N, Q, LDQ, DWORK )
            END IF
          END IF
          WRITE( NOUT, FMT = 99987 )
          DO 50  I = 1, N
            WRITE( NOUT, FMT = 99979 ) ( Q(I,J), J = 1, N )
   50     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99986 )
        END IF
        IF( VEC(6) ) THEN
          IF( .NOT.BPAR(5) ) THEN
            ISYMM = ( P * ( P + 1 ) ) / 2
            CALL DCOPY( ISYMM, Q, 1, DWORK, 1 )
            IF( BPAR(6) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', P, Q, LDQ, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', P, Q, LDQ, DWORK )
            END IF
          END IF
          WRITE( NOUT, FMT = 99985 )
          DO 60  I = 1, N
            WRITE( NOUT, FMT = 99979 ) ( Q(I,J), J = 1, N )
   60     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99984 )
        END IF
        IF( VEC(5) ) THEN
          IF( .NOT.BPAR(2) ) THEN
            ISYMM = ( M * ( M + 1 ) ) / 2
            CALL DCOPY( ISYMM, G, 1, DWORK, 1 )
            IF( BPAR(3) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', M, G, LDG, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', M, G, LDG, DWORK )
            END IF
          END IF
          WRITE( NOUT, FMT = 99983 )
          DO 70  I = 1, N
            WRITE( NOUT, FMT = 99979 ) ( G(I,J), J = 1, N )
   70     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99982 )
        END IF
        IF( VEC(9) ) THEN
          WRITE( NOUT, FMT = 99981 )
          DO 80  I = 1, N
            WRITE( NOUT, FMT = 99979 ) ( X(I,J), J = 1, N )
   80     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99980 )
        END IF
      END IF
      STOP
*
99999 FORMAT (' BB01AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from BB03AD = ', I3)
99997 FORMAT (/' Order of matrix A:              N  = ', I3)
99996 FORMAT (' Number of columns in matrix B:  M  = ', I3)
99995 FORMAT (' Number of rows in matrix C:     P  = ', I3)
99994 FORMAT (' A  = ')
99993 FORMAT (' B  = ')
99992 FORMAT (' B is not provided.')
99991 FORMAT (' C  = ')
99990 FORMAT (' C is not provided.')
99989 FORMAT (' G  = ')
99988 FORMAT (' G is not provided.')
99987 FORMAT (' Q  = ')
99986 FORMAT (' Q is not provided.')
99985 FORMAT (' W  = ')
99984 FORMAT (' W is not provided.')
99983 FORMAT (' R  = ')
99982 FORMAT (' R is not provided.')
99981 FORMAT (' X  = ')
99980 FORMAT (' X is not provided.')
99979 FORMAT (20(1X,F8.4))
*
      END
Program Data 
BB01AD EXAMPLE PROGRAM DATA
N
2 3
6
.T. .T. .T. .F. .F. .T.
1
.1234
0
Program Results 
 BB01AD EXAMPLE PROGRAM RESULTS

 Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo       

 Order of matrix A:              N  =   2
 Number of columns in matrix B:  M  =   1
 Number of rows in matrix C:     P  =   2
 A  = 
   0.0000   0.1234
   0.0000   0.0000
 B is not provided.
 C  = 
   1.0000   0.0000
   0.0000   1.0000
 G  = 
   0.0000   0.0000
   0.0000   1.0000
 Q is not provided.
 W  = 
   1.0000   0.0000
   0.0000   1.0000
 R is not provided.
 X  = 
   9.0486   1.0000
   1.0000   1.1166

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/BB02AD.html000077500000000000000000000535031201767322700160440ustar00rootroot00000000000000 BB02AD - SLICOT Library Routine Documentation

BB02AD

Benchmark examples for discrete-time algebraic Riccati equations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate the benchmark examples for the numerical solution of
  discrete-time algebraic Riccati equations (DAREs) of the form

         T                T               T    -1  T       T
  0  =  A X A  -  X  -  (A X B + S) (R + B X B)  (B X A + S )  +  Q

  as presented in [1]. Here, A,Q,X are real N-by-N matrices, B,S are
  N-by-M, and R is M-by-M. The matrices Q and R are symmetric and Q
  may be given in factored form

                T
  (I)    Q  =  C Q0 C .

  Here, C is P-by-N and Q0 is P-by-P. If R is nonsingular and S = 0,
  the DARE can be rewritten equivalently as

               T             -1
  0  =  X  -  A X (I_n + G X)  A  -  Q,

  where I_n is the N-by-N identity matrix and

                -1  T
  (II)   G = B R   B .
Specification 
      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     .. Scalar Arguments ..
      INTEGER          INFO, LDA, LDB, LDC, LDQ, LDR, LDS, LDWORK, LDX,
     $                 M, N, P
      CHARACTER        DEF
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)
Arguments

Mode Parameters 

  DEF     CHARACTER
          This parameter specifies if the default parameters are
          to be used or not.
          = 'N' or 'n' : The parameters given in the input vectors
                         xPAR (x = 'D', 'I', 'B', 'CH') are used.
          = 'D' or 'd' : The default parameters for the example
                         are used.
          This parameter is not meaningful if NR(1) = 1.
Input/Output Parameters 
  NR      (input) INTEGER array, dimension (2)
          This array determines the example for which DAREX returns
          data. NR(1) is the group of examples.
          NR(1) = 1 : parameter-free problems of fixed size.
          NR(1) = 2 : parameter-dependent problems of fixed size.
          NR(1) = 3 : parameter-free problems of scalable size.
          NR(1) = 4 : parameter-dependent problems of scalable size.
          NR(2) is the number of the example in group NR(1).
          Let NEXi be the number of examples in group i. Currently,
          NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1.
          1 <= NR(1) <= 4;
          0 <= NR(2) <= NEXi, where i = NR(1).

  DPAR    (input/output) DOUBLE PRECISION array, dimension (4)
          Double precision parameter vector. For explanation of the
          parameters see [1].
          DPAR(1) defines the parameter 'epsilon' for
          examples NR = 2.2,2.3,2.4, the parameter 'tau'
          for NR = 2.5, and the 1-by-1 matrix R for NR = 2.1,4.1.
          For Example 2.5, DPAR(2) - DPAR(4) define in
          consecutive order 'D', 'K', and 'r'.
          NOTE that DPAR is overwritten with default values
          if DEF = 'D' or 'd'.

  IPAR    (input/output) INTEGER array, dimension (3)
          On input, IPAR(1) determines the actual state dimension,
          i.e., the order of the matrix A as follows:
          NR(1) = 1, NR(1) = 2   : IPAR(1) is ignored.
          NR = NR(1).NR(2) = 4.1 : IPAR(1) determines the order of
                                   the output matrix A.
          NOTE that IPAR(1) is overwritten for Examples 1.1-2.3. For
          the other examples, IPAR(1) is overwritten if the default
          parameters are to be used.
          On output, IPAR(1) contains the order of the matrix A.

          On input, IPAR(2) is the number of colums in the matrix B
          and the order of the matrix R (in control problems, the
          number of inputs of the system). Currently, IPAR(2) is
          fixed for all examples and thus is not referenced on
          input.
          On output, IPAR(2) is the number of columns of the
          matrix B from (I).

          On input, IPAR(3) is the number of rows in the matrix C
          (in control problems, the number of outputs of the
          system). Currently, IPAR(3) is fixed for all examples
          and thus is not referenced on input.
          On output, IPAR(3) is the number of rows of the matrix C
          from (I).

          NOTE that IPAR(2) and IPAR(3) are overwritten and
          IPAR(2) <= IPAR(1) and IPAR(3) <= IPAR(1) for all
          examples.

  BPAR    (input) LOGICAL array, dimension (7)
          This array defines the form of the output of the examples
          and the storage mode of the matrices Q, G or R.
          BPAR(1) = .TRUE.  : Q is returned.
          BPAR(1) = .FALSE. : Q is returned in factored form, i.e.,
                              Q0 and C from (I) are returned.
          BPAR(2) = .TRUE.  : The matrix returned in array Q (i.e.,
                              Q if BPAR(1) = .TRUE. and Q0 if
                              BPAR(1) = .FALSE.) is stored as full
                              matrix.
          BPAR(2) = .FALSE. : The matrix returned in array Q is
                              provided in packed storage mode.
          BPAR(3) = .TRUE.  : If BPAR(2) = .FALSE., the matrix
                              returned in array Q is stored in upper
                              packed mode, i.e., the upper triangle
                              of a symmetric n-by-n matrix is stored
                              by columns, e.g., the matrix entry
                              Q(i,j) is stored in the array entry
                              Q(i+j*(j-1)/2) for i <= j.
                              Otherwise, this entry is ignored.
          BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix
                              returned in array Q is stored in lower
                              packed mode, i.e., the lower triangle
                              of a symmetric n-by-n matrix is stored
                              by columns, e.g., the matrix entry
                              Q(i,j) is stored in the array entry
                              Q(i+(2*n-j)*(j-1)/2) for j <= i.
                              Otherwise, this entry is ignored.
          BPAR(4) = .TRUE.  : The product G in (II) is returned.
          BPAR(4) = .FALSE. : G is returned in factored form, i.e.,
                              B and R from (II) are returned.
          BPAR(5) = .TRUE.  : The matrix returned in array R (i.e.,
                              G if BPAR(4) = .TRUE. and R if
                              BPAR(4) = .FALSE.) is stored as full
                              matrix.
          BPAR(5) = .FALSE. : The matrix returned in array R is
                              provided in packed storage mode.
          BPAR(6) = .TRUE.  : If BPAR(5) = .FALSE., the matrix
                              returned in array R is stored in upper
                              packed mode (see above).
                              Otherwise, this entry is ignored.
          BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix
                              returned in array R is stored in lower
                              packed mode (see above).
                              Otherwise, this entry is ignored.
          BPAR(7) = .TRUE.  : The coefficient matrix S of the DARE
                              is returned in array S.
          BPAR(7) = .FALSE. : The coefficient matrix S of the DARE
                              is not returned.
          NOTE that there are no default values for BPAR.  If all
          entries are declared to be .TRUE., then matrices Q, G or R
          are returned in conventional storage mode, i.e., as
          N-by-N or M-by-M arrays where the array element Z(I,J)
          contains the matrix entry Z_{i,j}.

  CHPAR   (output) CHARACTER*255
          On output, this string contains short information about
          the chosen example.

  VEC     (output) LOGICAL array, dimension (10)
          Flag vector which displays the availability of the output
          data:
          VEC(j), j=1,2,3, refer to N, M, and P, respectively, and
          are always .TRUE.
          VEC(4) refers to A and is always .TRUE.
          VEC(5) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors B
          and R from (II) are returned.
          VEC(6) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors C
          and Q0 from (I) are returned.
          VEC(7) refers to Q and is always .TRUE.
          VEC(8) refers to R and is always .TRUE.
          VEC(9) is .TRUE. if BPAR(7) = .TRUE., i.e., the matrix S
          is returned.
          VEC(10) refers to X and is .TRUE. if the exact solution
          matrix is available.
          NOTE that VEC(i) = .FALSE. for i = 1 to 10 if on exit
          INFO .NE. 0.

  N       (output) INTEGER
          The order of the matrices A, X, G if BPAR(4) = .TRUE., and
          Q if BPAR(1) = .TRUE.

  M       (output) INTEGER
          The number of columns in the matrix B (or the dimension of
          the control input space of the underlying dynamical
          system).

  P       (output) INTEGER
          The number of rows in the matrix C (or the dimension of
          the output space of the underlying dynamical system).

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the
          coefficient matrix A of the DARE.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          If (BPAR(4) = .FALSE.), then the leading N-by-M part
          of this array contains the coefficient matrix B of
          the DARE.  Otherwise, B is used as workspace.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= N.

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          If (BPAR(1) = .FALSE.), then the leading P-by-N part
          of this array contains the matrix C of the factored
          form (I) of Q.  Otherwise, C is used as workspace.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= P.

  Q       (output) DOUBLE PRECISION array, dimension (NQ)
          If (BPAR(1) = .TRUE.) and (BPAR(2) = .TRUE.), then
          NQ = LDQ*N.
          IF (BPAR(1) = .TRUE.) and (BPAR(2) = .FALSE.), then
          NQ = N*(N+1)/2.
          If (BPAR(1) = .FALSE.) and (BPAR(2) = .TRUE.), then
          NQ = LDQ*P.
          IF (BPAR(1) = .FALSE.) and (BPAR(2) = .FALSE.), then
          NQ = P*(P+1)/2.
          The symmetric matrix contained in array Q is stored
          according to BPAR(2) and BPAR(3).

  LDQ     INTEGER
          If conventional storage mode is used for Q, i.e.,
          BPAR(2) = .TRUE., then Q is stored like a 2-dimensional
          array with leading dimension LDQ. If packed symmetric
          storage mode is used, then LDQ is irrelevant.
          LDQ >= N if BPAR(1) = .TRUE.;
          LDQ >= P if BPAR(1) = .FALSE..

  R       (output) DOUBLE PRECISION array, dimension (MR)
          If (BPAR(4) = .TRUE.) and (BPAR(5) = .TRUE.), then
          MR = LDR*N.
          IF (BPAR(4) = .TRUE.) and (BPAR(5) = .FALSE.), then
          MR = N*(N+1)/2.
          If (BPAR(4) = .FALSE.) and (BPAR(5) = .TRUE.), then
          MR = LDR*M.
          IF (BPAR(4) = .FALSE.) and (BPAR(5) = .FALSE.), then
          MR = M*(M+1)/2.
          The symmetric matrix contained in array R is stored
          according to BPAR(5) and BPAR(6).

  LDR     INTEGER
          If conventional storage mode is used for R, i.e.,
          BPAR(5) = .TRUE., then R is stored like a 2-dimensional
          array with leading dimension LDR. If packed symmetric
          storage mode is used, then LDR is irrelevant.
          LDR >= N  if BPAR(4) =  .TRUE.;
          LDR >= M  if BPAR(4) = .FALSE..

  S       (output) DOUBLE PRECISION array, dimension (LDS,M)
          If (BPAR(7) = .TRUE.), then the leading N-by-M part of
          this array contains the coefficient matrix S of the DARE.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= 1, and
          LDS >= N if BPAR(7) = .TRUE..

  X       (output) DOUBLE PRECISION array, dimension (LDX,NX)
          If an exact solution is available (NR = 1.1,1.3,1.4,2.1,
          2.3,2.4,2.5,4.1), then NX = N and the leading N-by-N part
          of this array contains the solution matrix X.
          Otherwise, X is not referenced.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= 1, and
          LDX >= N if an exact solution is available.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= N*N.
Error Indicator 
  INFO    INTEGER
          = 0 : successful exit;
          < 0 : if INFO = -i, the i-th argument had an illegal
                value;
          = 1 : data file could not be opened or had wrong format;
          = 2 : division by zero;
          = 3 : G can not be computed as in (II) due to a singular R
                matrix. This error can only occur if
                BPAR(4) = .TRUE..
References 
  [1] Abels, J. and Benner, P.
      DAREX - A Collection of Benchmark Examples for Discrete-Time
      Algebraic Riccati Equations (Version 2.0).
      SLICOT Working Note 1999-16, November 1999. Available from
      http://www.win.tue.nl/niconet/NIC2/reports.html.

  This is an updated and extended version of

  [2] Benner, P., Laub, A.J., and Mehrmann, V.
      A Collection of Benchmark Examples for the Numerical Solution
      of Algebraic Riccati Equations II: Discrete-Time Case.
      Technical Report SPC 95_23, Fak. f. Mathematik,
      TU Chemnitz-Zwickau (Germany), December 1995.
Further Comments 
  Some benchmark examples read data from the data files provided
  with the collection.
Example

Program Text 

*     BB02AD EXAMPLE PROGRAM TEXT
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, PMAX
      PARAMETER        ( MMAX = 100, NMAX = 100, PMAX = 100 )
      INTEGER          LDA, LDB, LDC, LDQ, LDR, LDS, LDX
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDQ = NMAX, LDR = NMAX, LDS = NMAX,
     $                   LDX = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*NMAX )
*     .. Local Scalars ..
      CHARACTER        DEF
      INTEGER          I, INFO, ISYMM, J, LBPAR, LDPAR, LIPAR, M, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), B(LDB,MMAX), C(LDC, NMAX),
     $                 DPAR(4), DWORK(LDWORK), Q(LDQ, NMAX),
     $                 R(LDR, NMAX), S(LDS, NMAX), X(LDX, NMAX)
      INTEGER          IPAR(3), NR(2)
      LOGICAL          BPAR(7), VEC(10)
      CHARACTER        CHPAR(255)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         BB02AD, MA02DD
*     .. Executable Statements ..
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ( NIN, FMT = '()' )
      READ( NIN, FMT = * ) DEF
      READ( NIN, FMT = * ) ( NR(I), I = 1, 2 )
      IF( LSAME( DEF, 'N' ) ) THEN
        READ( NIN, FMT = * ) LBPAR
        IF( LBPAR.GT.0 ) READ( NIN, FMT = * ) ( BPAR(I), I = 1, LBPAR )
        READ( NIN, FMT = * ) LDPAR
        IF( LDPAR.GT.0 ) READ( NIN, FMT = * ) ( DPAR(I), I = 1, LDPAR )
        READ( NIN, FMT = * ) LIPAR
        IF( LIPAR.GT.0 ) READ( NIN, FMT = * ) ( IPAR(I), I = 1, LIPAR )
      END IF
*     Generate benchmark example
      CALL BB02AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, A,
     $             LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, X, LDX,
     $             DWORK, LDWORK, INFO )
*
      IF( INFO.NE.0 ) THEN
        WRITE( NOUT, FMT = 99998 ) INFO
      ELSE
        WRITE( NOUT, FMT = * ) CHPAR(1:70)
        WRITE( NOUT, FMT = 99997 ) N
        WRITE( NOUT, FMT = 99996 ) M
        WRITE( NOUT, FMT = 99995 ) P
        WRITE( NOUT, FMT = 99994 )
        DO 10  I = 1, N
          WRITE( NOUT, FMT = 99977 ) ( A(I,J), J = 1, N )
   10   CONTINUE
        IF( VEC(5) ) THEN
          WRITE( NOUT, FMT = 99993 )
          DO 20  I = 1, N
            WRITE( NOUT, FMT = 99977 ) ( B(I,J), J = 1, M )
   20     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99992 )
        END IF
        IF( VEC(6) ) THEN
          WRITE( NOUT,FMT = 99991 )
          DO 30  I = 1, P
            WRITE( NOUT, FMT = 99977 ) ( C(I,J), J = 1, N )
   30     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99990 )
        END IF
        IF( .NOT.VEC(5) ) THEN
          WRITE( NOUT, FMT = 99989 )
          IF( .NOT.BPAR(2) ) THEN
            ISYMM = ( N * ( N + 1 ) ) / 2
            CALL DCOPY( ISYMM, R, 1, DWORK, 1 )
            IF( BPAR(3) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', N, R, LDR, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', N, R, LDR, DWORK )
            END IF
          END IF
          DO 40  I = 1, N
            WRITE( NOUT, FMT = 99977 ) ( R(I,J), J = 1, N )
   40     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99988 )
        END IF
        IF( .NOT.VEC(6) ) THEN
          IF( .NOT.BPAR(5) ) THEN
            ISYMM = ( N * ( N + 1 ) ) / 2
            CALL DCOPY( ISYMM, Q, 1, DWORK, 1 )
            IF( BPAR(6) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', N, Q, LDQ, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', N, Q, LDQ, DWORK )
            END IF
          END IF
          WRITE( NOUT, FMT = 99987 )
          DO 50  I = 1, N
            WRITE( NOUT, FMT = 99977 ) ( Q(I,J), J = 1, N )
   50     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99986 )
        END IF
        IF( VEC(6) ) THEN
          IF( .NOT.BPAR(5) ) THEN
            ISYMM = ( P * ( P + 1 ) ) / 2
            CALL DCOPY( ISYMM, Q, 1, DWORK, 1 )
            IF( BPAR(6) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', P, Q, LDQ, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', P, Q, LDQ, DWORK )
            END IF
          END IF
          WRITE( NOUT, FMT = 99985 )
          DO 60  I = 1, P
            WRITE( NOUT, FMT = 99977 ) ( Q(I,J), J = 1, P )
   60     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99984 )
        END IF
        IF( VEC(5) ) THEN
          IF( .NOT.BPAR(2) ) THEN
            ISYMM = ( M * ( M + 1 ) ) / 2
            CALL DCOPY( ISYMM, R, 1, DWORK, 1 )
            IF( BPAR(3) ) THEN
              CALL MA02DD( 'Unpack', 'Upper', M, R, LDR, DWORK )
            ELSE
              CALL MA02DD( 'Unpack', 'Lower', M, R, LDR, DWORK )
            END IF
          END IF
          WRITE( NOUT, FMT = 99983 )
          DO 70  I = 1, M
            WRITE( NOUT, FMT = 99977 ) ( R(I,J), J = 1, M )
   70     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99982 )
        END IF
        IF( VEC(9) ) THEN
          WRITE( NOUT, FMT = 99981 )
          DO 80  I = 1, N
            WRITE( NOUT, FMT = 99977 ) ( S(I,J), J = 1, M )
   80     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99980 )
        END IF
        IF( VEC(10) ) THEN
          WRITE( NOUT, FMT = 99979 )
          DO 90  I = 1, N
            WRITE( NOUT, FMT = 99977 ) ( X(I,J), J = 1, N )
   90     CONTINUE
        ELSE
          WRITE( NOUT, FMT = 99978 )
        END IF
      END IF
      STOP
*
99999 FORMAT (' BB02AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from BB02AD = ', I3)
99997 FORMAT (/' Order of matrix A:              N  = ', I3)
99996 FORMAT (' Number of columns in matrix B:  M  = ', I3)
99995 FORMAT (' Number of rows in matrix C:     P  = ', I3)
99994 FORMAT (' A  = ')
99993 FORMAT (' B  = ')
99992 FORMAT (' B is not provided.')
99991 FORMAT (' C  = ')
99990 FORMAT (' C is not provided.')
99989 FORMAT (' G  = ')
99988 FORMAT (' G is not provided.')
99987 FORMAT (' Q  = ')
99986 FORMAT (' Q is not provided.')
99985 FORMAT (' Q0  = ')
99984 FORMAT (' Q0 is not provided.')
99983 FORMAT (' R  = ')
99982 FORMAT (' R is not provided.')
99981 FORMAT (' S  = ')
99980 FORMAT (' S is not provided.')
99979 FORMAT (' X  = ')
99978 FORMAT (' X is not provided.')
99977 FORMAT (20(1X,F8.4))
*
      END
Program Data 
BB02AD EXAMPLE PROGRAM DATA
N
2 3
7
.T. .T. .T. .F. .F. .T. .T.
1
.1234
0
Program Results 
 BB02AD EXAMPLE PROGRAM RESULTS

 increasingly bad scaled system as eps -> oo                           

 Order of matrix A:              N  =   2
 Number of columns in matrix B:  M  =   1
 Number of rows in matrix C:     P  =   2
 A  = 
   0.0000   0.1234
   0.0000   0.0000
 B  = 
   0.0000
   1.0000
 C is not provided.
 G is not provided.
 Q  = 
   1.0000   0.0000
   0.0000   1.0000
 Q0 is not provided.
 R  = 
   1.0000
 S  = 
   0.0000
   0.0000
 X  = 
   1.0000   0.0000
   0.0000   1.0152

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/BB03AD.html000077500000000000000000000311551201767322700160440ustar00rootroot00000000000000 BB03AD - SLICOT Library Routine Documentation

BB03AD

Benchmark examples of (generalized) continuous-time Lyapunov equations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate benchmark examples of (generalized) continuous-time
  Lyapunov equations

     T           T
    A  X  E  +  E  X A  =  Y .

  In some examples, the right hand side has the form

             T
    Y  =  - B  B

  and the solution can be represented as a product of Cholesky
  factors

           T
    X  =  U  U .

  E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note
  that E can be the identity matrix. For some examples, B, X, or U
  are not provided.

  This routine is an implementation of the benchmark library
  CTLEX (Version 1.0) described in [1].
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DEF     CHARACTER*1
          Specifies the kind of values used as parameters when
          generating parameter-dependent and scalable examples
          (i.e., examples with NR(1) = 2, 3, or 4):
          DEF = 'D' or 'd': Default values are used.
          DEF = 'N' or 'n': Values set in DPAR and IPAR are used.
          This parameter is not referenced if NR(1) = 1.
          Note that the scaling parameter of examples with
          NR(1) = 3 or 4 is considered as a regular parameter in
          this context.
Input/Output Parameters 
  NR      (input) INTEGER array, dimension 2
          Specifies the index of the desired example according
          to [1].
          NR(1) defines the group:
                1 : parameter-free problems of fixed size
                2 : parameter-dependent problems of fixed size
                3 : parameter-free problems of scalable size
                4 : parameter-dependent problems of scalable size
          NR(2) defines the number of the benchmark example
          within a certain group according to [1].

  DPAR    (input/output) DOUBLE PRECISION array, dimension 2
          On entry, if DEF = 'N' or 'n' and the desired example
          depends on real parameters, then the array DPAR must
          contain the values for these parameters.
          For an explanation of the parameters see [1].
          For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's',
          respectively.
          For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and
          's', respectively.
          For Examples 4.3 and 4.4, DPAR(1) defines the parameter
          't'.
          On exit, if DEF = 'D' or 'd' and the desired example
          depends on real parameters, then the array DPAR is
          overwritten by the default values given in [1].

  IPAR    (input/output) INTEGER array of DIMENSION at least 1
          On entry, if DEF = 'N' or 'n' and the desired example
          depends on integer parameters, then the array IPAR must
          contain the values for these parameters.
          For an explanation of the parameters see [1].
          For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'.
          For Example 4.4, IPAR(1) defines 'q'.
          On exit, if DEF = 'D' or 'd' and the desired example
          depends on integer parameters, then the array IPAR is
          overwritten by the default values given in [1].

  VEC     (output) LOGICAL array, dimension 8
          Flag vector which displays the availability of the output
          data:
          VEC(1) and VEC(2) refer to N and M, respectively, and are
          always .TRUE.
          VEC(3) is .TRUE. iff E is NOT the identity matrix.
          VEC(4) and VEC(5) refer to A and Y, respectively, and are
          always .TRUE.
          VEC(6) is .TRUE. iff B is provided.
          VEC(7) is .TRUE. iff the solution matrix X is provided.
          VEC(8) is .TRUE. iff the Cholesky factor U is provided.

  N       (output) INTEGER
          The actual state dimension, i.e., the order of the
          matrices E and A.

  M       (output) INTEGER
          The number of rows in the matrix B. If B is not provided
          for the desired example, M = 0 is returned.

  E       (output) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N part of this array contains the
          matrix E.
          NOTE that this array is overwritten (by the identity
          matrix), if VEC(3) = .FALSE.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= N.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
          The leading N-by-N part of this array contains the
          matrix Y.

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= N.

  B       (output) DOUBLE PRECISION array, dimension (LDB,N)
          The leading M-by-N part of this array contains the
          matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= M.

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array contains the
          matrix X.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= N.

  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array contains the
          matrix U.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= N.

  NOTE    (output) CHARACTER*70
          String containing short information about the chosen
          example.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is
          required.
          For the other examples, no workspace is needed, i.e.,
          LDWORK >= 1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value; in particular, INFO = -3 or -4 indicates
                that at least one of the parameters in DPAR or
                IPAR, respectively, has an illegal value.
References 
  [1]  D. Kressner, V. Mehrmann, and T. Penzl.
       CTLEX - a Collection of Benchmark Examples for Continuous-
       Time Lyapunov Equations.
       SLICOT Working Note 1999-6, 1999.
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

C     BB03AD EXAMPLE PROGRAM TEXT
C     Copyright (c) 2002-2010 NICONET e.V.
C
C     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        (NIN = 5, NOUT = 6)
      INTEGER          NMAX, MMAX
      PARAMETER        (NMAX = 100, MMAX = 100)
      INTEGER          LDE, LDA, LDY, LDB, LDX, LDU, LDWORK
      PARAMETER        (LDE = NMAX, LDA = NMAX, LDY = NMAX, LDB = MMAX,
     1                  LDX = NMAX, LDU = NMAX, LDWORK = 2*NMAX)
C     .. Local Scalars ..
      CHARACTER        DEF
      INTEGER          INFO, N, M, I, J, LDPAR, LIPAR
      CHARACTER*70     NOTE
C     .. Local Arrays ..
      DOUBLE PRECISION E(LDE,NMAX), A(LDA, NMAX), Y(LDY, NMAX),
     1                 B(LDB,NMAX), X(LDX, NMAX), U(LDU, NMAX),
     2                 DPAR(2), DWORK(LDWORK)
      INTEGER          NR(2), IPAR(1)
      LOGICAL          VEC(8)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
      EXTERNAL         BB03AD
C     .. Executable Statements ..
      WRITE (NOUT, FMT = 99999)
C     Skip the heading in the data file and read the data.
      READ (NIN, FMT = '()')
      READ (NIN, FMT = *) DEF
      READ (NIN, FMT = *) (NR(I), I = 1, 2)
      IF (LSAME(DEF,'N')) THEN
        READ (NIN, FMT = *) LDPAR
        IF (LDPAR .GT. 0)  READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR)
        READ (NIN, FMT = *) LIPAR
        IF (LIPAR .GT. 0)  READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR)
      END IF
C     Generate benchmark example
      CALL BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, Y,
     1            LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, LDWORK,
     2            INFO)
C
      IF (INFO .NE. 0) THEN
        WRITE (NOUT, FMT = 99998) INFO
      ELSE
        WRITE (NOUT, FMT = *) NOTE
        WRITE (NOUT, FMT = 99997) N
        WRITE (NOUT, FMT = 99996) M
        IF (VEC(3)) THEN
          WRITE (NOUT, FMT = 99995)
          DO 10  I = 1, N
            WRITE (NOUT, FMT = 99985) (E(I,J), J = 1, N)
10        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99994)
        END IF
        WRITE (NOUT,FMT = 99993)
        DO 20  I = 1, N
          WRITE (NOUT, FMT = 99985) (A(I,J), J = 1, N)
20      CONTINUE
        IF (VEC(6)) THEN
          WRITE (NOUT,FMT = 99992)
          DO 30  I = 1, M
            WRITE (NOUT, FMT = 99985) (B(I,J), J = 1, N)
30        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99991)
        END IF
        WRITE (NOUT,FMT = 99990)
        DO 40  I = 1, N
          WRITE (NOUT, FMT = 99985) (Y(I,J), J = 1, N)
40      CONTINUE
        IF (VEC(7)) THEN
          WRITE (NOUT, FMT = 99989)
          DO 50  I = 1, N
            WRITE (NOUT, FMT = 99985) (X(I,J), J = 1, N)
50        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99988)
        END IF
        IF (VEC(8)) THEN
          WRITE (NOUT, FMT = 99987)
          DO 60  I = 1, N
            WRITE (NOUT, FMT = 99985) (U(I,J), J = 1, N)
60        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99986)
        END IF
      END IF
C
99999 FORMAT (' BB03AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from BB03AD = ', I3)
99997 FORMAT (/' Order of matrix A:            N  = ', I3)
99996 FORMAT (' Number of rows in matrix B:   M  = ', I3)
99995 FORMAT (/' E  = ')
99994 FORMAT (/' E is the identity matrix.')
99993 FORMAT (' A  = ')
99992 FORMAT (' B  = ')
99991 FORMAT (' B is not provided.')
99990 FORMAT (' Y  = ')
99989 FORMAT (' X  = ')
99988 FORMAT (' X is not provided.')
99987 FORMAT (' U  = ')
99986 FORMAT (' U is not provided.')
99985 FORMAT (20(1X,F8.4))
C
      END
Program Data 
BB03AD EXAMPLE PROGRAM DATA
N
4 1
2
.15D1
.15D1
1
5
Program Results 
 BB03AD EXAMPLE PROGRAM RESULTS

 CTLEX: Example 4.1                                                    

 Order of matrix A:            N  =   5
 Number of rows in matrix B:   M  =   1

 E is the identity matrix.
 A  = 
  -3.6360  -0.6921  -1.1933  -0.8137   0.3507
   0.1406  -2.9375   0.9063   0.1562   0.3438
  -2.5735  -1.4421  -2.8183  -1.1887   1.2257
  -0.3779   0.0810   0.5544  -1.5891   0.0660
   0.8961   1.1586   1.6279   0.5631  -2.2066
 B  = 
  -3.6914  -3.9753  -0.0247  -1.9012   1.1111
 Y  = 
 -13.6261 -14.6743  -0.0911  -7.0181   4.1015
 -14.6743 -15.8031  -0.0982  -7.5580   4.4170
  -0.0911  -0.0982  -0.0006  -0.0469   0.0274
  -7.0181  -7.5580  -0.0469  -3.6147   2.1125
   4.1015   4.4170   0.0274   2.1125  -1.2346
 X  = 
   1.7737   1.9307  -0.0703   1.0497  -0.4681
   1.9307   2.1036  -0.0752   1.1489  -0.5069
  -0.0703  -0.0752   0.0076  -0.0428   0.0178
   1.0497   1.1489  -0.0428   0.6509  -0.2651
  -0.4681  -0.5069   0.0178  -0.2651   0.1284
 U is not provided.

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/BB04AD.html000077500000000000000000000311471201767322700160460ustar00rootroot00000000000000 BB04AD - SLICOT Library Routine Documentation

BB04AD

Benchmark examples of (generalized) discrete-time Lyapunov equations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate benchmark examples of (generalized) discrete-time
  Lyapunov equations

     T           T
    A  X  A  -  E  X E  =  Y .

  In some examples, the right hand side has the form

             T
    Y  =  - B  B

  and the solution can be represented as a product of Cholesky
  factors

           T
    X  =  U  U .

  E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note
  that E can be the identity matrix. For some examples, B, X, or U
  are not provided.

  This routine is an implementation of the benchmark library
  DTLEX (Version 1.0) described in [1].
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DEF     CHARACTER*1
          Specifies the kind of values used as parameters when
          generating parameter-dependent and scalable examples
          (i.e., examples with NR(1) = 2, 3, or 4):
          DEF = 'D' or 'd': Default values are used.
          DEF = 'N' or 'n': Values set in DPAR and IPAR are used.
          This parameter is not referenced if NR(1) = 1.
          Note that the scaling parameter of examples with
          NR(1) = 3 or 4 is considered as a regular parameter in
          this context.
Input/Output Parameters 
  NR      (input) INTEGER array, dimension 2
          Specifies the index of the desired example according
          to [1].
          NR(1) defines the group:
                1 : parameter-free problems of fixed size
                2 : parameter-dependent problems of fixed size
                3 : parameter-free problems of scalable size
                4 : parameter-dependent problems of scalable size
          NR(2) defines the number of the benchmark example
          within a certain group according to [1].

  DPAR    (input/output) DOUBLE PRECISION array, dimension 2
          On entry, if DEF = 'N' or 'n' and the desired example
          depends on real parameters, then the array DPAR must
          contain the values for these parameters.
          For an explanation of the parameters see [1].
          For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's',
          respectively.
          For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and
          's', respectively.
          For Examples 4.3 and 4.4, DPAR(1) defines the parameter
          't'.
          On exit, if DEF = 'D' or 'd' and the desired example
          depends on real parameters, then the array DPAR is
          overwritten by the default values given in [1].

  IPAR    (input/output) INTEGER array of DIMENSION at least 1
          On entry, if DEF = 'N' or 'n' and the desired example
          depends on integer parameters, then the array IPAR must
          contain the values for these parameters.
          For an explanation of the parameters see [1].
          For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'.
          For Example 4.4, IPAR(1) defines 'q'.
          On exit, if DEF = 'D' or 'd' and the desired example
          depends on integer parameters, then the array IPAR is
          overwritten by the default values given in [1].

  VEC     (output) LOGICAL array, dimension 8
          Flag vector which displays the availability of the output
          data:
          VEC(1) and VEC(2) refer to N and M, respectively, and are
          always .TRUE.
          VEC(3) is .TRUE. iff E is NOT the identity matrix.
          VEC(4) and VEC(5) refer to A and Y, respectively, and are
          always .TRUE.
          VEC(6) is .TRUE. iff B is provided.
          VEC(7) is .TRUE. iff the solution matrix X is provided.
          VEC(8) is .TRUE. iff the Cholesky factor U is provided.

  N       (output) INTEGER
          The actual state dimension, i.e., the order of the
          matrices E and A.

  M       (output) INTEGER
          The number of rows in the matrix B. If B is not provided
          for the desired example, M = 0 is returned.

  E       (output) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N part of this array contains the
          matrix E.
          NOTE that this array is overwritten (by the identity
          matrix), if VEC(3) = .FALSE.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= N.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
          The leading N-by-N part of this array contains the
          matrix Y.

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= N.

  B       (output) DOUBLE PRECISION array, dimension (LDB,N)
          The leading M-by-N part of this array contains the
          matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= M.

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array contains the
          matrix X.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= N.

  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array contains the
          matrix U.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= N.

  NOTE    (output) CHARACTER*70
          String containing short information about the chosen
          example.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is
          required.
          For the other examples, no workspace is needed, i.e.,
          LDWORK >= 1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value; in particular, INFO = -3 or -4 indicates
                that at least one of the parameters in DPAR or
                IPAR, respectively, has an illegal value.
References 
  [1]  D. Kressner, V. Mehrmann, and T. Penzl.
       DTLEX - a Collection of Benchmark Examples for Discrete-
       Time Lyapunov Equations.
       SLICOT Working Note 1999-7, 1999.
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

C     BB04AD EXAMPLE PROGRAM TEXT
C     Copyright (c) 2002-2010 NICONET e.V.
C
C     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        (NIN = 5, NOUT = 6)
      INTEGER          NMAX, MMAX
      PARAMETER        (NMAX = 100, MMAX = 100)
      INTEGER          LDE, LDA, LDY, LDB, LDX, LDU, LDWORK
      PARAMETER        (LDE = NMAX, LDA = NMAX, LDY = NMAX, LDB = MMAX,
     1                  LDX = NMAX, LDU = NMAX, LDWORK = 2*NMAX)
C     .. Local Scalars ..
      CHARACTER        DEF
      INTEGER          INFO, N, M, I, J, LDPAR, LIPAR
      CHARACTER*70     NOTE
C     .. Local Arrays ..
      DOUBLE PRECISION E(LDE,NMAX), A(LDA, NMAX), Y(LDY, NMAX),
     1                 B(LDB,NMAX), X(LDX, NMAX), U(LDU, NMAX),
     2                 DPAR(2), DWORK(LDWORK)
      INTEGER          NR(2), IPAR(1)
      LOGICAL          VEC(8)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
      EXTERNAL         BB04AD
C     .. Executable Statements ..
      WRITE (NOUT, FMT = 99999)
C     Skip the heading in the data file and read the data.
      READ (NIN, FMT = '()')
      READ (NIN, FMT = *) DEF
      READ (NIN, FMT = *) (NR(I), I = 1, 2)
      IF (LSAME(DEF,'N')) THEN
        READ (NIN, FMT = *) LDPAR
        IF (LDPAR .GT. 0)  READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR)
        READ (NIN, FMT = *) LIPAR
        IF (LIPAR .GT. 0)  READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR)
      END IF
C     Generate benchmark example
      CALL BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, Y,
     1            LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, LDWORK,
     2            INFO)
C
      IF (INFO .NE. 0) THEN
        WRITE (NOUT, FMT = 99998) INFO
      ELSE
        WRITE (NOUT, FMT = *) NOTE
        WRITE (NOUT, FMT = 99997) N
        WRITE (NOUT, FMT = 99996) M
        IF (VEC(3)) THEN
          WRITE (NOUT, FMT = 99995)
          DO 10  I = 1, N
            WRITE (NOUT, FMT = 99985) (E(I,J), J = 1, N)
10        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99994)
        END IF
        WRITE (NOUT,FMT = 99993)
        DO 20  I = 1, N
          WRITE (NOUT, FMT = 99985) (A(I,J), J = 1, N)
20      CONTINUE
        IF (VEC(6)) THEN
          WRITE (NOUT,FMT = 99992)
          DO 30  I = 1, M
            WRITE (NOUT, FMT = 99985) (B(I,J), J = 1, N)
30        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99991)
        END IF
        WRITE (NOUT,FMT = 99990)
        DO 40  I = 1, N
          WRITE (NOUT, FMT = 99985) (Y(I,J), J = 1, N)
40      CONTINUE
        IF (VEC(7)) THEN
          WRITE (NOUT, FMT = 99989)
          DO 50  I = 1, N
            WRITE (NOUT, FMT = 99985) (X(I,J), J = 1, N)
50        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99988)
        END IF
        IF (VEC(8)) THEN
          WRITE (NOUT, FMT = 99987)
          DO 60  I = 1, N
            WRITE (NOUT, FMT = 99985) (U(I,J), J = 1, N)
60        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99986)
        END IF
      END IF
C
99999 FORMAT (' BB04AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from BB04AD = ', I3)
99997 FORMAT (/' Order of matrix A:            N  = ', I3)
99996 FORMAT (' Number of rows in matrix B:   M  = ', I3)
99995 FORMAT (/' E  = ')
99994 FORMAT (/' E is the identity matrix.')
99993 FORMAT (' A  = ')
99992 FORMAT (' B  = ')
99991 FORMAT (' B is not provided.')
99990 FORMAT (' Y  = ')
99989 FORMAT (' X  = ')
99988 FORMAT (' X is not provided.')
99987 FORMAT (' U  = ')
99986 FORMAT (' U is not provided.')
99985 FORMAT (20(1X,F8.4))
C
      END
Program Data 
BB04AD EXAMPLE PROGRAM DATA
N
4 1
2
.15D1
.15D1
1
5
Program Results 
 BB04AD EXAMPLE PROGRAM RESULTS

 DTLEX: Example 4.1                                                    

 Order of matrix A:            N  =   5
 Number of rows in matrix B:   M  =   1

 E is the identity matrix.
 A  = 
   0.4562   0.0308   0.1990   0.0861   0.0217
   0.0637   0.5142  -0.1828   0.0096  -0.1148
   0.3139   0.1287   0.3484   0.1653  -0.1975
   0.1500   0.0053  -0.1838   0.2501  -0.0687
   0.0568  -0.1006  -0.3735  -0.0202   0.2285
 B  = 
   0.3086   0.0247  -0.4691   0.1728  -0.3704
 Y  = 
  -0.0953  -0.0076   0.1448  -0.0533   0.1143
  -0.0076  -0.0006   0.0116  -0.0043   0.0091
   0.1448   0.0116  -0.2201   0.0811  -0.1738
  -0.0533  -0.0043   0.0811  -0.0299   0.0640
   0.1143   0.0091  -0.1738   0.0640  -0.1372
 X  = 
   0.0953   0.0076  -0.1448   0.0533  -0.1143
   0.0076   0.0006  -0.0116   0.0043  -0.0091
  -0.1448  -0.0116   0.2201  -0.0811   0.1738
   0.0533   0.0043  -0.0811   0.0299  -0.0640
  -0.1143  -0.0091   0.1738  -0.0640   0.1372
 U is not provided.

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/BD01AD.html000077500000000000000000000274201201767322700160440ustar00rootroot00000000000000 BD01AD - SLICOT Library Routine Documentation

BD01AD

Benchmark examples for time-invariant continuous-time dynamical systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate benchmark examples for time-invariant,
  continuous-time dynamical systems

      .
    E x(t) = A x(t) + B u(t)

      y(t) = C x(t) + D u(t)

  E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and
  D is P-by-M. In many examples, E is the identity matrix and D is
  the zero matrix.

  This routine is an implementation of the benchmark library
  CTDSX (Version 1.0) described in [1].
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DEF     CHARACTER*1
          Specifies the kind of values used as parameters when
          generating parameter-dependent and scalable examples
          (i.e., examples with NR(1) = 2, 3, or 4):
          = 'D':  Default values defined in [1] are used;
          = 'N':  Values set in DPAR and IPAR are used.
          This parameter is not referenced if NR(1) = 1.
          Note that the scaling parameter of examples with
          NR(1) = 3 or 4 is considered as a regular parameter in
          this context.
Input/Output Parameters 
  NR      (input) INTEGER array, dimension (2)
          Specifies the index of the desired example according
          to [1].
          NR(1) defines the group:
                1 : parameter-free problems of fixed size
                2 : parameter-dependent problems of fixed size
                3 : parameter-free problems of scalable size
                4 : parameter-dependent problems of scalable size
          NR(2) defines the number of the benchmark example
          within a certain group according to [1].

  DPAR    (input/output) DOUBLE PRECISION array, dimension (7)
          On entry, if DEF = 'N' and the desired example depends on
          real parameters, then the array DPAR must contain the
          values for these parameters.
          For an explanation of the parameters see [1].
          For Examples 2.1 and 2.2, DPAR(1) defines the parameter
          'epsilon'.
          For Example 2.4, DPAR(1), ..., DPAR(7) define 'b', 'mu',
          'r', 'r_c', 'k_l', 'sigma', 'a', respectively.
          For Example 2.7, DPAR(1) and DPAR(2) define 'mu' and 'nu',
          respectively.
          For Example 4.1, DPAR(1), ..., DPAR(7) define 'a', 'b',
          'c', 'beta_1', 'beta_2', 'gamma_1', 'gamma_2',
          respectively.
          For Example 4.2, DPAR(1), ..., DPAR(3) define 'mu',
          'delta', 'kappa', respectively.
          On exit, if DEF = 'D' and the desired example depends on
          real parameters, then the array DPAR is overwritten by the
          default values given in [1].

  IPAR    (input/output) INTEGER array, dimension (1)
          On entry, if DEF = 'N' and the desired example depends on
          integer parameters, then the array IPAR must contain the
          values for these parameters.
          For an explanation of the parameters see [1].
          For Examples 2.3, 2.5, and 2.6, IPAR(1) defines the
          parameter 's'.
          For Example 3.1, IPAR(1) defines 'q'.
          For Examples 3.2 and 3.3, IPAR(1) defines 'n'.
          For Example 3.4, IPAR(1) defines 'l'.
          For Example 4.1, IPAR(1) defines 'n'.
          For Example 4.2, IPAR(1) defines 'l'.
          On exit, if DEF = 'D' and the desired example depends on
          integer parameters, then the array IPAR is overwritten by
          the default values given in [1].

  VEC     (output) LOGICAL array, dimension (8)
          Flag vector which displays the availabilty of the output
          data:
          VEC(1), ..., VEC(3) refer to N, M, and P, respectively,
          and are always .TRUE..
          VEC(4) is .TRUE. iff E is NOT the identity matrix.
          VEC(5), ..., VEC(7) refer to A, B, and C, respectively,
          and are always .TRUE..
          VEC(8) is .TRUE. iff D is NOT the zero matrix.

  N       (output) INTEGER
          The actual state dimension, i.e., the order of the
          matrices E and A.

  M       (output) INTEGER
          The number of columns in the matrices B and D.

  P       (output) INTEGER
          The number of rows in the matrices C and D.

  E       (output) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N part of this array contains the
          matrix E.
          NOTE that this array is overwritten (by the identity
          matrix), if VEC(4) = .FALSE..

  LDE     INTEGER
          The leading dimension of array E.  LDE >= N.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array contains the
          matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= N.

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array contains the
          matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= P.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array contains the
          matrix D.
          NOTE that this array is overwritten (by the zero
          matrix), if VEC(8) = .FALSE..

  LDD     INTEGER
          The leading dimension of array D.  LDD >= P.

  NOTE    (output) CHARACTER*70
          String containing short information about the chosen
          example.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          For Example 3.4, LDWORK >= 4*IPAR(1) is required.
          For the other examples, no workspace is needed, i.e.,
          LDWORK >= 1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value; in particular, INFO = -3 or -4 indicates
                that at least one of the parameters in DPAR or
                IPAR, respectively, has an illegal value;
          = 1:  data file can not be opened or has wrong format.
References 
  [1]  Kressner, D., Mehrmann, V. and Penzl, T.
       CTDSX - a Collection of Benchmark Examples for State-Space
       Realizations of Continuous-Time Dynamical Systems.
       SLICOT Working Note 1998-9. 1998.
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

C     BD01AD EXAMPLE PROGRAM TEXT
C     Copyright (c) 2002-2010 NICONET e.V.
C
C     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        (NIN = 5, NOUT = 6)
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        (NMAX = 421, MMAX = 211, PMAX = 211)
      INTEGER          LDA, LDB, LDC, LDD, LDE, LDWORK
      PARAMETER        (LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX,
     1                  LDE = NMAX, LDWORK = 4*NMAX)
C     .. Local Scalars ..
      CHARACTER        DEF
      INTEGER          I, INFO, J, LDPAR, LIPAR, M, N, P
      CHARACTER*70     NOTE
C     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     1                 D(LDD,MMAX), DPAR(7), DWORK(LDWORK), E(LDE,NMAX)
      INTEGER          NR(2), IPAR(7)
      LOGICAL          VEC(8)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
      EXTERNAL         BD01AD
C     .. Executable Statements ..
      WRITE (NOUT, FMT = 99999)
C     Skip the heading in the data file and read the data.
      READ (NIN, FMT = '()')
      READ (NIN, FMT = *) DEF
      READ (NIN, FMT = *) (NR(I), I = 1, 2)
      IF (LSAME(DEF,'N')) THEN
        READ (NIN, FMT = *) LDPAR
        IF (LDPAR .GT. 0)  READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR)
        READ (NIN, FMT = *) LIPAR
        IF (LIPAR .GT. 0)  READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR)
      END IF
C     Generate benchmark example
      CALL BD01AD(DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, LDA,
     1            B, LDB, C, LDC, D, LDD, NOTE, DWORK, LDWORK, INFO)
C
      IF (INFO .NE. 0) THEN
        WRITE (NOUT, FMT = 99998) INFO
      ELSE
        WRITE (NOUT, FMT = *) NOTE
        WRITE (NOUT, FMT = 99997) N
        WRITE (NOUT, FMT = 99996) M
        WRITE (NOUT, FMT = 99995) P
        IF (VEC(4)) THEN
          WRITE (NOUT, FMT = 99994)
          DO 10  I = 1, N
            WRITE (NOUT, FMT = 99987) (E(I,J), J = 1, N)
10        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99993)
        END IF
        WRITE (NOUT,FMT = 99992)
        DO 20  I = 1, N
          WRITE (NOUT, FMT = 99987) (A(I,J), J = 1, N)
20      CONTINUE
        WRITE (NOUT,FMT = 99991)
        DO 30  I = 1, N
          WRITE (NOUT, FMT = 99987) (B(I,J), J = 1, M)
30      CONTINUE
        WRITE (NOUT,FMT = 99990)
        DO 40  I = 1, P
          WRITE (NOUT, FMT = 99987) (C(I,J), J = 1, N)
40      CONTINUE
        IF (VEC(8)) THEN
          WRITE (NOUT,FMT = 99989)
          DO 50  I = 1, P
            WRITE (NOUT, FMT = 99987) (D(I,J), J = 1, M)
50        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99988)
        END IF
      END IF
C
99999 FORMAT (' BD01AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from BD01AD = ', I3)
99997 FORMAT (/' Order of matrix A:               N  = ', I3)
99996 FORMAT (' Number of columns in matrix B:   M  = ', I3)
99995 FORMAT (' Number of rows in matrix C:      P  = ', I3)
99994 FORMAT (/' E  = ')
99993 FORMAT (/' E is the identity matrix.')
99992 FORMAT (' A  = ')
99991 FORMAT (' B  = ')
99990 FORMAT (' C  = ')
99989 FORMAT (' D  = ')
99988 FORMAT (' D is of zeros.')
99987 FORMAT (20(1X,F8.4))
C
      END
Program Data 
BD01AD EXAMPLE PROGRAM DATA
D
1 1
Program Results 
 BD01AD EXAMPLE PROGRAM RESULTS

 Laub 1979, Ex.1                                                       

 Order of matrix A:               N  =   2
 Number of columns in matrix B:   M  =   1
 Number of rows in matrix C:      P  =   2

 E is the identity matrix.
 A  = 
   0.0000   1.0000
   0.0000   0.0000
 B  = 
   0.0000
   1.0000
 C  = 
   1.0000   0.0000
   0.0000   1.0000
 D is of zeros.

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/BD02AD.html000077500000000000000000000257121201767322700160470ustar00rootroot00000000000000 BD02AD - SLICOT Library Routine Documentation

BD02AD

Benchmark examples for time-invariant discrete-time dynamical systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate benchmark examples for time-invariant,
  discrete-time dynamical systems

    E x_k+1 = A x_k + B u_k

        y_k = C x_k + D u_k

  E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and
  D is P-by-M. In many examples, E is the identity matrix and D is
  the zero matrix.

  This routine is an implementation of the benchmark library
  DTDSX (Version 1.0) described in [1].
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DEF     CHARACTER*1
          Specifies the kind of values used as parameters when
          generating parameter-dependent and scalable examples
          (i.e., examples with NR(1) = 2, 3, or 4):
          = 'D':  Default values defined in [1] are used;
          = 'N':  Values set in DPAR and IPAR are used.
          This parameter is not referenced if NR(1) = 1.
          Note that the scaling parameter of examples with
          NR(1) = 3 or 4 is considered as a regular parameter in
          this context.
Input/Output Parameters 
  NR      (input) INTEGER array, dimension (2)
          Specifies the index of the desired example according
          to [1].
          NR(1) defines the group:
                1 : parameter-free problems of fixed size
                2 : parameter-dependent problems of fixed size
                3 : parameter-free problems of scalable size
                4 : parameter-dependent problems of scalable size
          NR(2) defines the number of the benchmark example
          within a certain group according to [1].

  DPAR    (input/output) DOUBLE PRECISION array, dimension (7)
          On entry, if DEF = 'N' and the desired example depends on
          real parameters, then the array DPAR must contain the
          values for these parameters.
          For an explanation of the parameters see [1].
          For Example 2.1, DPAR(1), ..., DPAR(3) define the
          parameters 'tau', 'delta', 'K', respectively.
          On exit, if DEF = 'D' and the desired example depends on
          real parameters, then the array DPAR is overwritten by the
          default values given in [1].

  IPAR    (input/output) INTEGER array, dimension (1)
          On entry, if DEF = 'N' and the desired example depends on
          integer parameters, then the array IPAR must contain the
          values for these parameters.
          For an explanation of the parameters see [1].
          For Example 3.1, IPAR(1) defines the parameter 'n'.
          On exit, if DEF = 'D' and the desired example depends on
          integer parameters, then the array IPAR is overwritten by
          the default values given in [1].

  VEC     (output) LOGICAL array, dimension (8)
          Flag vector which displays the availabilty of the output
          data:
          VEC(1), ..., VEC(3) refer to N, M, and P, respectively,
          and are always .TRUE..
          VEC(4) is .TRUE. iff E is NOT the identity matrix.
          VEC(5), ..., VEC(7) refer to A, B, and C, respectively,
          and are always .TRUE..
          VEC(8) is .TRUE. iff D is NOT the zero matrix.

  N       (output) INTEGER
          The actual state dimension, i.e., the order of the
          matrices E and A.

  M       (output) INTEGER
          The number of columns in the matrices B and D.

  P       (output) INTEGER
          The number of rows in the matrices C and D.

  E       (output) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N part of this array contains the
          matrix E.
          NOTE that this array is overwritten (by the identity
          matrix), if VEC(4) = .FALSE..

  LDE     INTEGER
          The leading dimension of array E.  LDE >= N.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array contains the
          matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= N.

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array contains the
          matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= P.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array contains the
          matrix D.
          NOTE that this array is overwritten (by the zero
          matrix), if VEC(8) = .FALSE..

  LDD     INTEGER
          The leading dimension of array D.  LDD >= P.

  NOTE    (output) CHARACTER*70
          String containing short information about the chosen
          example.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          NOTE that DWORK is not used in the current version
          of BD02AD.

  LDWORK  INTEGER
          LDWORK >= 1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value; in particular, INFO = -3 or -4 indicates
                that at least one of the parameters in DPAR or
                IPAR, respectively, has an illegal value;
          = 1:  data file can not be opened or has wrong format.
References 
  [1]  Kressner, D., Mehrmann, V. and Penzl, T.
       DTDSX - a Collection of Benchmark Examples for State-Space
       Realizations of Discrete-Time Dynamical Systems.
       SLICOT Working Note 1998-10. 1998.
Numerical Aspects 
  None
Further Comments 
  None
Example

Program Text 

C     BD02AD EXAMPLE PROGRAM TEXT
C     Copyright (c) 2002-2010 NICONET e.V.
C
C     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        (NIN = 5, NOUT = 6)
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        (NMAX = 421, MMAX = 211, PMAX = 211)
      INTEGER          LDA, LDB, LDC, LDD, LDE, LDWORK
      PARAMETER        (LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX,
     1                  LDE = NMAX, LDWORK = 1)
C     .. Local Scalars ..
      CHARACTER        DEF
      INTEGER          I, INFO, J, LDPAR, LIPAR, M, N, P
      CHARACTER*70     NOTE
C     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     1                 D(LDD,MMAX), DPAR(7), DWORK(LDWORK), E(LDE,NMAX)
      INTEGER          NR(2), IPAR(7)
      LOGICAL          VEC(8)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
      EXTERNAL         BD02AD
C     .. Executable Statements ..
      WRITE (NOUT, FMT = 99999)
C     Skip the heading in the data file and read the data.
      READ (NIN, FMT = '()')
      READ (NIN, FMT = *) DEF
      READ (NIN, FMT = *) (NR(I), I = 1, 2)
      IF (LSAME(DEF,'N')) THEN
        READ (NIN, FMT = *) LDPAR
        IF (LDPAR .GT. 0)  READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR)
        READ (NIN, FMT = *) LIPAR
        IF (LIPAR .GT. 0)  READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR)
      END IF
C     Generate benchmark example
      CALL BD02AD(DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, LDA,
     1            B, LDB, C, LDC, D, LDD, NOTE, DWORK, LDWORK, INFO)
C
      IF (INFO .NE. 0) THEN
        WRITE (NOUT, FMT = 99998) INFO
      ELSE
        WRITE (NOUT, FMT = *) NOTE
        WRITE (NOUT, FMT = 99997) N
        WRITE (NOUT, FMT = 99996) M
        WRITE (NOUT, FMT = 99995) P
        IF (VEC(4)) THEN
          WRITE (NOUT, FMT = 99994)
          DO 10  I = 1, N
            WRITE (NOUT, FMT = 99987) (E(I,J), J = 1, N)
10        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99993)
        END IF
        WRITE (NOUT,FMT = 99992)
        DO 20  I = 1, N
          WRITE (NOUT, FMT = 99987) (A(I,J), J = 1, N)
20      CONTINUE
        WRITE (NOUT,FMT = 99991)
        DO 30  I = 1, N
          WRITE (NOUT, FMT = 99987) (B(I,J), J = 1, M)
30      CONTINUE
        WRITE (NOUT,FMT = 99990)
        DO 40  I = 1, P
          WRITE (NOUT, FMT = 99987) (C(I,J), J = 1, N)
40      CONTINUE
        IF (VEC(8)) THEN
          WRITE (NOUT,FMT = 99989)
          DO 50  I = 1, P
            WRITE (NOUT, FMT = 99987) (D(I,J), J = 1, M)
50        CONTINUE
        ELSE
          WRITE (NOUT, FMT = 99988)
        END IF
      END IF
C
99999 FORMAT (' BD02AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from BD02AD = ', I3)
99997 FORMAT (/' Order of matrix A:               N  = ', I3)
99996 FORMAT (' Number of columns in matrix B:   M  = ', I3)
99995 FORMAT (' Number of rows in matrix C:      P  = ', I3)
99994 FORMAT (/' E  = ')
99993 FORMAT (/' E is the identity matrix.')
99992 FORMAT (' A  = ')
99991 FORMAT (' B  = ')
99990 FORMAT (' C  = ')
99989 FORMAT (' D  = ')
99988 FORMAT (' D is of zeros.')
99987 FORMAT (20(1X,F8.4))
C
      END
Program Data 
BD02AD EXAMPLE PROGRAM DATA
D
1 1
Program Results 
 BD02AD EXAMPLE PROGRAM RESULTS

 Laub 1979, Ex. 2: uncontrollable-unobservable data                    

 Order of matrix A:               N  =   2
 Number of columns in matrix B:   M  =   1
 Number of rows in matrix C:      P  =   1

 E is the identity matrix.
 A  = 
   4.0000   3.0000
  -4.5000  -3.5000
 B  = 
   1.0000
  -1.0000
 C  = 
   3.0000   2.0000
 D is of zeros.

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/DAESolver.html000077500000000000000000003411531201767322700167770ustar00rootroot00000000000000 IB01AD - SLICOT Library Routine Documentation

DAESolver

Solver for Algebraic Differential Equations (driver)

[Specification][Arguments][Method][References][Comments][Example]

Purpose 

  Interface for using a common entry point, DSblock compatible for
  defining Differential Algebraic Equations using several packages.
  The equations follow the form (CASE A):

      F(dx(t)/dt, x(t), u(t), p, t) = 0
      y(t) = g(dx(t)/dx, x(t), u(t), p, t)

  for the most general model which can only be solved by DASSL and
  DASSPK.

  A restricted case can be solved with RADAU5, LSODI, LSOIBT, if
  the system is expressed as (CASE B):

      F(x(t), u(t), p, t)*dx(t)/dt = A(x(t), u(t), p, t)
      y(t) = g(dx(t)/dx, x(t), u(t), p, t)

  And finally, the GELDA package is able to solve DAEs with the 
  expression (CASE C):

      F(u(t), p, t)*dx(t)/dt = A(u(t), p, t)*x(t) + E(u(t), p, t)

  The user must define the subroutines:
     DAEDF:    F(dx(t)/dt, x(t), u(t), p, t)  for CASES: A, B and C
     DAEDA:    A(x(t), u(t), p, t)           for CASES: B and C
     DAEDE:    E(u(t), p, t)                  for CASES: C
     DAEOUT:   g(dx(t)/dx, x(t), u(t), p, t)
  and the Jacobians (JACFX, JACFU, JACFP) if used. The interface 
  adapts the structure to fit all the codes
Specification 
     SUBROUTINE DAESolver(ISOLVER,CDAEDF_,CDAEDA_,CDAEDE_,CDAEOUT_,
   $                      CJACFX_,CJACFU_,CJACFP_,CJACFXDOT_,
   $                      NX, NY, NU, NP, TINI, TOUT,
   $                      X, XDOTI, Y, U, P,
   $                      IPAR, RPAR, RTOL, ATOL,
   $                      IWORK, LIWORK, DWORK, LDWORK,
   $                      IWARN, INFO) 
    .. Scalar Arguments ..
    DOUBLE PRECISION    TINI, TOUT
    INTEGER             ISOLVER, IWARN, INFO,
   $                    NX, NY, NU, NP,
   $                    LDWORK, LIWORK    
    CHARACTER*9         CDAEDF_, CDAEDA_,CDAEDE_, CDAEOUT_,
   $                    CJACFX_, CJACFU_, CJACFP_, CJACFXDOT_,
   $                    CDAEDF, CDAEDA,CDAEDE, CDAEOUT,
   $                    CJACFX, CJACFU, CJACFP, CJACFXDOT
    .. Array Arguments ..
    DOUBLE PRECISION    DWORK(LDWORK), RPAR(*), ATOL(*), RTOL(*)
   $                    X(NX), XDOTI(NX), Y(NY), U(NU), P(NP)
    INTEGER             IWORK(LIWORK), IPAR(*)
Arguments

Mode Parameters 

   ISOLVER INTEGER
           Indicates the nonlinear solver packages to be used
             = 1: LSODI,
             = 2: LSOIBT,
             = 3: RADAU5,
             = 4: DASSL,
             = 5: DASPK,
             = 6: DGELDA.
Input/Output Parameters
  
     DAEDF   (input) EXTERNAL
             Evaluates the F(dx(t)/dt, x(t), u(t), p, t).

     DAEDA   (input) EXTERNAL
             Evaluates the A(x(t), u(t), p, t).

     DAEDE   (input) EXTERNAL
             Evaluates the E(u(t), p, t).

     DAEOUT  (input) EXTERNAL
             Evaluates the output signals function g.

     JACFX   (input) EXTERNAL
             Evaluates the jacobian matrix with respect to X.

     JACFU   (input) EXTERNAL
             Evaluates the jacobian matrix with respect to U.

     JACFP   (input) EXTERNAL
             Evaluates the jacobian matrix with respect to P.

     NX      (input) INTEGER
             Dimension of the state vector.

     NY      (input) INTEGER
             Dimension of the output vector.

     NU      (input) INTEGER
             Dimension of the input vector.

     NP      (input) INTEGER
             Dimension of the parameter vector.

     TINI    (input) DOUBLE PRECISION
             Initial value of time.

     TOUT    (input) DOUBLE PRECISION
             Final value of time.
  
     X       (input/output) DOUBLE PRECISION array, dimension (NX)
             On entry, array containing the initial state variables.
             On exit, it has the last value of the state variables.
  
     XDOTI   (input) DOUBLE PRECISION array, dimension (NX)
             Array containing dx(t)/dt at initial point.

     Y       (input/output) DOUBLE PRECISION array, dimension (NY)
             On entry, array containing the initial values of Y.
             On exit, it has the results of the system.

     U       (input) DOUBLE PRECISION array, dimension (NU)
             Array containing the input initial values.
  
     P       (input) DOUBLE PRECISION array, dimension (NP)
             Array containing the parameter variables.
  
     IPAR    (input/output) INTEGER array, dimension (201)
             INPUT:
                1..15   General
               16..25   ODEPACK
               26..35   RADAU5
               36..50   DASSL/PK
               51..60   GELDA
               61..100  Reserved
             OUTPUT:
              101..110  General
              111..125  ODEPACK
              126..135  RADAU5
              136..145  DASSL/PK
              146..155  GELDA
              156..200  Reserved
             Any Mode:
              201..     User Available
    
             Common integer parameters for SOLVERS:
                IPAR(1), Tolerance mode
                    0 : both rtol and atol are scalars
                    1 : rtol is a scalar and atol is a vector
                    2 : both rtol and atol are vectors
                IPAR(2), Compute Output Values only at TOUT (and not
                    at the intermediate step). (1:Yes, 0:No)
                IPAR(3), mfjac, Method flag for jacobian
                    0 : No jacobian used (non-stiff method).
                    1 : User supplied full jacobian (stiff).
                    2 : User supplied banded jacobian (stiff).
                    3 : User supplied sparse jacobian (stiff).
                   10 : internally generated full jacobian (stiff).
                   11 : internally generated banded jacobian (stiff).
                   12 : internally generated sparse jacobian (stiff).
                IPAR(6), ml, lower half-bandwithds of the banded
                   jacobian, excluding tne main diagonal.
                IPAR(7), mu, upper half-bandwithds of the banded
                   jacobian, excluding the main diagonal.
         (Note: IPAR(6) and IPAR(7) are obligatories only if the
          jacobian matrix is banded)
                IPAR(101) = Number of steps taken for the problem.
                IPAR(102) = Number of residual evaluations.
                IPAR(103) = Number of jacobian evaluations.

             Common parameters for RADAU5, ODEPACK and DGELDA:
                IPAR(9), mfmass, Method flag for mass-matrix
                    0 : No mass-matrix used (non-stiff method).
                    1 : User supplied full mass-matrix (stiff).
                    2 : User supplied banded mass-matrix (stiff).
                   10 : Identity mass-matrix is used (stiff).
                IPAR(10), mlmass, lower half-bandwithds of the banded
                   mass matrix, excluding the main diagonal.
                IPAR(11), mumass, upper half-bandwithds of the banded
                   mass matrix, excluding the main diagonal.
                IPAR(12), Maximum number of steps allowed during one
                   call to the solver.

             Common parameters for ODEPACK, DASSL, DASPK and DGELDA:
                IPAR(13), Maximum order to be allowed.
                   default values : 12 if meth = 1
                                     5 if meth = 2
                   If exceds the default value, it will be reduced
                   to the default value.
                   In DASSL, DASPK and DGELDA : (1 .LE. MAXORD .LE. 5)
                IPAR(111) = The method order last used(successfully).
                IPAR(112) = The order to be attempted on the next step.

             Common parameters for ODEPACK package:
                IPAR(16), Status Flag
                IPAR(17), Optional inputs, must be 0
                IPAR(18), Maximum number of messages printed,
                   default value is 10.
                IPAR(113) = Index of the component of largest in the
                   weighted local error vector ( e(i)/ewt(i) ).
                IPAR(114) = Length of rwork actually required.
                IPAR(115) = Length of iwork actually required.

             - LSOIBIT
                IPAR(24), mb, block size.
                   (mb .GE. 1) and mb*IPAR(28) = NX
                IPAR(25), nb, number of blocks in the main diagonal.
                   (nb .ge. 4) and nb*IPAR(27) = NX

             - RADAU5
                IPAR(26) Transforms the Jacobian matrix to Hessenberg
                    form.(Only if IPAR(9)=1 and IPAR(3)=1 or 10)
                IPAR(27) Maximum number of Newton iterations in
                    each step.
                IPAR(28) Starting values for Newton's method
                      .EQ. 0 -> is taken the extrapolated collocation
                           solution
                      .NE. 0 -> zero values are used.
                IPAR(29) Dimension of the index 1 variables( >0 ).
                IPAR(30) Dimension of the index 2 variables.
                IPAR(31) Dimension of the index 3 variables.
                IPAR(32) Switch for step size strategy
                      0,1 Mod. Predictive controller(Gustafsson)
                      2   Classical step size control
         IPAR(33) Value of M1 (default 0).
                IPAR(34) Value of M2 (default(M2=M1).
                IPAR(126), Number of accepted steps.
                IPAR(127), Number of rejected steps.
                IPAR(128), Number of LU-Decompositions of both
                    matrices
                IPAR(129), Number of forward-backward substitutions,
                    of both systems.

             Common parameters for DASSL, DASPK and DGELDA solvers:
                IPAR(36),  this parameter enables the code to
                     initialize itself. Must set to 0 to indicate the
                     start of every new problem.
                          0: Yes. (On each new problem)
                          1: No. (Allows 500 new steps)
                IPAR(38), Solver try to compute the initial T, X
                      and XPRIME:
                          0: The initial T, X and XPRIME are
                            consistent.
                          1: Given X_d calculate X_a and X'_d
                          2: Given X' calculate X.
                          ( X_d differential variables in X
                            X_a algebrac variables in X )
               IPAR(136), Total number of error test failures so far.

             Common parameters for DASSL and DASPK solvers:
                IPAR(37),  code solve the problem without invoking
                     any special non negativity constraints:
                          0: Yes
                          1: To have constraint checking only in the
                            initial condition calculation.
                          2: To enforze nonnegativity in X during the
                            integration.
                          3: To enforce both options 1 and 2.
               IPAR(137), Total number of convergence test failures.

             - DASPK
               IPAR(39), DASPK use:
                         0: direct methods (dense or band)
                         1: Krylov method  (iterative)
                         2: Krylov method + Jac (iterative)
               IPAR(41), Proceed to the integration after the initial
                       condition calculation is done. Used when
                       IPAR(38) > 0:    0: Yes
                                        1: No
               IPAR(42), Errors are controled localy on all the
                     variables:      0:Yes
                                     1: No
               IPAR(8), Extra printing
                         0, no printing
                         1, for minimal printing
                         2, for full printing
               IPAR(44), maximum number of iterations in the SPIGMR
                    algorithm. (.LE. NX)
               IPAR(45), number of vectors on which orthogonalization
                    is done in the SPIGMR algorithm. (.LE. IPAR(44))
               IPAR(46), maximum number of restarts of the SPIGMR
                    algorithm per nonlinear iteration. (.GE. 0)
               IPAR(47), maximum number of Newton iterations per
                    Jacobian or preconditioner evaluation. (> 0)
               IPAR(48), maximum number of Jacobian or preconditioner
                    evaluations. (> 0)
               IPAR(49), maximum number of values of the artificial
                    stepsize parameter H to be tried if IPAR(38) = 1.
                    (> 0).
               IPAR(50), flag to turn off the linesearch algorithm.
                        0 : ON
                        1 : OFF (default)
               IPAR(138), number of convergence failures of the linear
                        iteration
               IPAR(139), length of IWORK actually required.
               IPAR(140), length of RWORK actually required.
               IPAR(141), total number of nonlinear iterations.
               IPAR(142), total number of linear (Krylov) iterations
               IPAR(143), number of PSOL calls.

             - DGELDA
               IPAR(51), contains the strangeness index.
               IPAR(52), number of differential components
               IPAR(53), number of algebraic components
               IPAR(54), number of undetermined components
               IPAR(55), method used:
                        if 1 then uses the BDF solver
                           2 then uses the Runge-Kutta solver
               IPAR(56), E(t) and A(t) are: 1  time dependent
                                            0  constants
               IPAR(57), Maximum index of the problem. ( .GE. 0 )
               IPAR(58), Step size strategy:
                    0, Mod. predictive controlled of Gustafsson(safer)
                    1, classical step size control(faster)

     RPAR    (input/output) DOUBLE PRECISION array, dimension (201)
             INPUT:
                1..15   General
               16..25   ODEPACK
               26..35   RADAU5
               36..50   DASSL/PK
               51..60   GELDA
               61..100  Reserved
             OUTPUT:
              101..110  General
              111..125  ODEPACK
              126..135  RADAU5
              136..145  DASSL/PK
              146..155  GELDA
              156..200  Reserved
             Any Mode:
              201..     User Available

             Common parameters for solvers:
                RPAR(1), Initial step size guess.Obligatory in RADAU5.
                RPAR(2), Maximum absolute step size allowed.

             Common parameters for ODEPACK, DASSL, DASPK and DGELDA:
                RPAR(111), Step size in t last used (successfully).
                RPAR(112), Step size to be attempted on the next step.
                RPAR(113), Current value of the independent variable
                   which the solver has actually reached

             Common parameters for ODEPACK solver:
                RPAR(16), Critical value of t which the solver is not
                   overshoot.
                RPAR(17), Minimum absolute step size allowed.
                RPAR(18), Tolerance scale factor, greater than 1.0.

             Parameters for RADAU5 solver:
                RPAR(26), The rounding unit, default 1E-16.
                RPAR(27), The safety factor in step size prediction,
                  default 0.9D0.
                RPAR(28), Decides whether the jacobian should be
                  recomputed, default 0.001D0.
                   Increase when jacobian evaluations are costly
                   For small systems should be smaller.
                RPAR(29), Stopping criterion for Newton's method,
                  default MIN(0.03D0, RTOL(1)**0.5D0).
                RPAR(30), RPAR(31): This saves, together with a
                  large RPAR(28), LU-decompositions and computing
                  time for large systems.
                  Small systems: RPAR(30)=1.D0, RPAR(31)=1.2D0
                  Large full systems: RPAR(30)=0.99D0, RPAR(31)=2.D0
                  might be good.
                RPAR(32), RPAR(33), Parameters for step size
                  selection.Condition: RPAR(32)<=HNEW/HOLD<=RPAR(33)

               Parameters for DASSL, DASPK and DGELDA solvers:
                RPAR(36), Stopping point (Tstop)

               - DASPK
                RPAR(37), convergence test constant in SPIGMR
                    algorithm. (0 .LT. RPAR(37) .LT. 1.0)
                RPAR(38), minimum scaled step in linesearch algorithm.
                    The default is  = (unit roundoff)**(2/3). (> 0)
                RPAR(39), swing factor in the Newton iteration
                    convergence test. (default 0.1) (> 0)

               - DASPK
                RPAR(40), safety factor used in step size prediction.
                RPAR(41) and RPAR(42) restric the relation between the
                    new and old stepsize in step size selection.
                      1/RPAR(41) .LE. Hnew/Hold .LE. 1/RPAR(42)
                RPAR(43), RPAR(44) QUOT1 and QUOT2 repectively.
                    If QUOT1 < Hnew/Hold < QUOT2 and A and E are
                    constants, the work can be saved by setting
                    Hnew=Hold and using the system matrix of the
                    previous step.
Tolerances 
     RTOL    DOUBLE PRECISION
             Relative Tolerance.

     ATOL    DOUBLE PRECISION
             Absolute Tolerance.
Workspace 
     IWORK   INTEGER array, dimension (LIWORK)

     LIWORK  INTEGER
             Minimum size of DWORK, depending on solver:
             - LSODI, LSOIBT, DASSL
                20 + NX
             - RADAU5
                3*N+20

     DWORK   DOUBLE PRECISION array, dimension (LDWORK)

     LDWORK  INTEGER
             Size of DWORK, depending on solver:
             - LSODI
                22 +  9*NX + NX**2             , IPAR(3) = 1 or 10
                22 + 10*NX + (2*ML + MU)*NX    , IPAR(3) = 2 or 11
             - LSOIBT
                20 + nyh*(maxord + 1) + 3*NX + lenw     where 
                  nyh    = Initial value of NX
                  maxord = Maximum order allowed(default or IPAR(13)
                  lenw   = 3*mb*mb*nb + 2 
             - RADAU5
                N*(LJAC+LMAS+3*LE+12)+20
                 where  LJAC=N               if (full jacobian)
                        LJAC=MLJAC+MUJAC+1   if (banded jacobian)
                   and  LMAS=0               if (IPAR(9) = 10 or 11)
                        LMAS=N               if (IPAR(9) = 1)
                        LMAS=MLMAS+MUMAS+1   if (IPAR(9) = 2)
                   and  LE=N                 if (IPAR(9) = 1 or 10)
                        LE=2*MLJAC+MUJAC+1   if (IPAR(9) = 2 or 11)
             - DASSL
                >= 40 LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2, IPAR(3) = 1 or 10
                >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ,    IPAR(3) = 2
                >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ
                               +2*(NEQ/(ML+MU+1)+1),     IPAR(3) = 11
Warning Indicator 
     IWARN   INTEGER
             = 0:  no warning;
             = 1:  LSODI/LSOIBT/RADAU5 do not use the input vector as argument;
             = 2:  LSODI/LSOIBT do not use the param vector as argument;
             = 3:  RTOL and ATOL are used as scalars;
Error Indicator 
     INFO    INTEGER
             = 0:  Successful exit;
             < 0:  If INFO = -i, the i-th argument had an illegal
                   value;
             = 1:  Wrong tolerance mode;
             = 2:  Method (IPAR(9)) is not allowed for ODEPACK/RADAU5;
             = 3:  Method (IPAR(3)) is not allowed for LSODE/RADAU5/DASSL;
             = 4:  Option not allowed for IPAR(37);
             = 5:  Option not allowed for IPAR(38);
             = 100+ERROR: RADAU5 returned -ERROR;
             = 200+ERROR: DASSL returned -ERROR;
             = 300+ERROR: DASPK returned -ERROR;
             = 400+ERROR: DGELDA returned -ERROR.
Method 
Since the package integrates 8 different solvers, it is possible to solve differential 
equations by means of Backward Differential Formulas, Runge-Kutta, using direct or 
iterative methods (including preconditioning) for the linear system associated, differential 
equations with time-varying coefficients or of order higher than one. The interface facilitates  
the user the work of changing the integrator and testing the results, thus leading a more robust 
and efficient integrated package.
References 
  [1]  A.C. Hindmarsh, Brief Description of ODEPACK: A Systematized Collection 
       of ODE Solvers, http://www.netlib.org/odepack/doc                        
                                                                                
  [2]  L.R. Petzold DASSL Library Documentation, http://www.netlib.org/ode/     
                                                                               
  [3]  P.N. Brown, A.C. Hindmarsh, L.R. Petzold, DASPK Package 1995 Revision                                                                               

  [4]  R.S. Maier, Using DASPK on the TMC CM5. Experiences with Two Programming 
       Models, Minesota Supercomputer Center, Technical Report.                 
                                                                               
  [5]  E. Hairer, G. Wanner, Solving Ordinary Dirential Equations II. Stiánd    
       Dirential- Algebraic Problems., Springer Seried in Computational         
       Mathermatics 14, Springer-Verlag 1991, Second Edition 1996.                                                                                             

  [6]  P. Kunkel, V. Mehrmann, W. Rath und J. Weickert, `GELDA: A Software      
       Package for the Solution of General Linear Dirential Algebraic           
       equations', SIAM Journal Scienti^Lc Computing, Vol. 18, 1997, pp.        
       115 - 138.                                                               
                                                                                
  [7]  M. Otter, DSblock: A neutral description of dynamic systems.             
       Version 3.3, http://www.netlib.org/odepack/doc                           
                                                                                
  [8]  M. Otter, H. Elmqvist, The DSblock model interface for exchanging model 
       components, Proceedings of EUROSIM 95, ed. F.Brenenecker, Vienna, Sep.  
       11-15, 1995                                                             
                                                                               
  [9]  M. Otter, The DSblock model interface, version 4.0, Incomplete Draft,   
       http://dv.op.dlr.de/~otter7dsblock/dsblock4.0a.html                     
                                                                               
  [10] Ch. Lubich, U. Novak, U. Pohle, Ch. Engstler, MEXX - Numerical          
       Software for the Integration of Constrained Mechanical Multibody        
       Systems, http://www.netlib.org/odepack/doc                              
                                                                               
  [11] Working Group on Software (WGS), SLICOT Implementation and Documentation
       Standards (version 1.0), WGS-Report 90-1, Eindhoven University of       
       Technology, May 1990.                                                   
                                                                               
  [12] P. Kunkel and V. Mehrmann, Canonical forms for linear differential-     
       algebraic equations with variable coeÆcients., J. Comput. Appl.         
       Math., 56:225{259, 1994.                                                
                                                                               
  [13] Working Group on Software (WGS), SLICOT Implementation and Documentation
       Standards, WGS-Report 96-1, Eindhoven University of Technology, updated:
       Feb. 1998, ../../REPORTS/rep96-1.ps.Z. 
                                                                              
  [14] A. Varga, Standarization of Interface for Nonlinear Systems Software   
       in SLICOT, Deutsches Zentrum ur Luft un Raumfahrt, DLR. SLICOT-Working 
       Note 1998-4, 1998, Available at                                        
       ../../REPORTS/SLWN1998-4.ps.Z.         
                                                                              
  [15] D. Kirk, Optimal Control Theory: An Introduction, Prentice-Hall.       
       Englewood Cli, NJ, 1970.                                               
                                                                              
  [16] F.L. Lewis and V.L. Syrmos, Optimal Control, Addison-Wesley.           
       New York, 1995.                                                        
                                                                             
  [17] W.M.Lioen, J.J.B de Swart, Test Set for Initial Value Problem Solvers,
       Technical Report NM-R9615, CWI, Amsterdam, 1996.                       
       http://www.cwi.nl/cwi/projects/IVPTestset/.                            
                                                                              
  [18] V.Hernandez, I.Blanquer, E.Arias, and P.Ruiz,                          
       Definition and Implementation of a SLICOT Standard Interface and the   
       associated MATLAB Gateway for the Solution of Nonlinear Control Systems
       by using ODE and DAE Packages}, Universidad Politecnica de Valencia,   
       DSIC. SLICOT Working Note 2000-3: July 2000. Available at             
       ../../REPORTS/SLWN2000-3.ps.Z.        
                                                                             
  [19] J.J.B. de Swart, W.M. Lioen, W.A. van der Veen, SIDE, November 25,    
       1998. Available at http://www.cwi.nl/cwi/projects/PSIDE/.             
                                                                             
  [20] Kim, H.Young, F.L.Lewis, D.M.Dawson, Intelligent optimal control of   
       robotic manipulators using neural networks.                           
                                                                             
  [21] J.C.Fernandez, E.Arias, V.Hernandez, L.Penalver, High Performance     
       Algorithm for Tracking Trajectories of Robot Manipulators,            
       Preprints of the Proceedings of the 6th IFAC International Workshop on
       Algorithms and Architectures for Real-Time Control (AARTC-2000),      
       pages 127-134.
Numerical Aspects 
  The numerical aspects of the routine lie on the features of the 
  different packages integrated. Several packages are more robust
  than others, and other packages simply cannot deal with problems 
  that others do. For a detailed description of the numerical aspects 
  of each method is recommended to check the references above.
Further Comments 
  Several packages (LSODES, LSOIBT) deal only with sparse matrices.  
  The interface checks the suitability of the methods to the 
  parameters and show a warning message if problems could arise.
Example

Program Text
 

*     DAESOLVER EXAMPLE PROGRAM TEXT FOR LSODIX PROBLEM
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER LSODI_, LSOIBT_, RADAU5_, DASSL_, DASPK_, GELDA_
      PARAMETER (LSODI_  = 1, LSOIBT_ = 2)
      PARAMETER (RADAU5_ = 3, DASSL_  = 4, DASPK_  = 5)
      PARAMETER (GELDA_  = 6)
*     .. Executable Statements ..
*
      EXTERNAL IARGC_
      INTEGER IARGC_
      INTEGER NUMARGS
      CHARACTER*80 NAME
      CHARACTER*80 SOLVER
*
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*
      NUMARGS = IARGC_()
*
      CALL GETARG_(0, NAME)
      IF (NUMARGS .NE. 1) THEN
        WRITE (*,*) 'Syntax Error: ',NAME(1:8),' <solver>'
        WRITE (*,*) 'Solvers : LSODI, LSOIBT, RADAU5, DASSL, DASPK, GELD
     &A'
      ELSE
*
        CALL GETARG_(1, SOLVER)
*
        WRITE (*,*) 'Problem: LSODIX   Solver: ',SOLVER(1:7)
*
        IF (SOLVER(1:5) .EQ. 'LSODI') THEN
          CALL TEST(LSODI_)
        ELSEIF (SOLVER(1:6) .EQ. 'LSOIBT') THEN
          CALL TEST(LSOIBT_)
        ELSEIF (SOLVER(1:6) .EQ. 'RADAU5') THEN
          CALL TEST(RADAU5_)
        ELSEIF (SOLVER(1:5) .EQ. 'GELDA') THEN
          CALL TEST(GELDA_)
        ELSEIF (SOLVER(1:5) .EQ. 'DASSL') THEN
          CALL TEST(DASSL_)
        ELSEIF (SOLVER(1:5) .EQ. 'DASPK') THEN
          CALL TEST(DASPK_)
        ELSE
          WRITE (*,*) 'Error: Solver: ', SOLVER,' unknown'
        ENDIF
      ENDIF
*
99999 FORMAT (' DAESOLVER EXAMPLE PROGRAM RESULTS FOR LSODIX PROBLEM'
     .        ,/1X)
      END
 
 
 

      SUBROUTINE TEST( ISOLVER )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     Testing subroutine DAESolver
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     ISOLVER  (input) INTEGER
*             Indicates the nonlinear solver package to be used:
*             = 1: LSODI,
*             = 2: LSOIBT,
*             = 3: RADAU5,
*             = 4: DASSL,
*             = 5: DASPK,
*             = 6: DGELDA.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*     .. Parameters ..
      INTEGER LSODI_, LSOIBT_, RADAU5_, DASSL_, DASPK_, GELDA_
      PARAMETER (LSODI_  = 1, LSOIBT_ = 2)
      PARAMETER (RADAU5_ = 3, DASSL_  = 4, DASPK_  = 5)
      PARAMETER (GELDA_  = 6)
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MD, ND, LPAR, LWORK
      PARAMETER        ( MD = 400, ND = 100, LPAR = 201,
     $                   LWORK = 10000 )
*     .. Common variables ..
      COMMON /TESTING/ ISOLVER2
      INTEGER ISOLVER2
*     .. Scalar Arguments ..
      INTEGER  ISOLVER
*     .. Local Scalars ..
      INTEGER          NEQN, NDISC, MLJAC, MUJAC, MLMAS, MUMAS
      INTEGER          IWARN, INFO
      DOUBLE PRECISION ATOL, RTOL, NORM
      LOGICAL          NUMJAC, NUMMAS, CONSIS
*     .. Local Arrays ..
      CHARACTER FULLNM*40, PROBLM*8, TYPE*3
      CHARACTER*9 CDAEDF,CDAEDA,CDAEDE,CDAEOUT,
     $            CJACFX,CJACFU,CJACFP,CJACFXDOT
      INTEGER          IND(MD), IPAR(LPAR), IWORK(LWORK)
      DOUBLE PRECISION T(0:ND), RPAR(LPAR), DWORK(LWORK)
      DOUBLE PRECISION X(MD), XPRIME(MD), Y(MD), U(MD), P(MD), SOLU(MD)
*     .. External Functions ..
      DOUBLE PRECISION DNRM2
      EXTERNAL         DNRM2
*     .. External Subroutines ..
      EXTERNAL         PLSODIX, ILSODIX, SLSODIX
      EXTERNAL         DAXPY
*     .. Executable Statements ..
*
      ISOLVER2 = ISOLVER
      DO 20 I=1,NEQN
         Y(I)=0D0
         U(I)=0D0
         P(I)=0D0
   20 CONTINUE
      DO 40 I=1,LPAR
         IPAR(I)=0
         RPAR(I)=0D0
   40 CONTINUE
      DO 60 I=1,LWORK
         IWORK(I)=0
         DWORK(I)=0D0
   60 CONTINUE
*     Get the problem dependent parameters.
      RTOL=1D-4
      ATOL=1D-6
      IPAR(1)=0
      IPAR(2)=1
      IPAR(3)=1
      IPAR(12)= 10000
      IF (ISOLVER .EQ. LSODI_ .OR. ISOLVER .EQ. RADAU5_) THEN
         IPAR(9)=1
         IPAR(16)=1
C        IPAR(17)=0
         RPAR(1)=1D-3
      ELSE
C           (ISOLVER .EQ. DASSL_ .OR. ISOLVER .EQ. DASPK_)
C        IPAR(36)=0
C        IPAR(37)=0
C        IPAR(38)=0
         IPAR(39)=1
      END IF
      CALL PLSODIX(FULLNM,PROBLM,TYPE,NEQN,NDISC,T,NUMJAC,MLJAC,
     $            MUJAC,NUMMAS,MLMAS,MUMAS,IND)
      CALL ILSODIX(NEQN,T(0),X,XPRIME,CONSIS)
      x(1) = 1.0d0
      x(2) = 0.0d0
      x(3) = 0.0d0
      xprime(1) = -0.04D0
      xprime(2) =  0.04D0
      xprime(3) =  0.0D0
      CALL SLSODIX(NEQN,T(1),SOLU)

      IF ( TYPE.NE.'DAE' ) THEN
         WRITE ( NOUT, FMT = 99998 )
      ELSE
         WRITE ( NOUT, FMT = 99997 ) FULLNM, PROBLM, TYPE, ISOLVER
         CDAEDF=''
         CDAEDA=''
         CDAEDE=''
         CDAEOUT=''
         CJACFX=''
         CJACFU=''
         CJACFP=''
         CJACFXDOT=''

         CALL DAESolver( ISOLVER, CDAEDF, CDAEDA, CDAEDE, CDAEOUT,
     $                   CJACFX, CJACFU, CJACFP, CJACFXDOT,
     $                   NEQN, NEQN, NEQN, NEQN, T(0), T(1),
     $                   X, XPRIME, Y, U, P,
     $                   IPAR, RPAR, RTOL, ATOL,
     $                   IWORK, LWORK, DWORK, LWORK, IWARN, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99996 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99995 ) IWARN
            ENDIF
            IF ( NEQN .LE. 30 ) THEN
               WRITE ( NOUT, FMT = 99994 )
               DO 80 I=1,NEQN
                  WRITE ( NOUT, FMT = 99993 ) I, X(I), SOLU(I)
   80          CONTINUE
            END IF
            NORM=DNRM2(NEQN,SOLU,1)
            IF ( NORM.EQ.0D0 ) THEN
               NORM=1D0
            END IF
            CALL DAXPY(NEQN,-1D0,X,1,SOLU,1)
            NORM=DNRM2(NEQN,SOLU,1)/NORM
            WRITE ( NOUT, FMT = 99992 ) NORM
         END IF
      END IF
*
99998 FORMAT (' ERROR: This test is only intended for DAE problems')
99997 FORMAT (' ',A,' (',A,' , ',A,') with SOLVER ',I2)
99996 FORMAT (' INFO on exit from DAESolver = ',I3)
99995 FORMAT (' IWARN on exit from DAESolver = ',I3)
99994 FORMAT (' Solution: (calculated) (reference)')
99993 FORMAT (I,F,F)
99992 FORMAT (' Relative error comparing with the reference solution:'
     $        ,E,/1X)
* *** Last line of TEST ***
      END
 
 
 

      SUBROUTINE DAEDA_( RPAR, NRP, IPAR, NIP, X, NX, U, NU, P, NP,
     $                   F, LDF, T, INFO )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     Interface routine between DAESolver and the problem function FEVAL
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     RPAR     (input/output) DOUBLE PRECISION array, dimension (NRP)
*              Array for communication between the driver and FEVAL.
*
*     NRP      (input) INTEGER
*              Dimension of RPAR array.
*
*     IPAR     (input/output) INTEGER array, dimension (NIP)
*              Array for communication between the driver and FEVAL.
*
*     NIP      (input) INTEGER
*              Dimension of IPAR array.
*
*     X        (input) DOUBLE PRECISION array, dimension (NX)
*              Array containing the state variables.
*
*     NX       (input) INTEGER
*              Dimension of the state vector.
*
*     U        (input) DOUBLE PRECISION array, dimension (NU)
*              Array containing the input values.
*
*     NU       (input) INTEGER
*              Dimension of the input vector.
*
*     P        (input) DOUBLE PRECISION array, dimension (NP)
*              Array containing the parameter values.
*
*     NP       (input) INTEGER
*              Dimension of the parameter vector.
*
*     F        (output) DOUBLE PRECISION array, dimension (LDF,NX)
*              The resulting function value f(T,X).
*
*     LDF      (input) INTEGER
*              The leading dimension of F.
*
*     T        (input) INTEGER
*              The time point where the function is evaluated.
*
*     Error Indicator
*
*     INFO     INTEGER
*              Returns values of error from FEVAL or 100 in case
*              a bad problem was choosen.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*
*     .. Common variables ..
      COMMON /TESTING/ ISOLVER
      INTEGER LSODI_, LSOIBT_, RADAU5_, DASSL_, DASPK_, GELDA_
      PARAMETER (LSODI_  = 1, LSOIBT_ = 2)
      PARAMETER (RADAU5_ = 3, DASSL_  = 4, DASPK_  = 5)
      PARAMETER (GELDA_  = 6)
*     .. Scalar Arguments ..
      INTEGER          NRP, NIP, NX, NU, NP, LDF, INFO
      DOUBLE PRECISION T
*     .. Array Arguments ..
      INTEGER          IPAR(NIP)
      DOUBLE PRECISION RPAR(NRP), X(NX), U(NU), P(NP),
     $  F(LDF,NX)
*     .. External Subroutines ..
      EXTERNAL         FLSODIX
*     .. Executable Statements ..
      CALL FLSODIX(NX,T,X,X,F,INFO,RPAR,IPAR)
* *** Last line of DAEDA_ ***
      END
 
 
 

      SUBROUTINE DAEDF_( RPAR, NRP, IPAR, NIP, X, XPRIME, NX,
     $                  U, NU, P, NP, T, F, LDF, INFO )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     Interface routine between DAESolver and the problem function MEVAL
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     RPAR     (input/output) DOUBLE PRECISION array, dimension (NRP)
*              Array for communication between the driver and MEVAL.
*
*     NRP      (input) INTEGER
*              Dimension of RPAR array.
*
*     IPAR     (input/output) INTEGER array, dimension (NIP)
*              Array for communication between the driver and MEVAL.
*
*     NIP      (input) INTEGER
*              Dimension of IPAR array.
*
*     X        (input) DOUBLE PRECISION array, dimension (NX)
*              Array containing the state variables.
*
*     XPRIME   (input) DOUBLE PRECISION array, dimension (NX)
*              Array containing the state variables derivative.
*
*     NX       (input) INTEGER
*              Dimension of the state vector.
*
*     U        (input) DOUBLE PRECISION array, dimension (NU)
*              Array containing the input values.
*
*     NU       (input) INTEGER
*              Dimension of the input vector.
*
*     P        (input) DOUBLE PRECISION array, dimension (NP)
*              Array containing the parameter values.
*
*     NP       (input) INTEGER
*              Dimension of the parameter vector.
*
*     T        (input) INTEGER
*              The time point where the function is evaluated.
*
*     F        (output) DOUBLE PRECISION array, dimension (LDF,NX)
*              The resulting function value f(T,X).
*
*     LDF      (input) INTEGER
*              The leading dimension of F.
*
*     Error Indicator
*
*     INFO     INTEGER
*              Returns values of error from MEVAL or 100 in case
*              a bad problem was choosen.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*
*     .. Common variables ..
      COMMON /TESTING/ ISOLVER
      INTEGER ISOLVER
      INTEGER LSODI_, LSOIBT_, RADAU5_, DASSL_, DASPK_, GELDA_
      PARAMETER (LSODI_  = 1, LSOIBT_ = 2)
      PARAMETER (RADAU5_ = 3, DASSL_  = 4, DASPK_  = 5)
      PARAMETER (GELDA_  = 6)
*     .. Scalar Arguments ..
      INTEGER          NRP, NIP, NX, NU, NP, LDF, INFO
      DOUBLE PRECISION T
*     .. Array Arguments ..
      INTEGER          IPAR(NIP)
      DOUBLE PRECISION RPAR(NRP), X(NX), XPRIME(NX), U(NU), P(NP),
     $  F(LDF,NX)
*     .. Local Scalars ..
      INTEGER          I
*     .. External Subroutines ..
      EXTERNAL         MLSODIX, RLSODIX
*     .. Executable Statements ..
      IF (ISOLVER .EQ. DASSL_ .OR. ISOLVER .EQ. DASPK_) THEN
        CALL RLSODIX(LDF,NX,T,X,XPRIME,F,INFO,RPAR,IPAR)
      ELSE
        CALL MLSODIX(LDF,NX,T,X,XPRIME,F,INFO,RPAR,IPAR)
      ENDIF
* *** Last line of DAEDF_ ***
      END
 
 
 

      SUBROUTINE  JACFX_( NRP, NIP, RPAR, IPAR, NX, NU,
     $                    NP, X, U, P, T, FX, LDFX,
     $                    INFO )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     Interface routine between DAESolver and the problem function JEVAL
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     NRP      (input) INTEGER
*              Dimension of RPAR array.
*
*     NIP      (input) INTEGER
*              Dimension of IPAR array.
*
*     RPAR     (input/output) DOUBLE PRECISION array
*              Array for communication between the driver and JEVAL.
*
*     IPAR     (input/output) INTEGER array
*              Array for communication between the driver and JEVAL.
*
*     NX       (input) INTEGER
*              Dimension of the state vector.
*
*     NU       (input) INTEGER
*              Dimension of the input vector.
*
*     NP       (input) INTEGER
*              Dimension of the parameter vector.
*
*     X        (input) DOUBLE PRECISION array, dimension (NX)
*              Array containing the state variables.
*
*     U        (input) DOUBLE PRECISION array, dimension (NU)
*              Array containing the input values.
*
*     P        (input) DOUBLE PRECISION array, dimension (NP)
*              Array containing the parameter values.
*
*     T        (input) INTEGER
*              The time point where the derivative is evaluated.
*
*     FX       (output) DOUBLE PRECISION array, dimension (LDFX,NX)
*              The array with the resulting Jacobian matrix.
*
*     LDFX     (input) INTEGER
*              The leading dimension of the array FX.
*
*     Error Indicator
*
*     INFO     INTEGER
*              Returns values of error from JEVAL or 100 in case
*              a bad problem was choosen.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*
*     .. Common variables ..
      COMMON /TESTING/ ISOLVER
      INTEGER LSODI_, LSOIBT_, RADAU5_, DASSL_, DASPK_, GELDA_
      PARAMETER (LSODI_  = 1, LSOIBT_ = 2)
      PARAMETER (RADAU5_ = 3, DASSL_  = 4, DASPK_  = 5)
      PARAMETER (GELDA_  = 6)
*     .. Scalar Arguments ..
      INTEGER          NRP, NIP, NX, NU, NP, LDFX, INFO
      DOUBLE PRECISION T
*     .. Array Arguments ..
      INTEGER          IPAR(NIP)
      DOUBLE PRECISION X(NX), U(NU), P(NP), RPAR(NRP), FX(LDFX,NX)
*     .. External Subroutines ..
      EXTERNAL         JLSODIX
*     .. Executable Statements ..
      CALL JLSODIX(LDFX,NX,T,X,X,FX,INFO,RPAR,IPAR)
* *** Last line of JACFX_ ***
      END
 
 

      SUBROUTINE JACFXDOT_( NRP, NIP, RPAR, IPAR,
     $                NX, NU, NP, XPRIME, U, P, T, J, LDJ, INFO )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     MATJACFXDOT routine for TRANSAMP problem
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     NRP      (input) INTEGER
*              Dimension of RPAR array.
*
*     NIP      (input) INTEGER
*              Dimension of IPAR array.
*
*     RPAR     (input/output) DOUBLE PRECISION array
*              Array for communication with the driver.
*
*     IPAR     (input/output) INTEGER array
*              Array for communication with the driver.
*
*     NX       (input) INTEGER
*              Dimension of the state vector.
*
*
*     NU       (input) INTEGER
*              Dimension of the input vector.
*
*     NP       (input) INTEGER
*              Dimension of the parameter vector.
*
*     XPRIME   (input) DOUBLE PRECISION array, dimension (NX)
*              Array containing the derivative of the state variables.
*
*     U        (input) DOUBLE PRECISION array, dimension (NU)
*              Array containing the input values.
*
*     P        (input) DOUBLE PRECISION array, dimension (NP)
*              Array containing the parameter values.
*
*     T        (input) INTEGER
*              The time point where the derivative is evaluated.
*
*     J        (output) DOUBLE PRECISION array, dimension (LDJ,NX)
*              The array with the resulting derivative matrix.
*
*     LDJ      (input) INTEGER
*              The leading dimension of the array J.
*
*     Error Indicator
*
*     INFO     INTEGER
*              Returns 1 in case a bad problem was choosen.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*
*     .. Common variables ..
      COMMON /TESTING/ ISOLVER
      INTEGER LSODI_, LSOIBT_, RADAU5_, DASSL_, DASPK_, GELDA_
      PARAMETER (LSODI_  = 1, LSOIBT_ = 2)
      PARAMETER (RADAU5_ = 3, DASSL_  = 4, DASPK_  = 5)
      PARAMETER (GELDA_  = 6)
*     .. Scalar Arguments ..
      INTEGER          NRP, NIP, NX, NU, NP, LDJ, INFO
      DOUBLE PRECISION T
*     .. Array Arguments ..
      INTEGER          IPAR(NIP)
      DOUBLE PRECISION XPRIME(NX), U(NU), P(NP), RPAR(NRP), J(LDJ,NX)
*     .. Executable Statements ..
*
      CALL JDOTLSODIX(LDJ,NX,T,XPRIME,XPRIME,J,INFO,RPAR,IPAR)
      ENDIF
* *** Last line of JACFXDOT_ ***
      END
 

Program Data 

No data required
Program Results 
 DAESOLVER EXAMPLE PROGRAM RESULTS
 
 Problem: LSODIX   Solver: LSODI  
 lsodix                                   (lsodix   , DAE) with SOLVER  1
 IWARN on exit from DAESolver =   2
 Solution: (calculated) (reference)
 6.462112224297606E-07
 1.255974374648338E-10
 6.117680951077711E-07
 Relative error comparing with the reference solution:    .8898590685949503E-06

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.
Return to index slicot-5.0+20101122/doc/DE01OD.html000077500000000000000000000116631201767322700160670ustar00rootroot00000000000000 DE01OD - SLICOT Library Routine Documentation

DE01OD

Convolution or deconvolution of two real signals

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the convolution or deconvolution of two real signals
  A and B.
Specification 
      SUBROUTINE DE01OD( CONV, N, A, B, INFO )
C     .. Scalar Arguments ..
      CHARACTER         CONV
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*)
Arguments

Mode Parameters 

  CONV    CHARACTER*1
          Indicates whether convolution or deconvolution is to be
          performed as follows:
          = 'C':  Convolution;
          = 'D':  Deconvolution.
Input/Output Parameters 
  N       (input) INTEGER
          The number of samples.  N must be a power of 2.  N >= 2.

  A       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the first signal.
          On exit, this array contains the convolution (if
          CONV = 'C') or deconvolution (if CONV = 'D') of the two
          signals.

  B       (input) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the second signal.
          NOTE that this array is overwritten.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  This routine computes the convolution or deconvolution of two real
  signals A and B using an FFT algorithm (SLICOT Library routine
  DG01MD).
References 
  [1] Rabiner, L.R. and Rader, C.M.
      Digital Signal Processing.
      IEEE Press, 1972.
Numerical Aspects 
  The algorithm requires 0( N*log(N) ) operations.
Further Comments 
  None
Example

Program Text 

*     DE01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 128 )
*     .. Local Scalars ..
      INTEGER          I, INFO, N
      CHARACTER*1      CONV
*     .. Local Arrays ..
      DOUBLE PRECISION A(NMAX), B(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DE01OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, CONV
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), B(I), I = 1,N )
*        Perform convolution on A and B.
         CALL DE01OD( CONV, N, A, B, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( CONV, 'C' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
            ELSE
               WRITE ( NOUT, FMT = 99996 )
            END IF
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99995 ) I, A(I)
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' DE01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DE01OD = ',I2)
99997 FORMAT ('   Convolution ',//'   i    A(i)',/)
99996 FORMAT ('   Deconvolution ',//'   i    A(i)',/)
99995 FORMAT (I4,1X,F8.4)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 DE01OD EXAMPLE PROGRAM DATA
   8     C
   0.4862   0.2288
   0.1948   0.3671
   0.5788   0.6417
  -0.5861   0.3875
   0.8254   0.2380
   0.1815   0.4682
   0.2904   0.5312
  -0.3599   0.6116
Program Results 
 DE01OD EXAMPLE PROGRAM RESULTS

   Convolution 

   i    A(i)

   1   0.5844
   2   0.5769
   3   0.6106
   4   1.0433
   5   0.6331
   6   0.4531
   7   0.7027
   8   0.9929

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/DE01PD.html000077500000000000000000000134621201767322700160670ustar00rootroot00000000000000 DE01PD - SLICOT Library Routine Documentation

DE01PD

Convolution or deconvolution of two real signals using Hartley transform

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the convolution or deconvolution of two real signals
  A and B using the Hartley transform.
Specification 
      SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO )
C     .. Scalar Arguments ..
      CHARACTER         CONV, WGHT
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*), W(*)
Arguments

Mode Parameters 

  CONV    CHARACTER*1
          Indicates whether convolution or deconvolution is to be
          performed as follows:
          = 'C':  Convolution;
          = 'D':  Deconvolution.

  WGHT    CHARACTER*1
          Indicates whether the precomputed weights are available
          or not, as follows:
          = 'A':  available;
          = 'N':  not available.
          Note that if N > 1 and WGHT = 'N' on entry, then WGHT is
          set to 'A' on exit.
Input/Output Parameters 
  N       (input) INTEGER
          The number of samples.  N must be a power of 2.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the first signal.
          On exit, this array contains the convolution (if
          CONV = 'C') or deconvolution (if CONV = 'D') of the two
          signals.

  B       (input) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the second signal.
          NOTE that this array is overwritten.

  W       (input/output) DOUBLE PRECISION array,
                         dimension (N - LOG2(N))
          On entry with WGHT = 'A', this array must contain the long
          weight vector computed by a previous call of this routine
          or of the SLICOT Library routine DG01OD.f, with the same
          value of N. If WGHT = 'N', the contents of this array on
          entry is ignored.
          On exit, this array contains the long weight vector.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  This routine computes the convolution or deconvolution of two
  real signals A and B using three scrambled Hartley transforms
  (SLICOT Library routine DG01OD).
References 
  [1] Van Loan, Charles.
      Computational frameworks for the fast Fourier transform.
      SIAM, 1992.
Numerical Aspects 
  The algorithm requires O(N log(N)) floating point operations.
Further Comments 
  None
Example

Program Text 

*     DE01PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 128 )
*     .. Local Scalars ..
      INTEGER          I, INFO, N
      CHARACTER*1      CONV, WGHT
*     .. Local Arrays ..
      DOUBLE PRECISION A(NMAX), B(NMAX), W(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DE01PD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, CONV, WGHT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), B(I), I = 1,N )
*        Perform convolution on A and B.
         CALL DE01PD( CONV, WGHT, N, A, B, W, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( CONV, 'C' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
            ELSE
               WRITE ( NOUT, FMT = 99996 )
            END IF
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99995 ) I, A(I)
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' DE01PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DE01PD = ',I2)
99997 FORMAT ('   Convolution ',//'   i    A(i)',/)
99996 FORMAT ('   Deconvolution ',//'   i    A(i)',/)
99995 FORMAT (I4,1X,F8.4)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 DE01PD EXAMPLE PROGRAM DATA
   8     C     N
   0.4862   0.2288
   0.1948   0.3671
   0.5788   0.6417
  -0.5861   0.3875
   0.8254   0.2380
   0.1815   0.4682
   0.2904   0.5312
  -0.3599   0.6116
Program Results 
 DE01PD EXAMPLE PROGRAM RESULTS

   Convolution 

   i    A(i)

   1   0.5844
   2   0.5769
   3   0.6106
   4   1.0433
   5   0.6331
   6   0.4531
   7   0.7027
   8   0.9929

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/DF01MD.html000077500000000000000000000171041201767322700160620ustar00rootroot00000000000000 DF01MD - SLICOT Library Routine Documentation

DF01MD

Sine transform or cosine transform of a real signal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the sine transform or cosine transform of a real
  signal.
Specification 
      SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         SICO
      INTEGER           INFO, N
      DOUBLE PRECISION  DT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), DWORK(*)
Arguments

Mode Parameters 

  SICO    CHARACTER*1
          Indicates whether the sine transform or cosine transform
          is to be computed as follows:
          = 'S':  The sine transform is computed;
          = 'C':  The cosine transform is computed.
Input/Output Parameters 
  N       (input) INTEGER
          The number of samples.  N must be a power of 2 plus 1.
          N >= 5.

  DT      (input) DOUBLE PRECISION
          The sampling time of the signal.

  A       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the signal to be
          processed.
          On exit, this array contains either the sine transform, if
          SICO = 'S', or the cosine transform, if SICO = 'C', of the
          given signal.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N+1)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Let A(1), A(2),..., A(N) be a real signal of N samples.

  If SICO = 'S', the routine computes the sine transform of A as
  follows. First, transform A(i), i = 1,2,...,N, into the complex
  signal B(i), i = 1,2,...,(N+1)/2, where

     B(1) = -2*A(2),
     B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2,
     B((N+1)/2) = 2*A(N-1) and j**2 = -1.

  Next, perform a discrete inverse Fourier transform on B(i) by
  calling SLICOT Library Routine DG01ND, to give the complex signal
  Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be
  obtained as follows:

     C(2i-1) = Re(Z(i)),  C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2.

  Finally, compute the sine transform coefficients S ,S ,...,S
                                                    1  2      N
  given by

     S  = 0,
      1
             {                     [C(k) + C(N+1-k)]     }
     S  = DT*{[C(k) - C(N+1-k)] - -----------------------},
      k      {                    [2*sin(pi*(k-1)/(N-1))]}

        for k = 2,3,...,N-1, and

     S = 0.
      N

  If SICO = 'C', the routine computes the cosine transform of A as
  follows. First, transform A(i), i = 1,2,...,N, into the complex
  signal B(i), i = 1,2,...,(N+1)/2, where

     B(1) = 2*A(1),
     B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]}
     for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N).

  Next, perform a discrete inverse Fourier transform on B(i) by
  calling SLICOT Library Routine DG01ND, to give the complex signal
  Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be
  obtained as follows:

     D(2i-1) = Re(Z(i)),  D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2.

  Finally, compute the cosine transform coefficients S ,S ,...,S
                                                      1  2      N
  given by

     S  = 2*DT*[D(1) + A0],
      1
             {                     [D(k) - D(N+1-k)]     }
     S  = DT*{[D(k) + D(N+1-k)] - -----------------------},
      k      {                    [2*sin(pi*(k-1)/(N-1))]}

        for k = 2,3,...,N-1, and

     S  = 2*DT*[D(1) - A0],
      N
              (N-1)/2
  where A0 = 2*SUM   A(2i).
               i=1
References 
  [1] Rabiner, L.R. and Rader, C.M.
      Digital Signal Processing.
      IEEE Press, 1972.

  [2] Oppenheim, A.V. and Schafer, R.W.
      Discrete-Time Signal Processing.
      Prentice-Hall Signal Processing Series, 1989.
Numerical Aspects 
  The algorithm requires 0( N*log(N) ) operations.
Further Comments 
  None
Example

Program Text 

*     DF01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 129 )
*     .. Local Scalars ..
      DOUBLE PRECISION DT
      INTEGER          I, INFO, N
      CHARACTER*1      SICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(NMAX), DWORK(NMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DF01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DT, SICO
      IF ( N.LE.1 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,N )
*        Compute the sine/cosine transform of the given real signal.
         CALL DF01MD( SICO, N, DT, A, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( SICO, 'S' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) I, A(I)
   20          CONTINUE
            ELSE
               WRITE ( NOUT, FMT = 99996 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) I, A(I)
   40          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' DF01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DF01MD = ',I2)
99997 FORMAT (' Components of sine transform are',//'   i',6X,'A(i)',/)
99996 FORMAT (' Components of cosine transform are',//'   i',6X,'A(i)',
     $       /)
99995 FORMAT (I4,3X,F8.4)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 DF01MD EXAMPLE PROGRAM DATA
  17     1.0     C
  -0.1862
   0.1288
   0.3948
   0.0671
   0.6788
  -0.2417
   0.1861
   0.8875
   0.7254
   0.9380
   0.5815
  -0.2682
   0.4904
   0.9312
  -0.9599
  -0.3116
   0.8743
Program Results 
 DF01MD EXAMPLE PROGRAM RESULTS

 Components of cosine transform are

   i      A(i)

   1    28.0536
   2     3.3726
   3   -20.8158
   4     6.0566
   5     5.7317
   6    -3.9347
   7   -12.8074
   8    -6.8780
   9    16.2892
  10   -17.0788
  11    21.7836
  12   -20.8203
  13    -7.3277
  14    -2.5325
  15    -0.3636
  16     7.8792
  17    11.0048

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/DG01MD.html000077500000000000000000000141211201767322700160570ustar00rootroot00000000000000 DG01MD - SLICOT Library Routine Documentation

DG01MD

Discrete Fourier transform, or inverse transform, of a complex signal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the discrete Fourier transform, or inverse transform,
  of a complex signal.
Specification 
      SUBROUTINE DG01MD( INDI, N, XR, XI, INFO )
C     .. Scalar Arguments ..
      CHARACTER         INDI
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  XI(*), XR(*)
Arguments

Mode Parameters 

  INDI    CHARACTER*1
          Indicates whether a Fourier transform or inverse Fourier
          transform is to be performed as follows:
          = 'D':  (Direct) Fourier transform;
          = 'I':  Inverse Fourier transform.
Input/Output Parameters 
  N       (input) INTEGER
          The number of complex samples.  N must be a power of 2.
          N >= 2.

  XR      (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the real part of either
          the complex signal z if INDI = 'D', or f(z) if INDI = 'I'.
          On exit, this array contains either the real part of the
          computed Fourier transform f(z) if INDI = 'D', or the
          inverse Fourier transform z of f(z) if INDI = 'I'.

  XI      (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the imaginary part of
          either z if INDI = 'D', or f(z) if INDI = 'I'.
          On exit, this array contains either the imaginary part of
          f(z) if INDI = 'D', or z if INDI = 'I'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  If INDI = 'D', then the routine performs a discrete Fourier
  transform on the complex signal Z(i), i = 1,2,...,N. If the result
  is denoted by FZ(k), k = 1,2,...,N, then the relationship between
  Z and FZ is given by the formula:

                  N            ((k-1)*(i-1))
         FZ(k) = SUM ( Z(i) * V              ),
                 i=1
                                  2
  where V = exp( -2*pi*j/N ) and j  = -1.

  If INDI = 'I', then the routine performs an inverse discrete
  Fourier transform on the complex signal FZ(k), k = 1,2,...,N. If
  the result is denoted by Z(i), i = 1,2,...,N, then the
  relationship between Z and FZ is given by the formula:

                 N             ((k-1)*(i-1))
         Z(i) = SUM ( FZ(k) * W              ),
                k=1

  where W = exp( 2*pi*j/N ).

  Note that a discrete Fourier transform, followed by an inverse
  discrete Fourier transform, will result in a signal which is a
  factor N larger than the original input signal.
References 
  [1] Rabiner, L.R. and Rader, C.M.
      Digital Signal Processing.
      IEEE Press, 1972.
Numerical Aspects 
  The algorithm requires 0( N*log(N) ) operations.
Further Comments 
  None
Example

Program Text 

*     DG01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 128 )
*     .. Local Scalars ..
      INTEGER          I, INFO, N
      CHARACTER*1      INDI
*     .. Local Arrays ..
      DOUBLE PRECISION XI(NMAX), XR(NMAX)
*     .. External Subroutines ..
      EXTERNAL         DG01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, INDI
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( XR(I), XI(I), I = 1,N )
*        Find the Fourier transform of the given complex signal.
         CALL DG01MD( INDI, N, XR, XI, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) I, XR(I), XI(I)
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' DG01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DG01MD = ',I2)
99997 FORMAT (' Components of Fourier transform are',//'   i',6X,
     $       'XR(i)',6X,'XI(i)',/)
99996 FORMAT (I4,3X,F8.4,3X,F8.4)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 DG01MD EXAMPLE PROGRAM DATA
   8     D
  -0.1862   0.1288
   0.3948   0.0671
   0.6788  -0.2417
   0.1861   0.8875
   0.7254   0.9380
   0.5815  -0.2682
   0.4904   0.9312
  -0.9599  -0.3116
Program Results 
 DG01MD EXAMPLE PROGRAM RESULTS

 Components of Fourier transform are

   i      XR(i)      XI(i)

   1     1.9109     2.1311
   2    -1.9419    -2.2867
   3    -1.4070    -1.3728
   4     2.2886    -0.6883
   5     1.5059     1.3815
   6    -2.2271     0.2915
   7     0.1470     2.1274
   8    -1.7660    -0.5533

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/DG01ND.html000077500000000000000000000225071201767322700160670ustar00rootroot00000000000000 DG01ND - SLICOT Library Routine Documentation

DG01ND

Discrete Fourier transform, or inverse Fourier transform, of a real signal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the discrete Fourier transform, or inverse Fourier
  transform, of a real signal.
Specification 
      SUBROUTINE DG01ND( INDI, N, XR, XI, INFO )
C     .. Scalar Arguments ..
      CHARACTER         INDI
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  XI(*), XR(*)
Arguments

Mode Parameters 

  INDI    CHARACTER*1
          Indicates whether a Fourier transform or inverse Fourier
          transform is to be performed as follows:
          = 'D':  (Direct) Fourier transform;
          = 'I':  Inverse Fourier transform.
Input/Output Parameters 
  N       (input) INTEGER
          Half the number of real samples.  N must be a power of 2.
          N >= 2.

  XR      (input/output) DOUBLE PRECISION array, dimension (N+1)
          On entry with INDI = 'D', the first N elements of this
          array must contain the odd part of the input signal; for
          example, XR(I) = A(2*I-1) for I = 1,2,...,N.
          On entry with INDI = 'I', the first N+1 elements of this
          array must contain the the real part of the input discrete
          Fourier transform (computed, for instance, by a previous
          call of the routine).
          On exit with INDI = 'D', the first N+1 elements of this
          array contain the real part of the output signal, that is
          of the computed discrete Fourier transform.
          On exit with INDI = 'I', the first N elements of this
          array contain the odd part of the output signal, that is
          of the computed inverse discrete Fourier transform.

  XI      (input/output) DOUBLE PRECISION array, dimension (N+1)
          On entry with INDI = 'D', the first N elements of this
          array must contain the even part of the input signal; for
          example, XI(I) = A(2*I) for I = 1,2,...,N.
          On entry with INDI = 'I', the first N+1 elements of this
          array must contain the the imaginary part of the input
          discrete Fourier transform (computed, for instance, by a
          previous call of the routine).
          On exit with INDI = 'D', the first N+1 elements of this
          array contain the imaginary part of the output signal,
          that is of the computed discrete Fourier transform.
          On exit with INDI = 'I', the first N elements of this
          array contain the even part of the output signal, that is
          of the computed inverse discrete Fourier transform.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Let A(1),....,A(2*N) be a real signal of 2*N samples. Then the
  first N+1 samples of the discrete Fourier transform of this signal
  are given by the formula:

               2*N           ((m-1)*(i-1))
       FA(m) = SUM ( A(i) * W              ),
               i=1
                                               2
  where m = 1,2,...,N+1, W = exp(-pi*j/N) and j = -1.

  This transform can be computed as follows. First, transform A(i),
  i = 1,2,...,2*N, into the complex signal Z(i) = (X(i),Y(i)),
  i = 1,2,...,N. That is, X(i) = A(2*i-1) and Y(i) = A(2*i). Next,
  perform a discrete Fourier transform on Z(i) by calling SLICOT
  Library routine DG01MD. This gives a new complex signal FZ(k),
  such that

                N            ((k-1)*(i-1))
       FZ(k) = SUM ( Z(i) * V              ),
               i=1

  where k = 1,2,...,N, V = exp(-2*pi*j/N).  Using the values of
  FZ(k), the components of the discrete Fourier transform FA can be
  computed by simple linear relations, implemented in the DG01NY
  subroutine.

  Finally, let

       XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)),   k = 1,2,...,N,

  be the contents of the arrays XR and XI on entry to DG01NY with
  INDI = 'D', then on exit XR and XI contain the real and imaginary
  parts of the Fourier transform of the original real signal A.
  That is,

       XR(m) = Re(FA(m)),  XI(m) = Im(FA(m)),

  where m = 1,2,...,N+1.

  If INDI = 'I', then the routine evaluates the inverse Fourier
  transform of a complex signal which may itself be the discrete
  Fourier transform of a real signal.

  Let FA(m), m = 1,2,...,2*N, denote the full discrete Fourier
  transform of a real signal A(i), i=1,2,...,2*N. The relationship
  between FA and A is given by the formula:

              2*N            ((m-1)*(i-1))
       A(i) = SUM ( FA(m) * W              ),
              m=1

  where W = exp(pi*j/N).

  Let

       XR(m) = Re(FA(m)) and XI(m) = Im(FA(m)) for m = 1,2,...,N+1,

  be the contents of the arrays XR and XI on entry to the routine
  DG01NY with INDI = 'I', then on exit the first N samples of the
  complex signal FZ are returned in XR and XI such that

       XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)) and k = 1,2,...,N.

  Next, an inverse Fourier transform is performed on FZ (e.g. by
  calling SLICOT Library routine DG01MD), to give the complex signal
  Z, whose i-th component is given by the formula:

               N             ((k-1)*(i-1))
       Z(i) = SUM ( FZ(k) * V              ),
              k=1

  where i = 1,2,...,N and V = exp(2*pi*j/N).

  Finally, the 2*N samples of the real signal A can then be obtained
  directly from Z. That is,

       A(2*i-1) = Re(Z(i)) and A(2*i) = Im(Z(i)), for i = 1,2,...N.

  Note that a discrete Fourier transform, followed by an inverse
  transform will result in a signal which is a factor 2*N larger
  than the original input signal.
References 
  [1] Rabiner, L.R. and Rader, C.M.
      Digital Signal Processing.
      IEEE Press, 1972.
Numerical Aspects 
  The algorithm requires 0( N*log(N) ) operations.
Further Comments 
  None
Example

Program Text 

*     DG01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 128 )
*     .. Local Scalars ..
      INTEGER          I, IEND, INFO, N
      CHARACTER*1      INDI
*     .. Local Arrays ..
      DOUBLE PRECISION A(2*NMAX), XI(NMAX+1), XR(NMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DG01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, INDI
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,2*N )
*        Copy the odd and even parts of A into XR and XI respectively.
         DO 20 I = 1, N
            XR(I) = A(2*I-1)
            XI(I) = A(2*I)
   20    CONTINUE
*        Find the Fourier transform of the given real signal.
         CALL DG01ND( INDI, N, XR, XI, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            IEND = N
            IF ( LSAME( INDI, 'D' ) ) IEND = N + 1
            DO 40 I = 1, IEND
               WRITE ( NOUT, FMT = 99996 ) I, XR(I), XI(I)
   40       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' DG01ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DG01ND = ',I2)
99997 FORMAT (' Components of Fourier transform are',//'   i',6X,
     $       'XR(i)',6X,'XI(i)',/)
99996 FORMAT (I4,3X,F8.4,3X,F8.4)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 DG01ND EXAMPLE PROGRAM DATA
   8     D
  -0.1862
   0.1288
   0.3948
   0.0671
   0.6788
  -0.2417
   0.1861
   0.8875
   0.7254
   0.9380
   0.5815
  -0.2682
   0.4904
   0.9312
  -0.9599
  -0.3116
Program Results 
 DG01ND EXAMPLE PROGRAM RESULTS

 Components of Fourier transform are

   i      XR(i)      XI(i)

   1     4.0420     0.0000
   2    -3.1322    -0.2421
   3     0.1862    -1.4675
   4    -2.1312    -1.1707
   5     1.5059    -1.3815
   6     2.1927    -0.1908
   7    -1.4462     2.0327
   8    -0.5757     1.4914
   9    -0.2202     0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/DG01OD.html000077500000000000000000000130361201767322700160650ustar00rootroot00000000000000 DG01OD - SLICOT Library Routine Documentation

DG01OD

Scrambled discrete Hartley transform of a real signal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the (scrambled) discrete Hartley transform of
  a real signal.
Specification 
      SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO )
C     .. Scalar Arguments ..
      CHARACTER         SCR, WGHT
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), W(*)
Arguments

Mode Parameters 

  SCR     CHARACTER*1
          Indicates whether the signal is scrambled on input or
          on output as follows:
          = 'N':  the signal is not scrambled at all;
          = 'I':  the input signal is bit-reversed;
          = 'O':  the output transform is bit-reversed.

  WGHT    CHARACTER*1
          Indicates whether the precomputed weights are available
          or not, as follows:
          = 'A':  available;
          = 'N':  not available.
          Note that if N > 1 and WGHT = 'N' on entry, then WGHT is
          set to 'A' on exit.
Input/Output Parameters 
  N       (input) INTEGER
          Number of real samples. N must be a power of 2.
          N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry with SCR = 'N' or SCR = 'O', this array must
          contain the input signal.
          On entry with SCR = 'I', this array must contain the
          bit-reversed input signal.
          On exit with SCR = 'N' or SCR = 'I', this array contains
          the Hartley transform of the input signal.
          On exit with SCR = 'O', this array contains the
          bit-reversed Hartley transform.

  W       (input/output) DOUBLE PRECISION array,
                         dimension (N - LOG2(N))
          On entry with WGHT = 'A', this array must contain the long
          weight vector computed by a previous call of this routine
          with the same value of N. If WGHT = 'N', the contents of
          this array on entry is ignored.
          On exit, this array contains the long weight vector.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  This routine uses a Hartley butterfly algorithm as described
  in [1].
References 
  [1] Van Loan, Charles.
      Computational frameworks for the fast Fourier transform.
      SIAM, 1992.
Numerical Aspects 
  The algorithm is backward stable and requires O(N log(N))
  floating point operations.
Further Comments 
  None
Example

Program Text 

*     DG01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 128 )
*     .. Local Scalars ..
      INTEGER          I, INFO, N
      CHARACTER*1      SCR, WGHT
*     .. Local Arrays ..
      DOUBLE PRECISION A(NMAX), W(NMAX)
*     .. External Subroutines ..
      EXTERNAL         DG01OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, SCR, WGHT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,N )
*        Compute the Hartley transform.
         CALL DG01OD( SCR, WGHT, N, A, W, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) I, A(I)
   10       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' DG01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DG01OD = ',I2)
99997 FORMAT ('   Hartley transform ',//'   i    A(i)',/)
99996 FORMAT (I4,1X,F8.4)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 DG01OD EXAMPLE
  16      N      N
 1.0
 2.0
 3.0
 4.0
 5.0
 6.0
 7.0
 8.0
 9.0
10.0
11.0
12.0
13.0
14.0
15.0
16.0
Program Results 
 DG01OD EXAMPLE PROGRAM RESULTS

   Hartley transform 

   i    A(i)

   1 136.0000
   2 -48.2187
   3 -27.3137
   4 -19.9728
   5 -16.0000
   6 -13.3454
   7 -11.3137
   8  -9.5913
   9  -8.0000
  10  -6.4087
  11  -4.6863
  12  -2.6546
  13   0.0000
  14   3.9728
  15  11.3137
  16  32.2187

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/DK01MD.html000077500000000000000000000115431201767322700160700ustar00rootroot00000000000000 DK01MD - SLICOT Library Routine Documentation

DK01MD

Anti-aliasing window applied to a real signal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply an anti-aliasing window to a real signal.
Specification 
      SUBROUTINE DK01MD( TYPE, N, A, INFO )
C     .. Scalar Arguments ..
      CHARACTER         TYPE
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*)
Arguments

Mode Parameters 

  TYPE    CHARACTER*1
          Indicates the type of window to be applied to the signal
          as follows:
          = 'M':  Hamming window;
          = 'N':  Hann window;
          = 'Q':  Quadratic window.
Input/Output Parameters 
  N       (input) INTEGER
          The number of samples.  N >= 1.

  A       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the signal to be
          processed.
          On exit, this array contains the windowing function.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  If TYPE = 'M', then a Hamming window is applied to A(1),...,A(N),
  which yields
    _
    A(i) = (0.54 + 0.46*cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N.

  If TYPE = 'N', then a Hann window is applied to A(1),...,A(N),
  which yields
    _
    A(i) = 0.5*(1 + cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N.

  If TYPE = 'Q', then a quadratic window is applied to A(1),...,
  A(N), which yields
    _
    A(i) = (1 - 2*((i-1)/(N-1))**2)*(1 - (i-1)/(N-1))*A(i),
                                          i = 1,2,...,(N-1)/2+1;
    _
    A(i) = 2*(1 - ((i-1)/(N-1))**3)*A(i), i = (N-1)/2+2,...,N.
References 
  [1] Rabiner, L.R. and Rader, C.M.
      Digital Signal Processing.
      IEEE Press, 1972.
Numerical Aspects 
  The algorithm requires 0( N ) operations.
Further Comments 
  None
Example

Program Text 

*     DK01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
*     .. Local Scalars ..
      CHARACTER*1      TYPE
      INTEGER          I, INFO, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(NMAX)
*     .. External Subroutines ..
      EXTERNAL         DK01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, TYPE
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,N )
*        Apply a Hamming window to the given signal.
         CALL DK01MD( TYPE, N, A, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) I, A(I)
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' DK01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DK01MD = ',I2)
99997 FORMAT (' Components of the windowing function are',//'   k     ',
     $       ' A(k)',/)
99996 FORMAT (I4,3X,F8.4)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 DK01MD EXAMPLE PROGRAM DATA
   8     M
   0.3262
   0.8723
  -0.7972
   0.6673
  -0.1722
   0.3237
   0.5263
  -0.3275
Program Results 
 DK01MD EXAMPLE PROGRAM RESULTS

 Components of the windowing function are

   k      A(k)

   1     0.3262
   2     0.8326
   3    -0.6591
   4     0.4286
   5    -0.0754
   6     0.0820
   7     0.0661
   8    -0.0262

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/FB01QD.html000077500000000000000000000417671201767322700161000ustar00rootroot00000000000000 FB01QD - SLICOT Library Routine Documentation

FB01QD

Time-varying square root covariance Kalman filter (dense matrices)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate a combined measurement and time update of one
  iteration of the time-varying Kalman filter. This update is given
  for the square root covariance filter, using dense matrices.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOBK    CHARACTER*1
          Indicates whether the user wishes to compute the Kalman
          filter gain matrix K  as follows:
                              i
          = 'K':  K  is computed and stored in array K;
                   i
          = 'N':  K  is not required.
                   i

  MULTBQ  CHARACTER*1                    1/2
          Indicates how matrices B  and Q    are to be passed to
                                  i      i
          the routine as follows:
          = 'P':  Array Q is not used and the array B must contain
                                 1/2
                  the product B Q   ;
                               i i
          = 'N':  Arrays B and Q must contain the matrices as
                  described below.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e., the order of the
          matrices S    and A .  N >= 0.
                    i-1      i

  M       (input) INTEGER
          The actual input dimension, i.e., the order of the matrix
           1/2
          Q   .  M >= 0.
           i

  P       (input) INTEGER
          The actual output dimension, i.e., the order of the matrix
           1/2
          R   .  P >= 0.
           i

  S       (input/output) DOUBLE PRECISION array, dimension (LDS,N)
          On entry, the leading N-by-N lower triangular part of this
          array must contain S   , the square root (left Cholesky
                              i-1
          factor) of the state covariance matrix at instant (i-1).
          On exit, the leading N-by-N lower triangular part of this
          array contains S , the square root (left Cholesky factor)
                          i
          of the state covariance matrix at instant i.
          The strict upper triangular part of this array is not
          referenced.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,N).

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain A ,
                                                              i
          the state transition matrix of the discrete system at
          instant i.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain B ,
                                                     1/2      i
          the input weight matrix (or the product B Q    if
                                                   i i
          MULTBQ = 'P') of the discrete system at instant i.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,*)
          If MULTBQ = 'N', then the leading M-by-M lower triangular
                                           1/2
          part of this array must contain Q   , the square root
                                           i
          (left Cholesky factor) of the input (process) noise
          covariance matrix at instant i.
          The strict upper triangular part of this array is not
          referenced.
          If MULTBQ = 'P', Q is not referenced and can be supplied
          as a dummy array (i.e., set parameter LDQ = 1 and declare
          this array to be Q(1,1) in the calling program).

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= MAX(1,M) if MULTBQ = 'N';
          LDQ >= 1        if MULTBQ = 'P'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain C , the
                                                              i
          output weight matrix of the discrete system at instant i.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,P)
          On entry, the leading P-by-P lower triangular part of this
                              1/2
          array must contain R   , the square root (left Cholesky
                              i
          factor) of the output (measurement) noise covariance
          matrix at instant i.
          On exit, the leading P-by-P lower triangular part of this
                                 1/2
          array contains (RINOV )   , the square root (left Cholesky
                               i
          factor) of the covariance matrix of the innovations at
          instant i.
          The strict upper triangular part of this array is not
          referenced.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,P).

  K       (output) DOUBLE PRECISION array, dimension (LDK,P)
          If JOBK = 'K', and INFO = 0, then the leading N-by-P part
          of this array contains K , the Kalman filter gain matrix
                                  i
          at instant i.
          If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the
          leading N-by-P part of this array contains AK , a matrix
                                                       i
          related to the Kalman filter gain matrix at instant i (see
                                                         -1/2
          METHOD). Specifically, AK  = A P     C'(RINOV')    .
                                   i    i i|i-1 i      i

  LDK     INTEGER
          The leading dimension of array K.   LDK >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          If JOBK = 'K', then TOL is used to test for near
                                            1/2
          singularity of the matrix (RINOV )   . If the user sets
                                          i
          TOL > 0, then the given value of TOL is used as a
          lower bound for the reciprocal condition number of that
          matrix; a matrix whose estimated condition number is less
          than 1/TOL is considered to be nonsingular. If the user
          sets TOL <= 0, then an implicitly computed, default
          tolerance, defined by TOLDEF = P*P*EPS, is used instead,
          where EPS is the machine precision (see LAPACK Library
          routine DLAMCH).
          Otherwise, TOL is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK),
          where LIWORK = P if JOBK = 'K',
          and   LIWORK = 1 otherwise.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.  If INFO = 0 and JOBK = 'K', DWORK(2) returns
          an estimate of the reciprocal of the condition number
                                     1/2
          (in the 1-norm) of (RINOV )   .
                                   i

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,N*(P+N)+2*P,N*(N+M+2)),     if JOBK = 'N';
          LDWORK >= MAX(2,N*(P+N)+2*P,N*(N+M+2),3*P), if JOBK = 'K'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
                                                     1/2
          = 1:  if JOBK = 'K' and the matrix (RINOV )   is singular,
                                                   i           1/2
                i.e., the condition number estimate of (RINOV )
                                                             i
                (in the 1-norm) exceeds 1/TOL.  The matrices S, AK ,
                            1/2                                   i
                and (RINOV )    have been computed.
                          i
Method 
  The routine performs one recursion of the square root covariance
  filter algorithm, summarized as follows:

   |  1/2                      |     |         1/2          |
   | R      C x S      0       |     | (RINOV )     0     0 |
   |  i      i   i-1           |     |       i              |
   |                      1/2  | T = |                      |
   | 0      A x S    B x Q     |     |     AK       S     0 |
   |         i   i-1  i   i    |     |       i       i      |

       (Pre-array)                      (Post-array)

  where T is an orthogonal transformation triangularizing the
  pre-array.

  The state covariance matrix P    is factorized as
                               i|i-1
     P     = S  S'
      i|i-1   i  i

  and one combined time and measurement update for the state X
                                                              i|i-1
  is given by

     X     = A X      + K (Y - C X     ),
      i+1|i   i i|i-1    i  i   i i|i-1

                       -1/2
  where K = AK (RINOV )     is the Kalman filter gain matrix and Y
         i    i      i                                            i
  is the observed output of the system.

  The triangularization is done entirely via Householder
  transformations exploiting the zero pattern of the pre-array.
References 
  [1] Anderson, B.D.O. and Moore, J.B.
      Optimal Filtering.
      Prentice Hall, Englewood Cliffs, New Jersey, 1979.

  [2] Verhaegen, M.H.G. and Van Dooren, P.
      Numerical Aspects of Different Kalman Filter Implementations.
      IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986.

  [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G.
      Algorithm 675: FORTRAN Subroutines for Computing the Square
      Root Covariance Filter and Square Root Information Filter in
      Dense or Hessenberg Forms.
      ACM Trans. Math. Software, 15, pp. 243-256, 1989.
Numerical Aspects 
  The algorithm requires

        3    2                               2   2
  (7/6)N  + N  x (5/2 x P + M) + N x (1/2 x M + P )

  operations and is backward stable (see [2]).
Further Comments 
  None
Example

Program Text 

*     FB01QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDK, LDQ, LDR, LDS
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDK = NMAX, LDQ = MMAX, LDR = PMAX,
     $                   LDS = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*(PMAX+NMAX)+2*PMAX,
     $                                 NMAX*(NMAX+MMAX+2), 3*PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, ISTEP, J, M, N, P
      CHARACTER*1      JOBK, MULTBQ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DIAG(PMAX), DWORK(LDWORK), K(LDK,PMAX),
     $                 Q(LDQ,MMAX), R(LDR,PMAX), S(LDS,NMAX)
      INTEGER          IWORK(PMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01QD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOBK, TOL, MULTBQ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( LSAME( MULTBQ, 'N' ) ) READ ( NIN, FMT = *)
     $                               ( ( Q(I,J), J = 1,M ), I = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,P ), I = 1,P )
*              Save the strict lower triangle of R in its strict upper
*              triangle and the diagonal in the array DIAG.
               DO 10 I = 2, P
                  CALL DCOPY( I, R(I,1), LDR, R(1,I), 1 )
   10          CONTINUE
               CALL DCOPY( P, R, LDR+1, DIAG, 1 )
*              Perform three iterations of the (Kalman) filter recursion
*              (in square root covariance form).
               ISTEP = 1
   20          CONTINUE
                  CALL 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 )
                  ISTEP = ISTEP + 1
                  IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN
*                    Restore the lower triangle of R.
                     DO 30 I = 2, P
                        CALL DCOPY( I, R(1,I), 1, R(I,1), LDR )
   30                CONTINUE
                     CALL DCOPY( P, DIAG, 1, R, LDR+1 )
                     GO TO 20
                  END IF
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( S(I,J), J = 1,N )
   40             CONTINUE
                  IF ( LSAME( JOBK, 'K' ) ) THEN
                     WRITE ( NOUT, FMT = 99996 )
                     DO 60 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( K(I,J), J = 1,P )
   60                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01QD = ',I2)
99997 FORMAT (' The square root of the state covariance matrix is ')
99996 FORMAT (/' The Kalman gain matrix is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 FB01QD EXAMPLE PROGRAM DATA
   4     2     2     K     0.0     N
   0.0000  0.0000  0.0000  0.0000
   0.0000  0.0000  0.0000  0.0000
   0.0000  0.0000  0.0000  0.0000
   0.0000  0.0000  0.0000  0.0000
   0.2113  0.8497  0.7263  0.8833
   0.7560  0.6857  0.1985  0.6525
   0.0002  0.8782  0.5442  0.3076
   0.3303  0.0683  0.2320  0.9329
   0.5618  0.5042
   0.5896  0.3493
   0.6853  0.3873
   0.8906  0.9222
   1.0000  0.0000
   0.0000  1.0000
   0.3616  0.5664  0.5015  0.2693
   0.2922  0.4826  0.4368  0.6325
   0.9488  0.0000
   0.3760  0.7340
Program Results 
 FB01QD EXAMPLE PROGRAM RESULTS

 The square root of the state covariance matrix is 
  -1.2936   0.0000   0.0000   0.0000
  -1.1382  -0.2579   0.0000   0.0000
  -0.9622  -0.1529   0.2974   0.0000
  -1.3076   0.0936   0.4508  -0.4897

 The Kalman gain matrix is 
   0.3638   0.9469
   0.3532   0.8179
   0.2471   0.5542
   0.1982   0.6471

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/FB01RD.html000077500000000000000000000433571201767322700160760ustar00rootroot00000000000000 FB01RD - SLICOT Library Routine Documentation

FB01RD

Time-invariant square root covariance Kalman filter (observer Hessenberg form)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate a combined measurement and time update of one
  iteration of the time-invariant Kalman filter. This update is
  given for the square root covariance filter, using the condensed
  observer Hessenberg form.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOBK    CHARACTER*1
          Indicates whether the user wishes to compute the Kalman
          filter gain matrix K  as follows:
                              i
          = 'K':  K  is computed and stored in array K;
                   i
          = 'N':  K  is not required.
                   i

  MULTBQ  CHARACTER*1                    1/2
          Indicates how matrices B  and Q    are to be passed to
                                  i      i
          the routine as follows:
          = 'P':  Array Q is not used and the array B must contain
                                 1/2
                  the product B Q   ;
                               i i
          = 'N':  Arrays B and Q must contain the matrices as
                  described below.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e., the order of the
          matrices S    and A.  N >= 0.
                    i-1

  M       (input) INTEGER
          The actual input dimension, i.e., the order of the matrix
           1/2
          Q   .  M >= 0.
           i

  P       (input) INTEGER
          The actual output dimension, i.e., the order of the matrix
           1/2
          R   .  P >= 0.
           i

  S       (input/output) DOUBLE PRECISION array, dimension (LDS,N)
          On entry, the leading N-by-N lower triangular part of this
          array must contain S   , the square root (left Cholesky
                              i-1
          factor) of the state covariance matrix at instant (i-1).
          On exit, the leading N-by-N lower triangular part of this
          array contains S , the square root (left Cholesky factor)
                          i
          of the state covariance matrix at instant i.
          The strict upper triangular part of this array is not
          referenced.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,N).

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain A,
          the state transition matrix of the discrete system in
          lower observer Hessenberg form (e.g., as produced by
          SLICOT Library Routine TB01ND).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain B ,
                                                     1/2      i
          the input weight matrix (or the product B Q    if
                                                   i i
          MULTBQ = 'P') of the discrete system at instant i.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,*)
          If MULTBQ = 'N', then the leading M-by-M lower triangular
                                           1/2
          part of this array must contain Q   , the square root
                                           i
          (left Cholesky factor) of the input (process) noise
          covariance matrix at instant i.
          The strict upper triangular part of this array is not
          referenced.
          Otherwise, Q is not referenced and can be supplied as a
          dummy array (i.e., set parameter LDQ = 1 and declare this
          array to be Q(1,1) in the calling program).

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= MAX(1,M) if MULTBQ = 'N';
          LDQ >= 1        if MULTBQ = 'P'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain C,
          the output weight matrix of the discrete system in lower
          observer Hessenberg form (e.g., as produced by SLICOT
          Library routine TB01ND).

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,P)
          On entry, the leading P-by-P lower triangular part of this
                              1/2
          array must contain R   , the square root (left Cholesky
                              i
          factor) of the output (measurement) noise covariance
          matrix at instant i.
          On exit, the leading P-by-P lower triangular part of this
                                 1/2
          array contains (RINOV )   , the square root (left Cholesky
                               i
          factor) of the covariance matrix of the innovations at
          instant i.
          The strict upper triangular part of this array is not
          referenced.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,P).

  K       (output) DOUBLE PRECISION array, dimension (LDK,P)
          If JOBK = 'K', and INFO = 0, then the leading N-by-P part
          of this array contains K , the Kalman filter gain matrix
                                  i
          at instant i.
          If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the
          leading N-by-P part of this array contains AK ,  a matrix
                                                       i
          related to the Kalman filter gain matrix at instant i (see
                                                         -1/2
          METHOD). Specifically, AK  = A P     C'(RINOV')    .
                                   i      i|i-1        i

  LDK     INTEGER
          The leading dimension of array K.  LDK >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          If JOBK = 'K', then TOL is used to test for near
                                            1/2
          singularity of the matrix (RINOV )   . If the user sets
                                          i
          TOL > 0, then the given value of TOL is used as a
          lower bound for the reciprocal condition number of that
          matrix; a matrix whose estimated condition number is less
          than 1/TOL is considered to be nonsingular. If the user
          sets TOL <= 0, then an implicitly computed, default
          tolerance, defined by TOLDEF = P*P*EPS, is used instead,
          where EPS is the machine precision (see LAPACK Library
          routine DLAMCH).
          Otherwise, TOL is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          where LIWORK = P if JOBK = 'K',
          and   LIWORK = 1 otherwise.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.  If INFO = 0 and JOBK = 'K', DWORK(2) returns
          an estimate of the reciprocal of the condition number
                                     1/2
          (in the 1-norm) of (RINOV )   .
                                   i

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2)),
                        if JOBK = 'N';
          LDWORK >= MAX(2,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2),3*P),
                        if JOBK = 'K'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
                                                     1/2
          = 1:  if JOBK = 'K' and the matrix (RINOV )   is singular,
                                                   i           1/2
                i.e., the condition number estimate of (RINOV )
                                                             i
                (in the 1-norm) exceeds 1/TOL.  The matrices S, AK ,
                            1/2                                   i
                and (RINOV )    have been computed.
                          i
Method 
  The routine performs one recursion of the square root covariance
  filter algorithm, summarized as follows:

   |  1/2                     |     |         1/2          |
   | R      0        C x S    |     | (RINOV )     0     0 |
   |  i                   i-1 |     |       i              |
   |             1/2          | T = |                      |
   | 0      B x Q    A x S    |     |     AK       S     0 |
   |         i   i        i-1 |     |       i       i      |

        (Pre-array)                      (Post-array)

  where T is unitary and (A,C) is in lower observer Hessenberg form.

  An example of the pre-array is given below (where N = 6, P = 2
  and M = 3):

       |x   |      | x          |
       |x x |      | x x        |
       |____|______|____________|
       |    | x x x| x x x      |
       |    | x x x| x x x x    |
       |    | x x x| x x x x x  |
       |    | x x x| x x x x x x|
       |    | x x x| x x x x x x|
       |    | x x x| x x x x x x|

  The corresponding state covariance matrix P      is then
                                             i|i-1
  factorized as

      P     = S  S'
       i|i-1   i  i

  and one combined time and measurement update for the state X
                                                              i|i-1
  is given by

      X     = A X      + K (Y - C X     )
       i+1|i     i|i-1    i  i     i|i-1

                       -1/2
  where K = AK (RINOV )     is the Kalman filter gain matrix and Y
         i    i      i                                            i
  is the observed output of the system.

  The triangularization is done entirely via Householder
  transformations exploiting the zero pattern of the pre-array.
References 
  [1] Anderson, B.D.O. and Moore, J.B.
      Optimal Filtering.
      Prentice Hall, Englewood Cliffs, New Jersey, 1979.

  [2] Van Dooren, P. and Verhaegen, M.H.G.
      Condensed Forms for Efficient Time-Invariant Kalman Filtering.
      SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988.

  [3] Verhaegen, M.H.G. and Van Dooren, P.
      Numerical Aspects of Different Kalman Filter Implementations.
      IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986.

  [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G.
      Algorithm 675: FORTRAN Subroutines for Computing the Square
      Root Covariance Filter and Square Root Information Filter in
      Dense or Hessenberg Forms.
      ACM Trans. Math. Software, 15, pp. 243-256, 1989.
Numerical Aspects 
  The algorithm requires

         3    2                           2         3
  1/6 x N  + N x (3/2 x P + M) + 2 x N x P + 2/3 x P

  operations and is backward stable (see [3]).
Further Comments 
  None
Example

Program Text 

*     FB01RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDK, LDQ, LDR, LDS
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDK = NMAX,
     $                   LDQ = MMAX, LDR = PMAX, LDS = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*(PMAX+NMAX+1),
     $                                 NMAX*(PMAX+NMAX)+2*PMAX,
     $                                 NMAX*(NMAX+MMAX+2), 3*PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, ISTEP, J, M, N, P
      CHARACTER*1      JOBK, MULTBQ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DIAG(PMAX), DWORK(LDWORK), K(LDK,PMAX),
     $                 Q(LDQ,MMAX), R(LDR,PMAX), S(LDS,NMAX)
      INTEGER          IWORK(PMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOBK, TOL, MULTBQ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( LSAME( MULTBQ, 'N' ) ) READ ( NIN, FMT = * )
     $                               ( ( Q(I,J), J = 1,M ), I = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,P ), I = 1,P )
*              Save the strict lower triangle of R in its strict upper
*              triangle and the diagonal in the array DIAG.
               DO 10 I = 2, P
                  CALL DCOPY( I, R(I,1), LDR, R(1,I), 1 )
   10          CONTINUE
               CALL DCOPY( P, R, LDR+1, DIAG, 1 )
*              Perform three iterations of the (Kalman) filter recursion
*              (in square root covariance form).
               ISTEP = 1
   20          CONTINUE
                  CALL 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 )
                  ISTEP = ISTEP + 1
                  IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN
*                    Restore the lower triangle of R.
                     DO 30 I = 2, P
                        CALL DCOPY( I, R(1,I), 1, R(I,1), LDR )
   30                CONTINUE
                     CALL DCOPY( P, DIAG, 1, R, LDR+1 )
                     GO TO 20
                  END IF
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( S(I,J), J = 1,N )
   40             CONTINUE
                  IF ( LSAME( JOBK, 'K' ) ) THEN
                     WRITE ( NOUT, FMT = 99996 )
                     DO 60 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( K(I,J), J = 1,P )
   60                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01QD = ',I2)
99997 FORMAT (' The square root of the state covariance matrix is ')
99996 FORMAT (/' The Kalman gain matrix is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 FB01RD EXAMPLE PROGRAM DATA
   4     2     2     K     0.0     N
   0.0000  0.0000  0.0000  0.0000
   0.0000  0.0000  0.0000  0.0000
   0.0000  0.0000  0.0000  0.0000
   0.0000  0.0000  0.0000  0.0000
   0.2113  0.8497  0.7263  0.0000
   0.7560  0.6857  0.1985  0.6525
   0.0002  0.8782  0.5442  0.3076
   0.3303  0.0683  0.2320  0.9329
   0.5618  0.5042
   0.5896  0.3493
   0.6853  0.3873
   0.8906  0.9222
   1.0000  0.0000
   0.0000  1.0000
   0.3616  0.0000  0.0000  0.0000
   0.2922  0.4826  0.0000  0.0000
   0.9488  0.0000
   0.3760  0.7340
Program Results 
 FB01RD EXAMPLE PROGRAM RESULTS

 The square root of the state covariance matrix is 
  -1.7223   0.0000   0.0000   0.0000
  -2.1073   0.5467   0.0000   0.0000
  -1.7649   0.1412  -0.1710   0.0000
  -1.8291   0.2058  -0.1497   0.7760

 The Kalman gain matrix is 
  -0.2135   1.6649
  -0.2345   2.1442
  -0.2147   1.7069
  -0.1345   1.4777

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/FB01SD.html000077500000000000000000000502151201767322700160660ustar00rootroot00000000000000 FB01SD - SLICOT Library Routine Documentation

FB01SD

Time-varying square root information Kalman filter (dense matrices)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate a combined measurement and time update of one
  iteration of the time-varying Kalman filter. This update is given
  for the square root information filter, using dense matrices.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOBX    CHARACTER*1
          Indicates whether X    is to be computed as follows:
                             i+1
          = 'X':  X    is computed and stored in array X;
                   i+1
          = 'N':  X    is not required.
                   i+1

  MULTAB  CHARACTER*1             -1
          Indicates how matrices A   and B  are to be passed to
                                  i       i
          the routine as follows:                       -1
          = 'P':  Array AINV must contain the matrix   A    and the
                                                    -1  i
                  array B must contain the product A  B ;
                                                    i  i
          = 'N':  Arrays AINV and B must contain the matrices
                  as described below.

  MULTRC  CHARACTER*1             -1/2
          Indicates how matrices R     and C    are to be passed to
                                  i+1       i+1
          the routine as follows:
          = 'P':  Array RINV is not used and the array C must
                                       -1/2
                  contain the product R    C   ;
                                       i+1  i+1
          = 'N':  Arrays RINV and C must contain the matrices
                  as described below.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e., the order of the
                    -1      -1
          matrices S   and A  .  N >= 0.
                    i       i

  M       (input) INTEGER
          The actual input dimension, i.e., the order of the matrix
           -1/2
          Q    .  M >= 0.
           i

  P       (input) INTEGER
          The actual output dimension, i.e., the order of the matrix
           -1/2
          R    .  P >= 0.
           i+1

  SINV    (input/output) DOUBLE PRECISION array, dimension
          (LDSINV,N)
          On entry, the leading N-by-N upper triangular part of this
                              -1
          array must contain S  , the inverse of the square root
                              i
          (right Cholesky factor) of the state covariance matrix
          P    (hence the information square root) at instant i.
           i|i
          On exit, the leading N-by-N upper triangular part of this
                          -1
          array contains S   , the inverse of the square root (right
                          i+1
          Cholesky factor) of the state covariance matrix P
                                                           i+1|i+1
          (hence the information square root) at instant i+1.
          The strict lower triangular part of this array is not
          referenced.

  LDSINV  INTEGER
          The leading dimension of array SINV.  LDSINV >= MAX(1,N).

  AINV    (input) DOUBLE PRECISION array, dimension (LDAINV,N)
                                                              -1
          The leading N-by-N part of this array must contain A  ,
                                                              i
          the inverse of the state transition matrix of the discrete
          system at instant i.

  LDAINV  INTEGER
          The leading dimension of array AINV.  LDAINV >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain B ,
                                                   -1         i
          the input weight matrix (or the product A  B  if
                                                   i  i
          MULTAB = 'P') of the discrete system at instant i.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  RINV    (input) DOUBLE PRECISION array, dimension (LDRINV,*)
          If MULTRC = 'N', then the leading P-by-P upper triangular
                                           -1/2
          part of this array must contain R    , the inverse of the
                                           i+1
          covariance square root (right Cholesky factor) of the
          output (measurement) noise (hence the information square
          root) at instant i+1.
          The strict lower triangular part of this array is not
          referenced.
          Otherwise, RINV is not referenced and can be supplied as a
          dummy array (i.e., set parameter LDRINV = 1 and declare
          this array to be RINV(1,1) in the calling program).

  LDRINV  INTEGER
          The leading dimension of array RINV.
          LDRINV >= MAX(1,P) if MULTRC = 'N';
          LDRINV >= 1        if MULTRC = 'P'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain C   ,
                                                    -1/2      i+1
          the output weight matrix (or the product R    C    if
                                                    i+1  i+1
          MULTRC = 'P') of the discrete system at instant i+1.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  QINV    (input/output) DOUBLE PRECISION array, dimension
          (LDQINV,M)
          On entry, the leading M-by-M upper triangular part of this
                              -1/2
          array must contain Q    , the inverse of the covariance
                              i
          square root (right Cholesky factor) of the input (process)
          noise (hence the information square root) at instant i.
          On exit, the leading M-by-M upper triangular part of this
                                 -1/2
          array contains (QINOV )    , the inverse of the covariance
                               i
          square root (right Cholesky factor) of the process noise
          innovation (hence the information square root) at
          instant i.
          The strict lower triangular part of this array is not
          referenced.

  LDQINV  INTEGER
          The leading dimension of array QINV.  LDQINV >= MAX(1,M).

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain X , the estimated
                                             i
          filtered state at instant i.
          On exit, if JOBX = 'X', and INFO = 0, then this array
          contains X   , the estimated filtered state at
                    i+1
          instant i+1.
          On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then
                               -1
          this array contains S   X   .
                               i+1 i+1

  RINVY   (input) DOUBLE PRECISION array, dimension (P)
                                   -1/2
          This array must contain R    Y   , the product of the
                                   i+1  i+1
                                   -1/2
          upper triangular matrix R     and the measured output
                                   i+1
          vector Y    at instant i+1.
                  i+1

  Z       (input) DOUBLE PRECISION array, dimension (M)
          This array must contain Z , the mean value of the state
                                   i
          process noise at instant i.

  E       (output) DOUBLE PRECISION array, dimension (P)
          This array contains E   , the estimated error at instant
                               i+1
          i+1.
Tolerances 
  TOL     DOUBLE PRECISION
          If JOBX = 'X', then TOL is used to test for near
                                     -1
          singularity of the matrix S   . If the user sets
                                     i+1
          TOL > 0, then the given value of TOL is used as a
          lower bound for the reciprocal condition number of that
          matrix; a matrix whose estimated condition number is less
          than 1/TOL is considered to be nonsingular. If the user
          sets TOL <= 0, then an implicitly computed, default
          tolerance, defined by TOLDEF = N*N*EPS, is used instead,
          where EPS is the machine precision (see LAPACK Library
          routine DLAMCH).
          Otherwise, TOL is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          where LIWORK = N if JOBX = 'X',
          and   LIWORK = 1 otherwise.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.  If INFO = 0 and JOBX = 'X', DWORK(2) returns
          an estimate of the reciprocal of the condition number
                              -1
          (in the 1-norm) of S   .
                              i+1

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N),
                        if JOBX = 'N';
          LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N,3*N),
                        if JOBX = 'X'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;                        -1
          = 1:  if JOBX = 'X' and the matrix S   is singular,
                                              i+1       -1
                i.e., the condition number estimate of S    (in the
                                                        i+1
                                                      -1    -1/2
                1-norm) exceeds 1/TOL.  The matrices S   , Q
                                                      i+1   i
                and E have been computed.
Method 
  The routine performs one recursion of the square root information
  filter algorithm, summarized as follows:

    |    -1/2             -1/2    |     |         -1/2             |
    |   Q         0      Q    Z   |     | (QINOV )     *     *     |
    |    i                i    i  |     |       i                  |
    |                             |     |                          |
    |  -1 -1     -1 -1    -1      |     |             -1    -1     |
  T | S  A  B   S  A     S  X     |  =  |    0       S     S   X   |
    |  i  i  i   i  i     i  i    |     |             i+1   i+1 i+1|
    |                             |     |                          |
    |           -1/2      -1/2    |     |                          |
    |    0     R    C    R    Y   |     |    0         0     E     |
    |           i+1  i+1  i+1  i+1|     |                     i+1  |

               (Pre-array)                      (Post-array)

  where T is an orthogonal transformation triangularizing the
                     -1/2
  pre-array, (QINOV )     is the inverse of the covariance square
                   i
  root (right Cholesky factor) of the process noise innovation
  (hence the information square root) at instant i, and E    is the
                                                         i+1
  estimated error at instant i+1.

  The inverse of the corresponding state covariance matrix P
                                                            i+1|i+1
  (hence the information matrix I) is then factorized as

                -1         -1     -1
     I       = P       = (S   )' S
      i+1|i+1   i+1|i+1    i+1    i+1

  and one combined time and measurement update for the state is
  given by X   .
            i+1

  The triangularization is done entirely via Householder
  transformations exploiting the zero pattern of the pre-array.
References 
  [1] Anderson, B.D.O. and Moore, J.B.
      Optimal Filtering.
      Prentice Hall, Englewood Cliffs, New Jersey, 1979.

  [2] Verhaegen, M.H.G. and Van Dooren, P.
      Numerical Aspects of Different Kalman Filter Implementations.
      IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986.

  [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G.
      Algorithm 675: FORTRAN Subroutines for Computing the Square
      Root Covariance Filter and Square Root Information Filter in
      Dense or Hessenberg Forms.
      ACM Trans. Math. Software, 15, pp. 243-256, 1989.
Numerical Aspects 
  The algorithm requires approximately

        3    2                              2   2
  (7/6)N  + N x (7/2 x M + P) + N x (1/2 x P + M )

  operations and is backward stable (see [2]).
Further Comments 
  None
Example

Program Text 

*     FB01SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV
      PARAMETER        ( LDAINV = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDQINV = MMAX, LDRINV = PMAX, LDSINV = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*(NMAX + 2*MMAX) + 3*MMAX,
     $                                (NMAX + PMAX)*(NMAX + 1) + 2*NMAX,
     $                                 3*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, ISTEP, J, M, N, P
      CHARACTER*1      JOBX, MULTAB, MULTRC
*     .. Local Arrays ..
      DOUBLE PRECISION AINV(LDAINV,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DIAG(MMAX), DWORK(LDWORK), E(PMAX),
     $                 QINV(LDQINV,MMAX), RINV(LDRINV,PMAX),
     $                 RINVY(PMAX), SINV(LDSINV,NMAX), X(NMAX), Z(MMAX)
      INTEGER          IWORK(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01SD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOBX, TOL, MULTAB, MULTRC
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( AINV(I,J), J = 1,N ), I = 1,N )
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) P
         ELSE
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
            IF ( LSAME( MULTRC, 'N' ) ) READ ( NIN, FMT = * )
     $                               ( ( RINV(I,J), J = 1,P ), I = 1,P )
            IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
               READ ( NIN, FMT = * ) ( ( QINV(I,J), J = 1,M ), I = 1,M )
               READ ( NIN, FMT = * ) ( ( SINV(I,J), J = 1,N ), I = 1,N )
               READ ( NIN, FMT = * ) ( Z(J), J = 1,M )
               READ ( NIN, FMT = * ) ( X(J), J = 1,N )
               READ ( NIN, FMT = * ) ( RINVY(J), J = 1,P )
*              Save the strict upper triangle of QINV in its strict
*              lower triangle and the diagonal in the array DIAG.
               DO 10 I = 2, M
                  CALL DCOPY( I, QINV(1,I), 1, QINV(I,1), LDQINV )
   10          CONTINUE
               CALL DCOPY( M, QINV, LDQINV+1, DIAG, 1 )
*              Perform three iterations of the (Kalman) filter recursion
*              (in square root information form).
               ISTEP = 1
   20          CONTINUE
                  CALL 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 )
                  ISTEP = ISTEP + 1
                  IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN
*                    Restore the upper triangle of QINV.
                     DO 30 I = 2, M
                        CALL DCOPY( I, QINV(I,1), LDQINV, QINV(1,I), 1 )
   30                CONTINUE
                     CALL DCOPY( M, DIAG, 1, QINV, LDQINV+1 )
                     GO TO 20
                  END IF
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( SINV(I,J), J = 1,N )
   40             CONTINUE
                  IF ( LSAME( JOBX, 'X' ) ) THEN
                     WRITE ( NOUT, FMT = 99995 )
                     DO 50 I = 1, N
                        WRITE ( NOUT, FMT = 99994 ) I, X(I)
   50                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01SD = ',I2)
99997 FORMAT (' The inverse of the square root of the state covariance',
     $       ' matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The components of the estimated filtered state are ',
     $       //'   k       X(k)',/)
99994 FORMAT (I4,3X,F8.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 FB01SD EXAMPLE PROGRAM DATA
   4     2     2     X     0.0     P     N
   0.2113  0.7560  0.0002  0.3303
   0.8497  0.6857  0.8782  0.0683
   0.7263  0.1985  0.5442  0.2320
   0.8833  0.6525  0.3076  0.9329
   0.3616  0.5664  0.5015  0.2693
   0.2922  0.4826  0.4368  0.6325
   1.0000  0.0000
   0.0000  1.0000
  -0.8805  1.3257
   2.1039  0.5207
  -0.6075  1.0386
  -0.8531  1.1688
   1.1159  0.2305
   0.0000  0.6597
   1.0000  0.0000  0.0000  0.0000
   0.0000  1.0000  0.0000  0.0000
   0.0000  0.0000  1.0000  0.0000
   0.0000  0.0000  0.0000  1.0000
   0.0019
   0.5075
   0.4076
   0.8408
   0.5017
   0.9128
   0.2129
   0.5591
Program Results 
 FB01SD EXAMPLE PROGRAM RESULTS

 The inverse of the square root of the state covariance matrix is 
   0.6897   0.7721   0.7079   0.6102
   0.0000  -0.3363  -0.2252  -0.2642
   0.0000   0.0000  -0.1650   0.0319
   0.0000   0.0000   0.0000   0.3708

 The components of the estimated filtered state are 

   k       X(k)

   1    -0.7125
   2    -1.8324
   3     1.7500
   4     1.5854

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/FB01TD.html000077500000000000000000000507461201767322700161000ustar00rootroot00000000000000 FB01TD - SLICOT Library Routine Documentation

FB01TD

Time-invariant square root information Kalman filter (controller Hessenberg form)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate a combined measurement and time update of one
  iteration of the time-invariant Kalman filter. This update is
  given for the square root information filter, using the condensed
  controller Hessenberg form.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOBX    CHARACTER*1
          Indicates whether X    is to be computed as follows:
                             i+1
          = 'X':  X    is computed and stored in array X;
                   i+1
          = 'N':  X    is not required.
                   i+1

  MULTRC  CHARACTER*1             -1/2
          Indicates how matrices R     and C    are to be passed to
                                  i+1       i+1
          the routine as follows:
          = 'P':  Array RINV is not used and the array C must
                                       -1/2
                  contain the product R    C   ;
                                       i+1  i+1
          = 'N':  Arrays RINV and C must contain the matrices
                  as described below.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e., the order of the
                    -1      -1
          matrices S   and A  .  N >= 0.
                    i

  M       (input) INTEGER
          The actual input dimension, i.e., the order of the matrix
           -1/2
          Q    .  M >= 0.
           i

  P       (input) INTEGER
          The actual output dimension, i.e., the order of the matrix
           -1/2
          R    .  P >= 0.
           i+1

  SINV    (input/output) DOUBLE PRECISION array, dimension
          (LDSINV,N)
          On entry, the leading N-by-N upper triangular part of this
                              -1
          array must contain S  , the inverse of the square root
                              i
          (right Cholesky factor) of the state covariance matrix
          P    (hence the information square root) at instant i.
           i|i
          On exit, the leading N-by-N upper triangular part of this
                          -1
          array contains S   , the inverse of the square root (right
                          i+1
          Cholesky factor) of the state covariance matrix P
                                                           i+1|i+1
          (hence the information square root) at instant i+1.
          The strict lower triangular part of this array is not
          referenced.

  LDSINV  INTEGER
          The leading dimension of array SINV.  LDSINV >= MAX(1,N).

  AINV    (input) DOUBLE PRECISION array, dimension (LDAINV,N)
                                                              -1
          The leading N-by-N part of this array must contain A  ,
          the inverse of the state transition matrix of the discrete
          system in controller Hessenberg form (e.g., as produced by
          SLICOT Library Routine TB01MD).

  LDAINV  INTEGER
          The leading dimension of array AINV.  LDAINV >= MAX(1,N).

  AINVB   (input) DOUBLE PRECISION array, dimension (LDAINB,M)
                                                               -1
          The leading N-by-M part of this array must contain  A  B,
                          -1
          the product of A   and the input weight matrix B of the
          discrete system, in upper controller Hessenberg form
          (e.g., as produced by SLICOT Library Routine TB01MD).

  LDAINB  INTEGER
          The leading dimension of array AINVB.  LDAINB >= MAX(1,N).

  RINV    (input) DOUBLE PRECISION array, dimension (LDRINV,*)
          If MULTRC = 'N', then the leading P-by-P upper triangular
                                           -1/2
          part of this array must contain R    , the inverse of the
                                           i+1
          covariance square root (right Cholesky factor) of the
          output (measurement) noise (hence the information square
          root) at instant i+1.
          The strict lower triangular part of this array is not
          referenced.
          Otherwise, RINV is not referenced and can be supplied as a
          dummy array (i.e., set parameter LDRINV = 1 and declare
          this array to be RINV(1,1) in the calling program).

  LDRINV  INTEGER
          The leading dimension of array RINV.
          LDRINV >= MAX(1,P) if MULTRC = 'N';
          LDRINV >= 1        if MULTRC = 'P'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain C   ,
                                                    -1/2      i+1
          the output weight matrix (or the product R    C    if
                                                    i+1  i+1
          MULTRC = 'P') of the discrete system at instant i+1.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  QINV    (input/output) DOUBLE PRECISION array, dimension
          (LDQINV,M)
          On entry, the leading M-by-M upper triangular part of this
                              -1/2
          array must contain Q    , the inverse of the covariance
                              i
          square root (right Cholesky factor) of the input (process)
          noise (hence the information square root) at instant i.
          On exit, the leading M-by-M upper triangular part of this
                                 -1/2
          array contains (QINOV )    , the inverse of the covariance
                               i
          square root (right Cholesky factor) of the process noise
          innovation (hence the information square root) at
          instant i.
          The strict lower triangular part of this array is not
          referenced.

  LDQINV  INTEGER
          The leading dimension of array QINV.  LDQINV >= MAX(1,M).

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain X , the estimated
                                             i
          filtered state at instant i.
          On exit, if JOBX = 'X', and INFO = 0, then this array
          contains X   , the estimated filtered state at
                    i+1
          instant i+1.
          On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then
                               -1
          this array contains S   X   .
                               i+1 i+1

  RINVY   (input) DOUBLE PRECISION array, dimension (P)
                                   -1/2
          This array must contain R    Y   , the product of the
                                   i+1  i+1
                                   -1/2
          upper triangular matrix R     and the measured output
                                   i+1
          vector Y    at instant i+1.
                  i+1

  Z       (input) DOUBLE PRECISION array, dimension (M)
          This array must contain Z , the mean value of the state
                                   i
          process noise at instant i.

  E       (output) DOUBLE PRECISION array, dimension (P)
          This array contains E   , the estimated error at instant
                               i+1
          i+1.
Tolerances 
  TOL     DOUBLE PRECISION
          If JOBX = 'X', then TOL is used to test for near
                                     -1
          singularity of the matrix S   . If the user sets
                                     i+1
          TOL > 0, then the given value of TOL is used as a
          lower bound for the reciprocal condition number of that
          matrix; a matrix whose estimated condition number is less
          than 1/TOL is considered to be nonsingular. If the user
          sets TOL <= 0, then an implicitly computed, default
          tolerance, defined by TOLDEF = N*N*EPS, is used instead,
          where EPS is the machine precision (see LAPACK Library
          routine DLAMCH).
          Otherwise, TOL is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          where LIWORK = N if JOBX = 'X',
          and   LIWORK = 1 otherwise.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.  If INFO = 0 and JOBX = 'X', DWORK(2) returns
          an estimate of the reciprocal of the condition number
                              -1
          (in the 1-norm) of S   .
                              i+1

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)),
                              if JOBX = 'N';
          LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1),
                        3*N), if JOBX = 'X'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;                        -1
          = 1:  if JOBX = 'X' and the matrix S    is singular,
                                              i+1       -1
                i.e., the condition number estimate of S    (in the
                                                        i+1
                                                      -1    -1/2
                1-norm) exceeds 1/TOL.  The matrices S   , Q
                                                      i+1   i
                and E have been computed.
Method 
  The routine performs one recursion of the square root information
  filter algorithm, summarized as follows:

    |    -1/2             -1/2    |     |         -1/2             |
    |   Q         0      Q    Z   |     | (QINOV )     *     *     |
    |    i                i    i  |     |       i                  |
    |                             |     |                          |
    |           -1/2      -1/2    |     |             -1    -1     |
  T |    0     R    C    R    Y   |  =  |    0       S     S   X   |
    |           i+1  i+1  i+1  i+1|     |             i+1   i+1 i+1|
    |                             |     |                          |
    |  -1 -1     -1 -1    -1      |     |                          |
    | S  A  B   S  A     S  X     |     |    0         0     E     |
    |  i         i        i  i    |     |                     i+1  |

                (Pre-array)                      (Post-array)

  where T is an orthogonal transformation triangularizing the
                     -1/2
  pre-array, (QINOV )     is the inverse of the covariance square
                   i
  root (right Cholesky factor) of the process noise innovation
                                                         -1  -1
  (hence the information square root) at instant i and (A  ,A  B) is
  in upper controller Hessenberg form.

  An example of the pre-array is given below (where N = 6, M = 2,
  and P = 3):

      |x x |             | x|
      |  x |             | x|
      _______________________
      |    | x x x x x x | x|
      |    | x x x x x x | x|
      |    | x x x x x x | x|
      _______________________
      |x x | x x x x x x | x|
      |  x | x x x x x x | x|
      |    | x x x x x x | x|
      |    |   x x x x x | x|
      |    |     x x x x | x|
      |    |       x x x | x|

  The inverse of the corresponding state covariance matrix P
                                                            i+1|i+1
  (hence the information matrix I) is then factorized as

                 -1         -1     -1
      I       = P       = (S   )' S
       i+1|i+1   i+1|i+1    i+1    i+1

  and one combined time and measurement update for the state is
  given by X   .
            i+1

  The triangularization is done entirely via Householder
  transformations exploiting the zero pattern of the pre-array.
References 
  [1] Anderson, B.D.O. and Moore, J.B.
      Optimal Filtering.
      Prentice Hall, Englewood Cliffs, New Jersey, 1979.

  [2] Van Dooren, P. and Verhaegen, M.H.G.
      Condensed Forms for Efficient Time-Invariant Kalman Filtering.
      SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988.

  [3] Verhaegen, M.H.G. and Van Dooren, P.
      Numerical Aspects of Different Kalman Filter Implementations.
      IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986.

  [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G.
      Algorithm 675: FORTRAN Subroutines for Computing the Square
      Root Covariance Filter and Square Root Information Filter in
      Dense or Hessenberg Forms.
      ACM Trans. Math. Software, 15, pp. 243-256, 1989.
Numerical Aspects 
  The algorithm requires approximately

        3    2                           2          3
  (1/6)N  + N x (3/2 x M + P) + 2 x N x M  + 2/3 x M

  operations and is backward stable (see [3]).
Further Comments 
  None
Example

Program Text 

*     FB01TD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDAINB, LDAINV, LDC, LDQINV, LDRINV, LDSINV
      PARAMETER        ( LDAINB = NMAX, LDAINV = NMAX, LDC = PMAX,
     $                   LDQINV = MMAX, LDRINV = PMAX, LDSINV = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*(NMAX + 2*MMAX) + 3*MMAX,
     $                                (NMAX + PMAX)*(NMAX + 1) + NMAX +
     $                                 MAX( NMAX - 1, MMAX + 1 ),
     $                                 3*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, ISTEP, J, M, N, P
      CHARACTER*1      JOBX, MULTRC
*     .. Local Arrays ..
      DOUBLE PRECISION AINV(LDAINV,NMAX), AINVB(LDAINB,MMAX),
     $                 C(LDC,NMAX), DIAG(MMAX), DWORK(LDWORK), E(PMAX),
     $                 QINV(LDQINV,MMAX), RINV(LDRINV,PMAX),
     $                 RINVY(PMAX), SINV(LDSINV,NMAX), X(NMAX), Z(MMAX)
      INTEGER          IWORK(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01TD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOBX, TOL, MULTRC
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( AINV(I,J), J = 1,N ), I = 1,N )
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) P
         ELSE
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
            IF ( LSAME( MULTRC, 'N' ) ) READ ( NIN, FMT = * )
     $                         ( ( RINV(I,J), J = 1,P ), I = 1,P )
            IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) M
            ELSE
               READ ( NIN, FMT = * )
     $                              ( ( AINVB(I,J), J = 1,M ), I = 1,N )
               READ ( NIN, FMT = * ) ( ( QINV(I,J), J = 1,M ), I = 1,M )
               READ ( NIN, FMT = * ) ( ( SINV(I,J), J = 1,N ), I = 1,N )
               READ ( NIN, FMT = * ) ( Z(J), J = 1,M )
               READ ( NIN, FMT = * ) ( X(J), J = 1,N )
               READ ( NIN, FMT = * ) ( RINVY(J), J = 1,P )
*              Save the strict upper triangle of QINV in its strict
*              lower triangle and the diagonal in the array DIAG.
               DO 10 I = 2, M
                  CALL DCOPY( I, QINV(1,I), 1, QINV(I,1), LDQINV )
   10          CONTINUE
               CALL DCOPY( M, QINV, LDQINV+1, DIAG, 1 )
*              Perform three iterations of the (Kalman) filter
*              recursion (in square root information form).
               ISTEP = 1
   20          CONTINUE
                  CALL 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 )
                  ISTEP = ISTEP + 1
                  IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN
*                    Restore the upper triangle of QINV.
                     DO 30 I = 2, M
                        CALL DCOPY( I, QINV(I,1), LDQINV, QINV(1,I), 1 )
   30                CONTINUE
                     CALL DCOPY( M, DIAG, 1, QINV, LDQINV+1 )
                     GO TO 20
                  END IF
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( SINV(I,J), J = 1,N )
   40             CONTINUE
                  IF ( LSAME( JOBX, 'X' ) ) THEN
                     WRITE ( NOUT, FMT = 99995 )
                     DO 50 I = 1, N
                        WRITE ( NOUT, FMT = 99994 ) I, X(I)
   50                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01TD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01TD = ',I2)
99997 FORMAT (' The inverse of the square root of the state covariance',
     $       ' matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The components of the estimated filtered state are ',
     $       //'   k       X(k)',/)
99994 FORMAT (I4,3X,F8.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 FB01TD EXAMPLE PROGRAM DATA
   4     2     2     X     0.0     N
   0.2113  0.7560  0.0002  0.3303
   0.8497  0.6857  0.8782  0.0683
   0.7263  0.1985  0.5442  0.2320
   0.0000  0.6525  0.3076  0.9329
   0.3616  0.5664  0.5015  0.2693
   0.2922  0.4826  0.4368  0.6325
   1.0000  0.0000
   0.0000  1.0000
  -0.8805  1.3257
   0.0000  0.5207
   0.0000  0.0000
   0.0000  0.0000
   1.1159  0.2305
   0.0000  0.6597
   1.0000  0.0000  0.0000  0.0000
   0.0000  1.0000  0.0000  0.0000
   0.0000  0.0000  1.0000  0.0000
   0.0000  0.0000  0.0000  1.0000
   0.0019
   0.5075
   0.4076
   0.8408
   0.5017
   0.9128
   0.2129
   0.5591
Program Results 
 FB01TD EXAMPLE PROGRAM RESULTS

 The inverse of the square root of the state covariance matrix is 
  -0.8731  -1.1461  -1.0260  -0.8901
   0.0000  -0.2763  -0.1929  -0.3763
   0.0000   0.0000  -0.1110  -0.1051
   0.0000   0.0000   0.0000   0.3120

 The components of the estimated filtered state are 

   k       X(k)

   1    -2.0688
   2    -0.7814
   3     2.2181
   4     0.9298

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/FB01VD.html000077500000000000000000000322471201767322700160760ustar00rootroot00000000000000 FB01VD - SLICOT Library Routine Documentation

FB01VD

One recursion of the conventional Kalman filter

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute one recursion of the conventional Kalman filter
  equations. This is one update of the Riccati difference equation
  and the Kalman filter gain.
Specification 
      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     .. 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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The actual state dimension, i.e., the order of the
          matrices P      and A .  N >= 0.
                    i|i-1      i

  M       (input) INTEGER
          The actual input dimension, i.e., the order of the matrix
          Q .  M >= 0.
           i

  L       (input) INTEGER
          The actual output dimension, i.e., the order of the matrix
          R .  L >= 0.
           i

  P       (input/output) DOUBLE PRECISION array, dimension (LDP,N)
          On entry, the leading N-by-N part of this array must
          contain P     , the state covariance matrix at instant
                   i|i-1
          (i-1). The upper triangular part only is needed.
          On exit, if INFO = 0, the leading N-by-N part of this
          array contains P     , the state covariance matrix at
                          i+1|i
          instant i. The strictly lower triangular part is not set.
          Otherwise, the leading N-by-N part of this array contains
          P     , its input value.
           i|i-1

  LDP     INTEGER
          The leading dimension of array P.  LDP >= MAX(1,N).

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain A ,
                                                              i
          the state transition matrix of the discrete system at
          instant i.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain B ,
                                                              i
          the input weight matrix of the discrete system at
          instant i.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading L-by-N part of this array must contain C ,
                                                              i
          the output weight matrix of the discrete system at
          instant i.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,L).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,M)
          The leading M-by-M part of this array must contain Q ,
                                                              i
          the input (process) noise covariance matrix at instant i.
          The diagonal elements of this array are modified by the
          routine, but are restored on exit.

  LDQ     INTEGER
          The leading dimension of array Q.  LDQ >= MAX(1,M).

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,L)
          On entry, the leading L-by-L part of this array must
          contain R , the output (measurement) noise covariance
                   i
          matrix at instant i.
          On exit, if INFO = 0, or INFO = L+1, the leading L-by-L
                                                               1/2
          upper triangular part of this array contains (RINOV )   ,
                                                             i
          the square root (left Cholesky factor) of the covariance
          matrix of the innovations at instant i.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,L).

  K       (output) DOUBLE PRECISION array, dimension (LDK,L)
          If INFO = 0, the leading N-by-L part of this array
          contains K , the Kalman filter gain matrix at instant i.
                    i
          If INFO > 0, the leading N-by-L part of this array
          contains the matrix product P     C'.
                                       i|i-1 i

  LDK     INTEGER
          The leading dimension of array K.  LDK >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the matrix RINOV . If the user sets TOL > 0, then the
                          i
          given value of TOL is used as a lower bound for the
          reciprocal condition number of that matrix; a matrix whose
          estimated condition number is less than 1/TOL is
          considered to be nonsingular. If the user sets TOL <= 0,
          then an implicitly computed, default tolerance, defined by
          TOLDEF = L*L*EPS, is used instead, where EPS is the
          machine precision (see LAPACK Library routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (L)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, or INFO = L+1, DWORK(1) returns an
          estimate of the reciprocal of the condition number (in the
          1-norm) of the matrix RINOV .
                                     i

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,L*N+3*L,N*N,N*M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -k, the k-th argument had an illegal
                value;
          = k:  if INFO = k, 1 <= k <= L, the leading minor of order
                k of the matrix RINOV  is not positive-definite, and
                                     i
                its Cholesky factorization could not be completed;
          = L+1: the matrix RINOV  is singular, i.e., the condition
                                 i
                number estimate of RINOV  (in the 1-norm) exceeds
                                        i
                1/TOL.
Method 
  The conventional Kalman filter gain used at the i-th recursion
  step is of the form

                         -1
     K  = P     C'  RINOV  ,
      i    i|i-1 i       i

  where RINOV  = C P     C' + R , and the state covariance matrix
             i    i i|i-1 i    i

  P      is updated by the discrete-time difference Riccati equation
   i|i-1

     P      = A  (P      - K C P     ) A'  + B Q B'.
      i+1|i    i   i|i-1    i i i|i-1   i     i i i

  Using these two updates, the combined time and measurement update
  of the state X      is given by
                i|i-1

     X      = A X      + A K (Y  - C X     ),
      i+1|i    i i|i-1    i i  i    i i|i-1

  where Y  is the new observation at step i.
         i
References 
  [1] Anderson, B.D.O. and Moore, J.B.
      Optimal Filtering,
      Prentice Hall, Englewood Cliffs, New Jersey, 1979.

  [2] Verhaegen, M.H.G. and Van Dooren, P.
      Numerical Aspects of Different Kalman Filter Implementations.
      IEEE Trans. Auto. Contr., AC-31, pp. 907-917, 1986.
Numerical Aspects 
  The algorithm requires approximately

          3   2
   3/2 x N + N  x (3 x L + M/2)

  operations.
Further Comments 
  None
Example

Program Text 

*     FB01VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, LMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, LMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDK, LDP, LDQ, LDR
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = LMAX, LDK = NMAX,
     $                   LDP = NMAX, LDQ = MMAX, LDR = LMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( LMAX*NMAX + 3*LMAX, NMAX*NMAX,
     $                                 MMAX*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, L, M, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), K(LDK,LMAX), P(LDP,NMAX),
     $                 Q(LDQ,MMAX), R(LDR,LMAX)
      INTEGER          IWORK(LMAX)
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01VD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, L, TOL
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( P(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,M ), I = 1,M )
            IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) L
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,L )
               READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,L ), I = 1,L )
*              Perform one iteration of the (Kalman) filter recursion.
               CALL FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC,
     $                      Q, LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK,
     $                      LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, N
                     CALL DCOPY( I-1, P(1,I), 1, P(I,1), LDP )
                     WRITE ( NOUT, FMT = 99994 ) ( P(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( K(I,J), J = 1,L )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 I = 1, L
                     WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1,L )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01VD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01VD = ',I3)
99997 FORMAT (' The state covariance matrix is ')
99996 FORMAT (/' The Kalman filter gain matrix is ')
99995 FORMAT (/' The square root of the covariance matrix of the innov',
     $          'ations is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' L is out of range.',/' P = ',I5)
      END
Program Data 
 FB01VD EXAMPLE PROGRAM DATA
   4     3     2     0.0
   0.5015  0.4368  0.2693  0.6325
   0.4368  0.4818  0.2639  0.4148
   0.2693  0.2639  0.1121  0.6856
   0.6325  0.4148  0.6856  0.8906
   0.2113  0.8497  0.7263  0.8833
   0.7560  0.6857  0.1985  0.6525
   0.0002  0.8782  0.5442  0.3076
   0.3303  0.0683  0.2320  0.9329
   0.0437  0.7783  0.5618
   0.4818  0.2119  0.5896
   0.2639  0.1121  0.6853
   0.4148  0.6856  0.8906
   0.9329  0.2146  0.3126
   0.2146  0.2922  0.5664
   0.3126  0.5664  0.5935
   0.3873  0.9488  0.3760  0.0881
   0.9222  0.3435  0.7340  0.4498
   1.0000  0.0000
   0.0000  1.0000
Program Results 
 FB01VD EXAMPLE PROGRAM RESULTS

 The state covariance matrix is 
   1.6007   1.3283   1.1153   1.7177
   1.3283   1.2763   1.0132   1.5137
   1.1153   1.0132   0.8222   1.2722
   1.7177   1.5137   1.2722   2.1562

 The Kalman filter gain matrix is 
   0.1648   0.2241
   0.2115   0.1610
   0.0728   0.1673
   0.1304   0.3892

 The square root of the covariance matrix of the innovations is 
   1.5091   1.1543
   0.0000   1.5072

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/FD01AD.html000077500000000000000000000344661201767322700160600ustar00rootroot00000000000000 FD01AD - SLICOT Library Routine Documentation

FD01AD

Fast recursive least-squares filtering

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the least-squares filtering problem recursively in time.
  Each subroutine call implements one time update of the solution.
  The algorithm uses a fast QR-decomposition based approach.
Specification 
      SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK,
     $                   CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  JP      CHARACTER*1
          Indicates whether the user wishes to apply both prediction
          and filtering parts, as follows:
          = 'B':  Both prediction and filtering parts are to be
                  applied;
          = 'P':  Only the prediction section is to be applied.
Input/Output Parameters 
  L       (input) INTEGER
          The length of the impulse response of the equivalent
          transversal filter model.  L >= 1.

  LAMBDA  (input) DOUBLE PRECISION
          Square root of the forgetting factor.
          For tracking capabilities and exponentially stable error
          propagation, LAMBDA < 1.0 (strict inequality) should
          be used.  0.0 < LAMBDA <= 1.0.

  XIN     (input) DOUBLE PRECISION
          The input sample at instant n.
          (The situation just before and just after the call of
          the routine are denoted by instant (n-1) and instant n,
          respectively.)

  YIN     (input) DOUBLE PRECISION
          If JP = 'B', then YIN must contain the reference sample
          at instant n.
          Otherwise, YIN is not referenced.

  EFOR    (input/output) DOUBLE PRECISION
          On entry, this parameter must contain the square root of
          exponentially weighted forward prediction error energy
          at instant (n-1).  EFOR >= 0.0.
          On exit, this parameter contains the square root of the
          exponentially weighted forward prediction error energy
          at instant n.

  XF      (input/output) DOUBLE PRECISION array, dimension (L)
          On entry, this array must contain the transformed forward
          prediction variables at instant (n-1).
          On exit, this array contains the transformed forward
          prediction variables at instant n.

  EPSBCK  (input/output) DOUBLE PRECISION array, dimension (L+1)
          On entry, the leading L elements of this array must
          contain the normalized a posteriori backward prediction
          error residuals of orders zero through L-1, respectively,
          at instant (n-1), and EPSBCK(L+1) must contain the
          square-root of the so-called "conversion factor" at
          instant (n-1).
          On exit, this array contains the normalized a posteriori
          backward prediction error residuals, plus the square root
          of the conversion factor at instant n.

  CTETA   (input/output) DOUBLE PRECISION array, dimension (L)
          On entry, this array must contain the cosines of the
          rotation angles used in time updates, at instant (n-1).
          On exit, this array contains the cosines of the rotation
          angles at instant n.

  STETA   (input/output) DOUBLE PRECISION array, dimension (L)
          On entry, this array must contain the sines of the
          rotation angles used in time updates, at instant (n-1).
          On exit, this array contains the sines of the rotation
          angles at instant n.

  YQ      (input/output) DOUBLE PRECISION array, dimension (L)
          On entry, if JP = 'B', then this array must contain the
          orthogonally transformed reference vector at instant
          (n-1). These elements are also the tap multipliers of an
          equivalent normalized lattice least-squares filter.
          Otherwise, YQ is not referenced and can be supplied as
          a dummy array (i.e., declare this array to be YQ(1) in
          the calling program).
          On exit, if JP = 'B', then this array contains the
          orthogonally transformed reference vector at instant n.

  EPOS    (output) DOUBLE PRECISION
          The a posteriori forward prediction error residual.

  EOUT    (output) DOUBLE PRECISION
          If JP = 'B', then EOUT contains the a posteriori output
          error residual from the least-squares filter at instant n.

  SALPH   (output) DOUBLE PRECISION array, dimension (L)
          The element SALPH(i), i=1,...,L, contains the opposite of
          the i-(th) reflection coefficient for the least-squares
          normalized lattice predictor (whose value is -SALPH(i)).
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  an element to be annihilated by a rotation is less
                than the machine precision (see LAPACK Library
                routine DLAMCH).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The output error EOUT at instant n, denoted by EOUT(n), is the
  reference sample minus a linear combination of L successive input
  samples:

                        L-1
     EOUT(n) = YIN(n) - SUM h_i * XIN(n-i),
                        i=0

  where YIN(n) and XIN(n) are the scalar samples at instant n.
  A least-squares filter uses those h_0,...,h_{L-1} which minimize
  an exponentially weighted sum of successive output errors squared:

      n
     SUM [LAMBDA**(2(n-k)) * EOUT(k)**2].
     k=1

  Each subroutine call performs a time update of the least-squares
  filter using a fast least-squares algorithm derived from a
  QR decomposition, as described in references [1] and [2] (the
  notation from [2] is followed in the naming of the arrays).
  The algorithm does not compute the parameters h_0,...,h_{L-1} from
  the above formula, but instead furnishes the parameters of an
  equivalent normalized least-squares lattice filter, which are
  available from the arrays SALPH (reflection coefficients) and YQ
  (tap multipliers), as well as the exponentially weighted input
  signal energy

      n                                              L
     SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2.
     k=1                                            i=1

  For more details on reflection coefficients and tap multipliers,
  references [2] and [4] are recommended.
References 
  [1]  Proudler, I. K., McWhirter, J. G., and Shepherd, T. J.
       Fast QRD based algorithms for least-squares linear
       prediction.
       Proceedings IMA Conf. Mathematics in Signal Processing
       Warwick, UK, December 1988.

  [2]  Regalia, P. A., and Bellanger, M. G.
       On the duality between QR methods and lattice methods in
       least-squares adaptive filtering.
       IEEE Trans. Signal Processing, SP-39, pp. 879-891,
       April 1991.

  [3]  Regalia, P. A.
       Numerical stability properties of a QR-based fast
       least-squares algorithm.
       IEEE Trans. Signal Processing, SP-41, June 1993.

  [4]  Lev-Ari, H., Kailath, T., and Cioffi, J.
       Least-squares adaptive lattice and transversal filters:
       A unified geometric theory.
       IEEE Trans. Information Theory, IT-30, pp. 222-236,
       March 1984.
Numerical Aspects 
  The algorithm requires O(L) operations for each subroutine call.
  It is backward consistent for all input sequences XIN, and
  backward stable for persistently exciting input sequences,
  assuming LAMBDA < 1.0 (see [3]).
  If the condition of the signal is very poor (IWARN = 1), then the
  results are not guaranteed to be reliable.
Further Comments 
  1.  For tracking capabilities and exponentially stable error
      propagation, LAMBDA < 1.0 should be used.  LAMBDA is typically
      chosen slightly less than 1.0 so that "past" data are
      exponentially forgotten.
  2.  Prior to the first subroutine call, the variables must be
      initialized. The following initial values are recommended:

      XF(i) = 0.0,        i=1,...,L
      EPSBCK(i) = 0.0     i=1,...,L
      EPSBCK(L+1) = 1.0
      CTETA(i) = 1.0      i=1,...,L
      STETA(i) = 0.0      i=1,...,L
      YQ(i) = 0.0         i=1,...,L

      EFOR = 0.0          (exact start)
      EFOR = "small positive constant" (soft start).

      Soft starts are numerically more reliable, but result in a
      biased least-squares solution during the first few iterations.
      This bias decays exponentially fast provided LAMBDA < 1.0.
      If sigma is the standard deviation of the input sequence
      XIN, then initializing EFOR = sigma*1.0E-02 usually works
      well.
Example

Program Text 

*     FD01AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT, NOUT1
      PARAMETER        ( NIN = 5, NOUT = 6, NOUT1 = 7 )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          IMAX, LMAX
      PARAMETER        ( IMAX = 500, LMAX = 10 )
      DOUBLE PRECISION LAMBDA
      PARAMETER        ( LAMBDA = 0.99D0 )
*     .. Local Scalars ..
      CHARACTER        JP
      INTEGER          I, INFO, IWARN, L
      DOUBLE PRECISION DELTA, EFOR, EOUT, EPOS, XIN, YIN
*     .. Local Arrays ..
      DOUBLE PRECISION CTETA(LMAX), EPSBCK(LMAX+1), SALPH(LMAX),
     $                 STETA(LMAX), XF(LMAX), YQ(LMAX)
*     .. External Functions ..
      DOUBLE PRECISION XFCN, YFCN
      EXTERNAL         XFCN, YFCN
*     NOTE: XFCN() generates at each iteration the next sample of the
*           input sequence. YFCN() generates at each iteration the next
*           sample of the reference sequence. These functions are user
*           defined (obtained from data acquisition devices, for
*           example).
*     .. External Subroutines ..
      EXTERNAL         FD01AD
*
*     .. File for the output error sequence ..
      OPEN ( UNIT = NOUT1, FILE = 'ERR.OUT', STATUS = 'REPLACE' )
*     ..  Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, DELTA, JP
      IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) L
      ELSE
         IF ( DELTA.LT.ZERO ) THEN
            WRITE ( NOUT, FMT = 99991 )
         ELSE
*
            DO 10 I = 1, L
               CTETA(I)  = ONE
               STETA(I)  = ZERO
               EPSBCK(I) = ZERO
               XF(I) = ZERO
               YQ(I) = ZERO
   10       CONTINUE
            EPSBCK(L+1) = ONE
            EFOR = DELTA
*           .. Run least squares filter.
            DO 20 I = 1, IMAX
               XIN = XFCN(I)
               YIN = YFCN(I)
               CALL FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK,
     $                      CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN,
     $                      INFO)
               WRITE(NOUT1,*) EOUT
   20       CONTINUE
            CLOSE(NOUT1)
*           NOTE:  File 'ERR.OUT' now contains the output error
*                  sequence.
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 30 I = 1, L
                  WRITE ( NOUT, FMT = 99996 ) I, XF(I), YQ(I), EPSBCK(I)
   30          CONTINUE
               WRITE ( NOUT, FMT = 99995 ) L+1, EPSBCK(L+1)
               WRITE ( NOUT, FMT = 99994 ) EFOR
               IF ( IWARN.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99993 ) IWARN
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FD01AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from FD01AD = ', I2)
99997 FORMAT ('  i', 7X, 'XF(i)', 7X, 'YQ(i)', 6X, 'EPSBCK(i)', /1X)
99996 FORMAT ( I3, 2X, 3(2X, F10.6))
99995 FORMAT ( I3, 28X, F10.6, /1X)
99994 FORMAT (' EFOR = ', D10.3)
99993 FORMAT (' IWARN on exit from FD01AD = ', I2)
99992 FORMAT (/' L is out of range.',/' L = ',I5)
99991 FORMAT (/' The exponentially weighted forward prediction error',
     $         '  energy must be non-negative.' )
*
      END
*
*     .. Example functions ..
*
      DOUBLE PRECISION FUNCTION XFCN( I )
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE, SIN
*     .. Local Scalar ..
      INTEGER          I
*     .. Executable Statements ..
      XFCN = SIN( 0.3D0*DBLE( I ) )
* *** Last line of XFCN ***
      END
*
      DOUBLE PRECISION FUNCTION YFCN( I )
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE, SIN
*     .. Local Scalar ..
      INTEGER          I
*     .. Executable Statements ..
      YFCN = 0.5D0 * SIN( 0.3D0*DBLE( I ) ) +
     $       2.0D0 * SIN( 0.3D0*DBLE( I-1 ) )
* *** Last line of YFCN ***
      END
Program Data 
 FD01AD EXAMPLE PROGRAM DATA
   2    1.0D-2     B
Program Results 
 FD01AD EXAMPLE PROGRAM RESULTS

  i       XF(i)       YQ(i)      EPSBCK(i)

  1      4.880088   12.307615   -0.140367
  2     -1.456881    2.914057   -0.140367
  3                              0.980099

 EFOR =  0.197D-02

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/FSQP.html000077500000000000000000000405461201767322700157660ustar00rootroot00000000000000 FSQP - SLICOT Library Routine Documentation

FSQP

Minimization of the maximum of a set of smooth objective functions

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the minimization of the maximum of a set of smooth
  objective functions (possibly a single one or none at all) subject
  to nonlinear equality and inequality constraints, linear equality
  and inequality constraints, and simple bounds on the variables.
  Specifically, the problem to solve is of the form

                           min max{f (x)}
                                i   i

                                            n
  where 1 <= i <= NF, and x is a vector in R  subject to the
  following constraints

   bl <= x <= bu

   g (x)<=0,    j = 1 ... NINEQN
    j
   g (x)<=0,    j = NINEQN+1 ... NINEQ
    j
   h (x)=0,     j = 1 ... NEQN
    j
   h (x)=0,     j = NEQN+1 ... NEQ
    j

                                  n
  where bl and bu are vectors in R , and

       n
  f : R -> R,   j = 1 ... NF,           smooth
   j    
       n
  g : R -> R,   j = 1 ... NINEQN,       nonlinear and smooth 
   j 
       n
  g : R -> R,   j = NINEQN+1 ... NINEQ, linear
   j 
       n
  h : R -> R,   j = 1 ... NEQN,         nonlinear and smooth 
   j 
       n
  h : R -> R,   j = NEQN+1 ... NEQ,     linear
   j
Specification 
      SUBROUTINE FSQP( MODE, IPRINT, OBJ, CONSTR, GRADOB, GRADCN,
     &                 NPARAM, NF, NINEQN, NINEQ, NEQN, NEQ, MITER,
     &                 UDELTA, BIGBND, BL, BU, X, F, G, TOL1, TOL2,
     &                 IWORK, LIWORK, DWORK, LDWORK, INFO)
C     .. Scalar Arguments ..
      INTEGER           NPARAM, NF, NINEQN, NINEQ, NEQN, NEQ, MODE,
     &                  IPRINT, MITER, INFO, LIWORK, LDWORK
      DOUBLE PRECISION  BIGBND, TOL1, TOL2, UDELTA
C     .. Array Arguments ..
      INTEGER           IWORK(LIWORK)
      DOUBLE PRECISION  BL(*), BU(*), X(*), F(*), G(*), DWORK(LDWORK)
Arguments

Mode Parameters 

  MODE    (input) INTEGER
          mode = CBA (a 3-digit number) with the following meaning
          (see [1] for more details):

          A specifies the problem to be solved:
          A = 0: The problem is that described above.
          A = 1: In the problem described above, the function to
                 minimize is replaced by
                           min max{ABS(f (x))}
                                i       i
                 i.e., absolute values of the objective functions
                 are taken.

          B indicates the method to be used:
          B = 0: Algorithm FFSQP-AL is selected (see METHOD below).
          B = 1: Algorithm FFSQP-NL is selected (see METHOD below).

          C indicates the order of evaluation of objective
          functions and constraints during the line search:
          C = 1: The function that caused the previous value of t
                 to be rejected is checked first and all functions
                 of the same type ("objective" or "constraint") as
                 the latter will then be checked first (recommended
                 for most users).
          C = 2: Constraints will be always checked first at each
                 trial point during the line search. If it is a
                 contraint that caused the previous value of t to
                 be rejected, that constraint will be checked first
                 (useful when objective functions are not defined or
                 are difficult to evaluate outside of the feasible
                 region).

  IPRINT  (input) INTEGER
          Parameter indicating the desired output (see [1] for a
          more complete description of the output).
          IPRINT = 0: No information except for user-input errors
             is displayed. This value is imposed during phase 1.
          IPRINT = 1: Objective and constraint values at the
             initial feasible point are displayed. At the end of
             execution, status (INFO), iterate, objective values,
             constraint values, number of evaluations of objectives
             and nonlinear constraints, norm of the Kuhn-Tucker
             vector, and sum of feasibility violation are
             displayed.
          IPRINT = 2: At the end of each iteration, the same
             information as with IPRINT = 1 is displayed.
          IPRINT = 3: At each iteration, the same information as
             with IPRINT = 2,including detailed information on the
             search direction computation, on the line search, and
             on the update, is displayed.
          IPRINT = 10*N +M: N any positive integer, M=2 or 3.
             Information corresponding to IPRINT=M is displayed at
             every (10*N)th iteration and at the last iteration.
User-supplied Subroutines 
  OBJ     SUBROUTINE
          Computes the value of the objective functions. If NF = 0,
          a (dummy) subroutine must be provided anyway. The 
          specification of OBJ is

          SUBROUTINE OBJ(NPARAM,J,X,FJ)
          INTEGER NPARAM, J
          DOUBLE PRECISION X(NPARAM),FJ

          Arguments:
          NPARAM (Input) Dimension of X.
          J (Input) Number of the objective to be computed.
          X (Input) Current iterate.
          FJ (Output) Value of the jth objective function at X.

  CONSTR  SUBROUTINE
          Computes the value of the constraints. If there are no
          constraints, a (dummy) subroutine must be provided anyway.
          The specification of CONSTR is as follows.

          SUBROUTINE CONSTR(NPARAM,J,X,GJ)
          INTEGER NPARAM,J
          DOUBLE PRECISION X(NPARAM),GJ

          Arguments:
          NPARAM (Input) Dimension of X.
          J (Input) Number of the constraint to be computed.
          X (Input) Current iterate.
          GJ (Output) Value of the jth constraint at X.

          The order of the constraints must be as follows. First
          the NINEQN (possibly zero) nonlinear inequality
          constraints. Then the NINEQ-NINEQN (possibly zero) linear
          inequality constraints. Finally, the NEQN (possibly zero)
          nonlinear equality constraints followed by the NEQ-NEQN
          (possibly zero) linear equality constraints.

  GRADOB  SUBROUTINE
          Computes the gradients of the objective functions. The
          user must pass the subroutine name GROBFD, if he/she
          wishes that FSQP evaluate these gradients automatically,
          by forward finite differences. The specification of GRADOB
          is as follows.

          SUBROUTINE GRADOB(NPARAM,J,X,GRADFJ,DUMMY)
          INTEGER NPARAM,J
          DOUBLE PRECISION X(NPARAM),GRADFJ(NPARAM)
          DOUBLE PRECISION DUMMY
          EXTERNAL DUMMY

          Arguments:
          NPARAM (Input) Dimension of X.
          J (Input) Number of objective for which gradient is to be
                computed.
          X (Input) Current iterate.
          GRADFJ (Output) Gradient of the jth objective function at
                X.
          DUMMY (Input) Used by GROBFD (internally assigned the 
                name of the objective function subroutine by FFSQP).

          Note that DUMMY is passed as argument to GRADOB to allow
          for forward finite difference computation of the gradient.

  GRADCN  SUBROUTINE
          Computes the gradients of the constraints. The
          user must pass the subroutine name GRCNFD, if he/she
          wishes that FSQP evaluate these gradients automatically,
          by forward finite differences. The specification of GRADCN
          is as follows

          SUBROUTINE GRADCN (NPARAM,J,X,GRADGJ,DUMMY)
          INTEGER NPARAM,J
          DOUBLE PRECISION X(NPARAM),GRADGJ(NPARAM)
          DOUBLE PRECISION DUMMY
          EXTERNAL DUMMY

          Arguments:
          NPARAM (Input) Dimension of X.
          J (Input) Number of constraint for which gradient is to
                be computed.
          X (Input) Current iterate.
          GRADGJ (Output) Gradient of the jth constraint evaluated
                at X.
          DUMMY (Input) Used by GRCNFD (internally assigned the
                name of the constraint function subroutine by
                FFSQP).

          Note that DUMMY is passed as argument to GRADCN to allow
          for forward finite difference computation of the gradients.
Input/Output Parameters 
  NPARAM  (input) INTEGER
          Number of free variables, i.e., the dimension of X.

  NF      (input) INTEGER
          Number of objective functions (possibly zero).

  NINEQN  (input) INTEGER
          Number (possibly zero) of nonlinear inequality 
          constraints.

  NINEQ   (input) INTEGER
          Total number (possibly equal to nineqn) of inequality
          constraints.

  NEQN    (input) INTEGER
          Number (possibly zero) of nonlinear equality constraints.

  NEQ     (input) INTEGER
          Total number (possibly equal to neqn) of equality
          constraints.

  MITER   (input) INTEGER
          Maximum number of iterations allowed by the user before
          termination of execution.

  UDELTA  (input) DOUBLE PRECISION
          The perturbation size the user suggests to use in 
          approximating gradients by finite difference. UDELTA 
          should be set to zero if the user has no idea how to 
          choose it. See [1] for details.

  BIGBND  (input) DOUBLE PRECISION
          It plays the role of Infinite Bound (see also BL and BU
          below). 

  BL      (input) DOUBLE PRECISION array, dimension (NPARAM)
          Lower bounds for the components of X. To specify a non-
          existent lower bound for some j, the value used must
          satisfy BL(j) <= -BIGBND.

  BU      (input) DOUBLE PRECISION array, dimension (NPARAM)
          Upper bounds for the components of X. To specify a non-
          existent upper bound for some j, the value used must
          satisfy BU(j) >= BIGBND.

  X       (input/output) DOUBLE PRECISION array, dimension (NPARAM)
          On entry, this is the initial guess.
          On exit, this is the iterate at the end of execution.

  F       (output) DOUBLE PRECISION array, dimension ( MAX(1,NF) )
          Value of functions f_i, i = 1, ..., NF, at X at the end
          of execution.

  G       (output) DOUBLE PRECISION array, dimension 
          ( MAX(1,NINEQ+NEQ) )
          Value of constraint functions at X at the end of
          execution.
Tolerances 
  TOL1    DOUBLE PRECISION
          Corresponds to argument EPS in [1].
          Final norm requirement for the Newton direction (see [1],
          argument EPS). It must be bigger than the machine 
          precision epsmac (computed by FSQP). If the user does
          not have a good feeling of what value should be chosen,
          a very small number could be provided and IPRINT = 2 be
          selected so that the user would be able to keep track of
          the process of optimization and terminate FSQP at
          appropriate time.

  TOL2    DOUBLE PRECISION
          Corresponds to argument EPSEQN in [1].
          Maximum violation of nonlinear equality constraints
          allowed by the user at an optimal point. It is in effect
          only if NEQN > 0 and must be bigger than the machine
          precision epsmac (computed by FSQP).
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          Corresponds to argument IW in [1].

  LIWORK  INTEGER
          Corresponds to argument IWSIZE in [1].
          The length of array IWORK. It must be at least as big as 
          6*NPARAM + 8*max(1,NINEQ+NEQ) + 7*max(1,NF) + 30. This
          estimate is usually very conservative and the smallest
          suitable value will be displayed if the user-supplied
          value is too small.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          Corresponds to argument W in [1].
          On exit, it will contain estimates of Lagrange
          multipliers at the end of execution. These multipliers
          will be placed in the first NPARAM + NINEQ + NEQ + NFF
          entries; where NFF = 0 if (in mode) A = 0 and NF = 1, and
          NFF = NF otherwise. See [1] for details.

  LDWORK  INTEGER
          Corresponds to argument NWSIZE in [1].
          The length of array DWORK. It must be at least as big as
          4*SQR(NPARAM) + 5*MAX(1,NINEQ+NEQ)*NPARAM + 
          3*MAX(1,NF)*NPARAM + 26*(NPARAM+MAX(1,NF)) + 
          45*MAX(1,NINEQ+NEQ) + 100.
          This estimate is usually very conservative and the 
          smallest suitable value will be displayed if the user-
          supplied value is too small.
Error Indicator 
  INFO    (output) INTEGER
          Corresponds to argument INFORM in [1].
          INFO = 0: Normal termination of execution.
          INFO = 1: The user-provided initial guess is infeasible
             for linear constraints and FFSQP is unable to generate
             a point satisfying all these constraints.
          INFO = 2: The user-provided initial guess is infeasible
             for nonlinear inequality constraints and linear
             constraints; and FFSQP is unable to generate a point
             satisfying all these constraints.
          INFO = 3: The maximum number miter of iterations has
             been reached before a solution is obtained.
          INFO = 4: The line search fails to find a new iterate
             (trial step size being smaller than the machine
             precision epsmac computed by FFSQP).
          INFO = 5: Failure of the QP solver in attempting to
             construct d0. A more robust QP solver may succeed.
          INFO = 6: Failure of the QP solver in attempting to
             construct d1 . A more robust QP solver may succeed.
          INFO = 7: Input data are not consistent (with printout
             indicating the error).
          INFO = 8: Two consecutive iterates are numerically
             equivalent before a stopping criterion is satisfied.
          INFO = 9: One of the penalty parameters exceeded
             BIGBND. The algorithm is having trouble satisfying a
             nonlinear equality constraint.
Method 
  If the initial guess provided by the user is infeasible for
  nonlinear inequality constraints and linear constraints, FFSQP
  first generates a point satisfying all these constraints by
  iterating on the problem of minimizing the maximum of these
  constraints.

  Then, using Mayne-Polak's scheme, nonlinear equality
  constraints are turned into nonlinear inequality constraints
  and the original objective function is replaced by a modified
  objective function.

  After obtaining feasibility, either (i) an Armijo-type line
  search may be used (algorithm FFSQP-AL), yielding a monotone
  decrease of the objective function at each iteration; or (ii) a
  nonmonotone line search may be selected (algorithm FFSQP-NL),
  forcing a decrease of the objective function within at most four
  iterations.
  
  See [1] for further details.
References 
  [1] J. L. Zhou, A. L. Tits and C. T. Lawrence
      User's Guide for FFSQP Version 3.7 : A Fortran Code for
      Solving Optimization Programs, Possibly Minimax, with General
      Inequality Constraints and Linear Equality Constraints,
      Generating Feasible Iterates
      Institute for Systems Research, University of Maryland,
      Technical Report SRC-TR-92-107r5, 1997.
      (Available at http://gachinese.com/aemdesign/FSQPframe.htm)
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine and related files.

Return to index slicot-5.0+20101122/doc/IB01AD.html000077500000000000000000001336211201767322700160520ustar00rootroot00000000000000 IB01AD - SLICOT Library Routine Documentation

IB01AD

Upper triangular factor in the QR factorization of the block-Hankel matrix (driver)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To preprocess the input-output data for estimating the matrices
  of a linear time-invariant dynamical system and to find an
  estimate of the system order. The input-output data can,
  optionally, be processed sequentially.
Specification 
      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     .. 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, *)
Arguments

Mode Parameters 

  METH    CHARACTER*1
          Specifies the subspace identification method to be used,
          as follows:
          = 'M':  MOESP  algorithm with past inputs and outputs;
          = 'N':  N4SID  algorithm.

  ALG     CHARACTER*1
          Specifies the algorithm for computing the triangular
          factor R, as follows:
          = 'C':  Cholesky algorithm applied to the correlation
                  matrix of the input-output data;
          = 'F':  Fast QR algorithm;
          = 'Q':  QR algorithm applied to the concatenated block
                  Hankel matrices.

  JOBD    CHARACTER*1
          Specifies whether or not the matrices B and D should later
          be computed using the MOESP approach, as follows:
          = 'M':  the matrices B and D should later be computed
                  using the MOESP approach;
          = 'N':  the matrices B and D should not be computed using
                  the MOESP approach.
          This parameter is not relevant for METH = 'N'.

  BATCH   CHARACTER*1
          Specifies whether or not sequential data processing is to
          be used, and, for sequential processing, whether or not
          the current data block is the first block, an intermediate
          block, or the last block, as follows:
          = 'F':  the first block in sequential data processing;
          = 'I':  an intermediate block in sequential data
                  processing;
          = 'L':  the last block in sequential data processing;
          = 'O':  one block only (non-sequential data processing).
          NOTE that when  100  cycles of sequential data processing
               are completed for  BATCH = 'I',  a warning is
               issued, to prevent for an infinite loop.

  CONCT   CHARACTER*1
          Specifies whether or not the successive data blocks in
          sequential data processing belong to a single experiment,
          as follows:
          = 'C':  the current data block is a continuation of the
                  previous data block and/or it will be continued
                  by the next data block;
          = 'N':  there is no connection between the current data
                  block and the previous and/or the next ones.
          This parameter is not used if BATCH = 'O'.

  CTRL    CHARACTER*1
          Specifies whether or not the user's confirmation of the
          system order estimate is desired, as follows:
          = 'C':  user's confirmation;
          = 'N':  no confirmation.
          If  CTRL = 'C',  a reverse communication routine,  IB01OY,
          is indirectly called (by SLICOT Library routine IB01OD),
          and, after inspecting the singular values and system order
          estimate,  n,  the user may accept  n  or set a new value.
          IB01OY  is not called if CTRL = 'N'.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          block Hankel matrices to be processed.  NOBR > 0.
          (In the MOESP theory,  NOBR  should be larger than  n,
          the estimated dimension of state vector.)

  M       (input) INTEGER
          The number of system inputs.  M >= 0.
          When M = 0, no system inputs are processed.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMP    (input) INTEGER
          The number of rows of matrices  U  and  Y  (number of
          samples,  t). (When sequential data processing is used,
          NSMP  is the number of samples of the current data
          block.)
          NSMP >= 2*(M+L+1)*NOBR - 1,  for non-sequential
                                       processing;
          NSMP >= 2*NOBR,  for sequential processing.
          The total number of samples when calling the routine with
          BATCH = 'L'  should be at least  2*(M+L+1)*NOBR - 1.
          The  NSMP  argument may vary from a cycle to another in
          sequential data processing, but  NOBR, M,  and  L  should
          be kept constant. For efficiency, it is advisable to use
          NSMP  as large as possible.

  U       (input) DOUBLE PRECISION array, dimension (LDU,M)
          The leading NSMP-by-M part of this array must contain the
          t-by-m input-data sequence matrix  U,
          U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
          NSMP  values of the j-th input component for consecutive
          time increments.
          If M = 0, this array is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= NSMP, if M > 0;
          LDU >= 1,    if M = 0.

  Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
          The leading NSMP-by-L part of this array must contain the
          t-by-l output-data sequence matrix  Y,
          Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
          NSMP  values of the j-th output component for consecutive
          time increments.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= NSMP.

  N       (output) INTEGER
          The estimated order of the system.
          If  CTRL = 'C',  the estimated order has been reset to a
          value specified by the user.

  R       (output or input/output) DOUBLE PRECISION array, dimension
          ( LDR,2*(M+L)*NOBR )
          On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading
          2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this
          array contains the current upper triangular part of the
          correlation matrix in sequential data processing.
          If ALG = 'F' and BATCH = 'F' or 'I', the array R is not
          referenced.
          On exit, if INFO = 0, ALG = 'Q', and BATCH = 'F' or 'I',
          the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular
          part of this array contains the current upper triangular
          factor R from the QR factorization of the concatenated
          block Hankel matrices. Denote  R_ij, i,j = 1:4,  the
          ij submatrix of  R,  partitioned by M*NOBR,  M*NOBR,
          L*NOBR,  and  L*NOBR  rows and columns.
          On exit, if INFO = 0 and BATCH = 'L' or 'O', the leading
          2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of
          this array contains the matrix S, the processed upper
          triangular factor R from the QR factorization of the
          concatenated block Hankel matrices, as required by other
          subroutines. Specifically, let  S_ij, i,j = 1:4,  be the
          ij submatrix of  S,  partitioned by M*NOBR,  L*NOBR,
          M*NOBR,  and  L*NOBR  rows and columns. The submatrix
          S_22  contains the matrix of left singular vectors needed
          subsequently. Useful information is stored in  S_11  and
          in the block-column  S_14 : S_44.  For METH = 'M' and
          JOBD = 'M', the upper triangular part of  S_31  contains
          the upper triangular factor in the QR factorization of the
          matrix  R_1c = [ R_12'  R_22'  R_11' ]',  and  S_12
          contains the corresponding leading part of the transformed
          matrix  R_2c = [ R_13'  R_23'  R_14' ]'.  For  METH = 'N',
          the subarray  S_41 : S_43  contains the transpose of the
          matrix contained in  S_14 : S_34.
          The details of the contents of R need not be known if this
          routine is followed by SLICOT Library routine IB01BD.
          On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or
          'L', the leading  2*(M+L)*NOBR-by-2*(M+L)*NOBR  upper
          triangular part of this array must contain the upper
          triangular matrix R computed at the previous call of this
          routine in sequential data processing. The array R need
          not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'.

  LDR     INTEGER
          The leading dimension of the array  R.
          LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ),
                               for METH = 'M' and JOBD = 'M';
          LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or
                               for METH = 'N'.

  SV      (output) DOUBLE PRECISION array, dimension ( L*NOBR )
          The singular values used to estimate the system order.
Tolerances 
  RCOND   DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  RCOND > 0,  the given value
          of  RCOND  is used as a lower bound for the reciprocal
          condition number;  an m-by-n matrix whose estimated
          condition number is less than  1/RCOND  is considered to
          be of full rank.  If the user sets  RCOND <= 0,  then an
          implicitly computed, default tolerance, defined by
          RCONDEF = m*n*EPS,  is used instead, where  EPS  is the
          relative machine precision (see LAPACK Library routine
          DLAMCH).
          This parameter is not used for  METH = 'M'.

  TOL     DOUBLE PRECISION
          Absolute tolerance used for determining an estimate of
          the system order. If  TOL >= 0,  the estimate is
          indicated by the index of the last singular value greater
          than or equal to  TOL.  (Singular values less than  TOL
          are considered as zero.) When  TOL = 0,  an internally
          computed default value,  TOL = NOBR*EPS*SV(1),  is used,
          where  SV(1)  is the maximal singular value, and  EPS  is
          the relative machine precision (see LAPACK Library routine
          DLAMCH). When  TOL < 0,  the estimate is indicated by the
          index of the singular value that has the largest
          logarithmic gap to its successor.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= (M+L)*NOBR, if METH = 'N';
          LIWORK >= M+L, if METH = 'M' and ALG = 'F';
          LIWORK >= 0,   if METH = 'M' and ALG = 'C' or 'Q'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK,  and, for  METH = 'N',  and  BATCH = 'L'  or
          'O',  DWORK(2)  and  DWORK(3)  contain the reciprocal
          condition numbers of the triangular factors of the
          matrices  U_f  and  r_1  [6].
          On exit, if  INFO = -23,  DWORK(1)  returns the minimum
          value of LDWORK.
          Let
          k = 0,               if CONCT = 'N' and ALG = 'C' or 'Q';
          k = 2*NOBR-1,        if CONCT = 'C' and ALG = 'C' or 'Q';
          k = 2*NOBR*(M+L+1),  if CONCT = 'N' and ALG = 'F';
          k = 2*NOBR*(M+L+2),  if CONCT = 'C' and ALG = 'F'.
          The first (M+L)*k elements of  DWORK  should be preserved
          during successive calls of the routine with  BATCH = 'F'
          or  'I',  till the final call with  BATCH = 'L'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH = 'F' or
                          'I' and CONCT = 'C';
          LDWORK >= 1, if ALG = 'C', BATCH = 'F' or 'I' and
                          CONCT = 'N';
          LDWORK >= max((4*NOBR-2)*(M+L), 5*L*NOBR), if METH = 'M',
                          ALG = 'C', BATCH = 'L' and CONCT = 'C';
          LDWORK >= max((2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR),
                          if METH = 'M', JOBD = 'M', ALG = 'C',
                           BATCH = 'O', or
                          (BATCH = 'L' and CONCT = 'N');
          LDWORK >= 5*L*NOBR, if METH = 'M', JOBD = 'N', ALG = 'C',
                           BATCH = 'O', or
                          (BATCH = 'L' and CONCT = 'N');
          LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'C', and
                          BATCH = 'L' or 'O';
          LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F',
                          BATCH <> 'O' and CONCT = 'C';
          LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F',
                          BATCH = 'F', 'I' and CONCT = 'N';
          LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F',
                          BATCH = 'L' and CONCT = 'N', or
                          BATCH = 'O';
          LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F', and
                          LDR >= NS = NSMP - 2*NOBR + 1;
          LDWORK >= max(4*(M+L)*NOBR, 5*L*NOBR), if METH = 'M',
                          ALG = 'Q', BATCH = 'O', and LDR >= NS;
          LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'Q',
                          BATCH = 'O', and LDR >= NS;
          LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', (BATCH = 'F' or 'O',
                          and LDR < NS), or (BATCH = 'I' or
                          'L' and CONCT = 'N');
          LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I'
                          or 'L' and CONCT = 'C'.
          The workspace used for ALG = 'Q' is
                    LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR,
          where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended
          value LDRWRK = NS, assuming a large enough cache size.
          For good performance,  LDWORK  should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  the number of 100 cycles in sequential data
                processing has been exhausted without signaling
                that the last block of data was get; the cycle
                counter was reinitialized;
          = 2:  a fast algorithm was requested (ALG = 'C' or 'F'),
                but it failed, and the QR algorithm was then used
                (non-sequential data processing);
          = 3:  all singular values were exactly zero, hence  N = 0
                (both input and output were identically zero);
          = 4:  the least squares problems with coefficient matrix
                U_f,  used for computing the weighted oblique
                projection (for METH = 'N'), have a rank-deficient
                coefficient matrix;
          = 5:  the least squares problem with coefficient matrix
                r_1  [6], used for computing the weighted oblique
                projection (for METH = 'N'), has a rank-deficient
                coefficient matrix.
          NOTE: the values 4 and 5 of IWARN have no significance
                for the identification problem.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  a fast algorithm was requested (ALG = 'C', or 'F')
                in sequential data processing, but it failed; the
                routine can be repeatedly called again using the
                standard QR algorithm;
          = 2:  the singular value decomposition (SVD) algorithm did
                not converge.
Method 
  The procedure consists in three main steps, the first step being
  performed by one of the three algorithms included.

  1.a) For non-sequential data processing using QR algorithm, a
  t x 2(m+l)s  matrix H is constructed, where

       H = [ Uf'         Up'      Y'      ],  for METH = 'M',
               s+1,2s,t    1,s,t   1,2s,t

       H = [ U'       Y'      ],              for METH = 'N',
              1,2s,t   1,2s,t

  and  Up     , Uf        , U      , and  Y        are block Hankel
         1,s,t    s+1,2s,t   1,2s,t        1,2s,t
  matrices defined in terms of the input and output data [3].
  A QR factorization is used to compress the data.
  The fast QR algorithm uses a QR factorization which exploits
  the block-Hankel structure. Actually, the Cholesky factor of H'*H
  is computed.

  1.b) For sequential data processing using QR algorithm, the QR
  decomposition is done sequentially, by updating the upper
  triangular factor  R.  This is also performed internally if the
  workspace is not large enough to accommodate an entire batch.

  1.c) For non-sequential or sequential data processing using
  Cholesky algorithm, the correlation matrix of input-output data is
  computed (sequentially, if requested), taking advantage of the
  block Hankel structure [7].  Then, the Cholesky factor of the
  correlation matrix is found, if possible.

  2) A singular value decomposition (SVD) of a certain matrix is
  then computed, which reveals the order  n  of the system as the
  number of "non-zero" singular values. For the MOESP approach, this
  matrix is  [ R_24'  R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s),
  where  R  is the upper triangular factor  R  constructed by SLICOT
  Library routine  IB01MD.  For the N4SID approach, a weighted
  oblique projection is computed from the upper triangular factor  R
  and its SVD is then found.

  3) The singular values are compared to the given, or default TOL,
  and the estimated order  n  is returned, possibly after user's
  confirmation.
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error
      state-space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Verhaegen M.
      Subspace Model Identification. Part 3: Analysis of the
      ordinary output-error state-space model identification
      algorithm.
      Int. J. Control, 58, pp. 555-586, 1993.

  [3] Verhaegen M.
      Identification of the deterministic part of MIMO state space
      models given in innovations form from input-output data.
      Automatica, Vol.30, No.1, pp.61-74, 1994.

  [4] Van Overschee, P., and De Moor, B.
      N4SID: Subspace Algorithms for the Identification of
      Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [5] Peternell, K., Scherrer, W. and Deistler, M.
      Statistical Analysis of Novel Subspace Identification Methods.
      Signal Processing, 52, pp. 161-177, 1996.

  [6] Sima, V.
      Subspace-based Algorithms for Multivariable System
      Identification.
      Studies in Informatics and Control, 5, pp. 335-344, 1996.

  [7] Sima, V.
      Cholesky or QR Factorization for Data Compression in
      Subspace-based Identification ?
      Proceedings of the Second NICONET Workshop on ``Numerical
      Control Software: SLICOT, a Useful Tool in Industry'',
      December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999.
Numerical Aspects 
  The implemented method is numerically stable (when QR algorithm is
  used), reliable and efficient. The fast Cholesky or QR algorithms
  are more efficient, but the accuracy could diminish by forming the
  correlation matrix.
  The most time-consuming computational step is step 1:
                                     2
  The QR algorithm needs 0(t(2(m+l)s) ) floating point operations.
                                        2              3
  The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating
  point operations.
                                       2           3 2
  The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating
  point operations.
                                             3
  Step 2 of the algorithm requires 0(((m+l)s) ) floating point
  operations.
Further Comments 
  For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the
  calculations could be rather inefficient if only minimal workspace
  (see argument LDWORK) is provided. It is advisable to provide as
  much workspace as possible. Almost optimal efficiency can be
  obtained for  LDWORK = (NS+2)*(2*(M+L)*NOBR),  assuming that the
  cache size is large enough to accommodate R, U, Y, and DWORK.
Example

Program Text 

*     IB01AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LDR, LDU, LDWORK, LDY, LIWORK, LMAX, MMAX,
     $                 NOBRMX, NSMPMX
      PARAMETER        ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000,
     $                   LDR = MAX( 2*( MMAX + LMAX )*NOBRMX,
     $                              3*MMAX*NOBRMX ), LDU = NSMPMX,
     $                   LDWORK = MAX( 6*( MMAX + LMAX )*NOBRMX,
     $                                 ( MMAX + LMAX )*( 4*NOBRMX*
     $                                 ( MMAX + LMAX + 1 ) + 2*NOBRMX ),
     $                                 ( MMAX + LMAX )*4*NOBRMX*
     $                                 ( NOBRMX + 1 ) ),
     $                   LDY = NSMPMX, LIWORK = ( MMAX + LMAX )*NOBRMX )
*     .. Local Scalars ..
      LOGICAL          NGIVEN
      CHARACTER        ALG, BATCH, CONCT, CTRL, JOBD, METH
      INTEGER          I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE,
     $                 NGIV, NOBR, NSAMPL, NSMP
      DOUBLE PRECISION RCOND, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), R(LDR, 2*(MMAX+LMAX)*NOBRMX),
     $                 SV(LMAX*NOBRMX), U(LDU, MMAX), Y(LDY, LMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         IB01AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
*     If the value of N is positive, it will be taken as system order.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL, METH, ALG,
     $                      JOBD, BATCH, CONCT, CTRL
      IF ( LSAME( BATCH, 'F' ) ) THEN
         READ ( NIN, FMT = * ) NCYCLE
      ELSE
         NCYCLE = 1
      END IF
      NSAMPL = NCYCLE*NSMP
*
      NGIVEN = N.GT.0
      IF( NGIVEN )
     $   NGIV = N
      IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN
         WRITE ( NOUT, FMT = 99997 ) NOBR
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99996 ) M
      ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) L
      ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR.
     $        ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'O' ) ) .OR.
     $        ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'L' ) ) .OR.
     $          NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR.
     $                                 LSAME( BATCH, 'I' ) ) ) THEN
         WRITE ( NOUT, FMT = 99994 ) NSMP
      ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NCYCLE
      ELSE
*        Read the matrices U and Y from the input file.
         IF ( M.GT.0 )
     $      READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1, M ), I = 1, NSAMPL )
         READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL )
*        Compute the  R  factor from a QR (or Cholesky) factorization
*        of the Hankel-like matrix (or correlation matrix).
         DO 10 ICYCLE = 1, NCYCLE
            II = ( ICYCLE - 1 )*NSMP + 1
            IF ( NCYCLE.GT.1 ) THEN
               IF ( ICYCLE.GT.1 )      BATCH = 'I'
               IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L'
            END IF
            CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M,
     $                   L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR,
     $                   SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN,
     $                   INFO )
   10    CONTINUE
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 )
     $         WRITE ( NOUT, FMT = 99990 ) IWARN
            IF( NGIVEN )
     $         N = NGIV
            WRITE ( NOUT, FMT = 99992 ) N
            WRITE ( NOUT, FMT = 99991 ) ( SV(I), I = 1,L*NOBR )
         END IF
      END IF
      STOP
99999 FORMAT ( ' IB01AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT ( ' INFO on exit from IB01AD = ',I2)
99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5)
99996 FORMAT (/' M is out of range.',/' M = ', I5)
99995 FORMAT (/' L is out of range.',/' L = ', I5)
99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5)
99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5)
99992 FORMAT ( ' The order of the system is ', I5)
99991 FORMAT ( ' The singular values are ',/ (8(1X,F8.4)))
99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2)
      END
Program Data 
 IB01AD EXAMPLE PROGRAM DATA
  15     0     1     1  1000    0.0   -1.0     M     C     N     O     N     N
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   4.766099
   4.763659
   4.839359
   5.002979
   5.017629
   5.056699
   5.154379
   5.361949
   5.425439
   5.569519
   5.681849
   5.742899
   5.803949
   5.918729
   5.821049
   5.447419
   5.061589
   4.629349
   4.267939
   4.011519
   3.850349
   3.711159
   3.569519
   3.518239
   3.652549
   3.818609
   3.862559
   4.011519
   4.353409
   4.705049
   5.083559
   5.344859
   5.274039
   5.127519
   4.761219
   4.451089
   4.221539
   4.045709
   3.874769
   3.730689
   3.662319
   3.576849
   3.542659
   3.479169
   3.454749
   3.359509
   3.298459
   3.225199
   3.200779
   3.225199
   3.227639
   3.274039
   3.457189
   3.867449
   4.321659
   4.492599
   4.431549
   4.243519
   4.050599
   3.857679
   3.730689
   3.791739
   3.921169
   3.955359
   3.847909
   3.725809
   3.611039
   3.716039
   4.092109
   4.480389
   4.814939
   5.054259
   5.303339
   5.486489
   5.672089
   5.779529
   5.799069
   5.664759
   5.291129
   4.880879
   4.558529
   4.184909
   3.889419
   3.708719
   3.623249
   3.569519
   3.718479
   4.033499
   4.412009
   4.629349
   4.558529
   4.394919
   4.180019
   4.197119
   4.431549
   4.714819
   4.961459
   5.300899
   5.567079
   5.681849
   5.545099
   5.188569
   4.883319
   4.600049
   4.270379
   4.038389
   3.838139
   3.711159
   3.591499
   3.535329
   3.486489
   3.476729
   3.425439
   3.381489
   3.369279
   3.364389
   3.347299
   3.381489
   3.420559
   3.413229
   3.452309
   3.635459
   4.038389
   4.375379
   4.727029
   5.056699
   5.298459
   5.532889
   5.466959
   5.195899
   4.885759
   4.763659
   4.875989
   5.042049
   5.283809
   5.491379
   5.596379
   5.672089
   5.772209
   5.830819
   5.933379
   5.899189
   5.935819
   5.894309
   5.918729
   5.994429
   5.957799
   6.031059
   6.062809
   6.040829
   6.096999
   6.123859
   6.162929
   6.040829
   5.845469
   5.772209
   5.799069
   5.923609
   5.928499
   6.001759
   6.001759
   6.060369
   5.882099
   5.510909
   5.322879
   5.371719
   5.454749
   5.437649
   5.159269
   4.902859
   4.587839
   4.502369
   4.595159
   4.824709
   5.064029
   5.271599
   5.466959
   5.615919
   5.528009
   5.254499
   4.883319
   4.517019
   4.197119
   4.001759
   3.806399
   3.904079
   3.923609
   3.869889
   3.806399
   3.720929
   3.818609
   4.140949
   4.529229
   4.805179
   5.086009
   5.339969
   5.532889
   5.576849
   5.667199
   5.791739
   5.850349
   5.923609
   5.921169
   5.977339
   5.740459
   5.388809
   5.000539
   4.849129
   4.944369
   5.173919
   5.369279
   5.447419
   5.603709
   5.730689
   5.850349
   5.979779
   5.991989
   6.084789
   5.940709
   5.803949
   5.791739
   5.603709
   5.264269
   4.946809
   4.619579
   4.514579
   4.433989
   4.285029
   4.121419
   3.945589
   3.984659
   4.219099
   4.546319
   4.873549
   5.154379
   5.388809
   5.613479
   5.835699
   5.884539
   5.955359
   5.762439
   5.459629
   5.061589
   4.707499
   4.458409
   4.267939
   4.053039
   3.943149
   3.825929
   3.967569
   4.280149
   4.480389
   4.492599
   4.390039
   4.197119
   4.111649
   3.982219
   3.867449
   3.767319
   3.872329
   4.236189
   4.663539
   4.971229
   5.066469
   4.902859
   4.675749
   4.392479
   4.099439
   4.114089
   4.326539
   4.643999
   4.971229
   5.159269
   5.388809
   5.576849
   5.652549
   5.803949
   5.913839
   5.886979
   5.799069
   5.730689
   5.762439
   5.813719
   5.821049
   5.928499
   6.013969
   5.764879
   5.413229
   5.098219
   4.678189
   4.372939
   4.392479
   4.590279
   4.919949
   5.017629
   4.858899
   4.675749
   4.619579
   4.834479
   5.090889
   5.376599
   5.681849
   5.823489
   5.952919
   6.062809
   6.089669
   6.075019
   6.026179
   5.994429
   6.077459
   5.857679
   5.701389
   5.730689
   5.784419
   5.823489
   5.894309
   5.762439
   5.415679
   4.961459
   4.595159
   4.331429
   4.297239
   4.582949
   4.861339
   5.173919
   5.166589
   4.919949
   4.607369
   4.370499
   4.182469
   4.038389
   4.145839
   4.431549
   4.556089
   4.480389
   4.375379
   4.370499
   4.558529
   4.858899
   4.895529
   4.741679
   4.744129
   4.875989
   5.105539
   5.239849
   5.518239
   5.652549
   5.723369
   5.855239
   5.962679
   5.984659
   5.984659
   6.055479
   6.062809
   6.055479
   6.070129
   5.784419
   5.440099
   5.056699
   4.941929
   5.010299
   5.134849
   5.313109
   5.479169
   5.623249
   5.562199
   5.330209
   5.010299
   4.665979
   4.414459
   4.201999
   4.048159
   4.079899
   4.189789
   4.131179
   4.004199
   3.916289
   3.960239
   4.199559
   4.624469
   4.883319
   5.137289
   5.379049
   5.623249
   5.762439
   5.833259
   5.686739
   5.366839
   5.225199
   5.239849
   5.354629
   5.508469
   5.596379
   5.752669
   5.874769
   5.906519
   5.894309
   5.742899
   5.447419
   5.024959
   4.883319
   4.885759
   4.893089
   4.714819
   4.451089
   4.233749
   4.043269
   3.864999
   3.757559
   3.669639
   3.593939
   3.547539
   3.506029
   3.454749
   3.398579
   3.361949
   3.339969
   3.374159
   3.520679
   3.713599
   3.757559
   3.779529
   3.696509
   3.777089
   3.886979
   3.904079
   3.850349
   3.965129
   4.282589
   4.521899
   4.714819
   4.971229
   5.220319
   5.532889
   5.652549
   5.781979
   5.955359
   6.035939
   6.118969
   6.133629
   6.153159
   6.192229
   6.143389
   6.167809
   5.991989
   5.652549
   5.459629
   5.437649
   5.339969
   5.098219
   4.785639
   4.492599
   4.236189
   4.067689
   3.933379
   3.823489
   3.730689
   3.611039
   3.564639
   3.549989
   3.557309
   3.513359
   3.515799
   3.694059
   4.072579
   4.480389
   4.705049
   4.612259
   4.385149
   4.201999
   4.026179
   3.904079
   3.774649
   3.691619
   3.845469
   4.201999
   4.585399
   4.902859
   5.256949
   5.510909
   5.640339
   5.843029
   5.974889
   5.935819
   5.821049
   5.528009
   5.171479
   4.810059
   4.453529
   4.380269
   4.565859
   4.805179
   5.125079
   5.354629
   5.589059
   5.764879
   5.923609
   5.940709
   5.857679
   5.694059
   5.486489
   5.149499
   4.844249
   4.541439
   4.267939
   4.060369
   3.960239
   3.789299
   3.642779
   3.525569
   3.498699
   3.454749
   3.408349
   3.379049
   3.376599
   3.361949
   3.359509
   3.369279
   3.398579
   3.579289
   3.948029
   4.412009
   4.585399
   4.514579
   4.343639
   4.155599
   3.984659
   4.043269
   4.307009
   4.421779
   4.353409
   4.223979
   4.053039
   3.940709
   3.838139
   3.730689
   3.652549
   3.611039
   3.564639
   3.496259
   3.462069
   3.454749
   3.425439
   3.379049
   3.432769
   3.623249
   3.974889
   4.380269
   4.714819
   5.073799
   5.369279
   5.603709
   5.745349
   5.652549
   5.401019
   5.015189
   4.709939
   4.416899
   4.236189
   4.236189
   4.248399
   4.221539
   4.297239
   4.590279
   4.893089
   5.134849
   5.427889
   5.379049
   5.364389
   5.452309
   5.567079
   5.672089
   5.769769
   5.830819
   5.923609
   5.965129
   6.057919
   6.050599
   6.072579
   6.111649
   6.070129
   5.896749
   5.755109
   5.718479
   5.821049
   6.001759
   6.001759
   5.901629
   5.557309
   5.173919
   4.800289
   4.431549
   4.194679
   4.006639
   3.850349
   3.747789
   3.642779
   3.591499
   3.569519
   3.528009
   3.537779
   3.554869
   3.493819
   3.447419
   3.440099
   3.408349
   3.410789
   3.452309
   3.681849
   4.060369
   4.441319
   4.854019
   5.154379
   5.425439
   5.596379
   5.586619
   5.354629
   5.027399
   4.863779
   4.761219
   4.570739
   4.368059
   4.397359
   4.573189
   4.841809
   5.203219
   5.452309
   5.652549
   5.855239
   5.906519
   5.952919
   5.828369
   5.791739
   5.799069
   5.813719
   5.877209
   5.955359
   5.781979
   5.518239
   5.127519
   4.763659
   4.492599
   4.233749
   4.011519
   3.855239
   3.691619
   3.635459
   3.818609
   4.155599
   4.590279
   4.988329
   5.076239
   4.907739
   4.648889
   4.377829
   4.216649
   4.287469
   4.590279
   4.846689
   5.139729
   5.388809
   5.689179
   5.884539
   6.043269
   6.170259
   6.211769
   6.250839
   6.209329
   6.013969
   5.701389
   5.469399
   5.479169
   5.557309
   5.728249
   5.882099
   5.984659
   5.901629
   5.581729
   5.371719
   5.418119
   5.510909
   5.667199
   5.791739
   5.698949
   5.484049
   5.154379
   4.980999
   5.061589
   5.195899
   5.359509
   5.615919
   5.762439
   5.857679
   5.948029
   5.835699
   5.706269
   5.498699
   5.188569
   5.117749
   5.191009
   5.315549
   5.532889
   5.444979
   5.396139
   5.274039
   5.027399
   4.744129
   4.668419
   4.651329
   4.514579
   4.267939
   4.260609
   4.263049
   4.189789
   4.277699
   4.600049
   4.932159
   5.283809
   5.528009
   5.740459
   5.874769
   5.955359
   5.991989
   5.845469
   5.528009
   5.061589
   4.734359
   4.534109
   4.534109
   4.697729
   4.744129
   4.619579
   4.643999
   4.832039
   5.132399
   5.410789
   5.625689
   5.603709
   5.315549
   4.961459
   4.619579
   4.358289
   4.155599
   4.033499
   3.886979
   3.772209
   3.640339
   3.532889
   3.435209
   3.427889
   3.422999
   3.398579
   3.603709
   4.023729
   4.451089
   4.792969
   4.902859
   4.780759
   4.590279
   4.336309
   4.145839
   4.216649
   4.433989
   4.714819
   5.098219
   5.359509
   5.569519
   5.772209
   5.921169
   6.055479
   5.962679
   5.642779
   5.435209
   5.388809
   5.537779
   5.681849
   5.701389
   5.615919
   5.667199
   5.740459
   5.803949
   5.882099
   5.950469
   6.072579
   6.148279
   6.116529
   6.177579
   6.201999
   6.206889
   5.991989
   5.564639
   5.178799
   4.998089
   5.051819
   5.232529
   5.484049
   5.686739
   5.899189
   5.869889
   5.977339
   6.053039
   6.079899
   6.128739
   6.079899
   6.167809
   6.194679
   6.236189
   6.053039
   5.652549
   5.274039
   4.858899
   4.534109
   4.455969
   4.619579
   4.866229
   5.117749
   5.166589
   5.056699
   5.002979
   5.098219
   5.325319
   5.567079
   5.466959
   5.252059
   4.946809
   4.880879
   4.980999
   5.225199
   5.459629
   5.723369
   5.791739
   5.906519
   5.991989
   5.835699
   5.528009
   5.142169
   4.775869
   4.490159
   4.236189
   4.023729
   3.886979
   3.752669
   3.681849
   3.806399
   4.145839
   4.600049
   5.002979
   5.303339
   5.552429
   5.615919
   5.523119
   5.611039
   5.713599
   5.845469
   5.899189
   5.994429
   6.092109
   6.092109
   6.143389
   6.153159
   6.233749
   6.187349
   6.013969
   5.835699
   5.774649
   5.686739
   5.537779
   5.327759
   5.054259
   4.700169
   4.394919
   4.180019
   4.043269
   3.877209
   3.752669
   3.728249
   3.869889
   4.206889
   4.355849
   4.426669
   4.453529
   4.521899
   4.392479
   4.155599
   3.965129
   3.877209
   3.970009
   4.258169
   4.421779
   4.336309
   4.299679
   4.392479
   4.675749
   4.761219
   4.658659
   4.490159
   4.307009
   4.126299
   3.972449
   4.077459
   4.372939
   4.741679
   5.088449
   5.186129
   5.037169
   4.785639
   4.563419
   4.534109
   4.705049
   4.741679
   4.648889
   4.431549
   4.238629
   4.065249
   3.943149
   3.811279
   3.691619
   3.652549
   3.825929
   4.223979
   4.424219
   4.429109
   4.319219
   4.138509
   3.965129
   3.886979
   3.801509
   3.701389
   3.640339
   3.767319
   4.150719
   4.648889
   4.990769
   5.088449
   5.022509
   4.783199
   4.685519
   4.665979
   4.707499
   4.912619
   5.195899
   5.415679
   5.623249
   5.740459
   5.899189
   5.928499
   6.050599
   6.153159
   5.965129
   5.586619
   5.381489
   5.371719
   5.486489
   5.567079
   5.821049
   5.913839
   5.994429
   6.011519
   5.999309
   6.018849
   5.821049
   5.728249
   5.740459
   5.764879
   5.882099
   5.926049
   5.750229
   5.415679
   4.995649
   4.861339
   4.902859
   5.103099
   5.364389
   5.596379
   5.752669
   5.845469
   5.928499
   6.006639
   5.840579
   5.518239
   5.173919
   4.739239
   4.458409
   4.426669
   4.602489
   4.822269
   5.183689
   5.430329
   5.652549
   5.821049
   5.706269
   5.369279
   5.027399
   4.705049
   4.414459
   4.145839
   3.965129
   4.033499
   4.372939
   4.683079
Program Results 
 IB01AD EXAMPLE PROGRAM RESULTS

 The order of the system is     4
 The singular values are 
  69.8841  14.9963   3.6675   1.9677   0.3000   0.2078   0.1651   0.1373
   0.1133   0.1059   0.0856   0.0784   0.0733   0.0678   0.0571

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/IB01BD.html000077500000000000000000001441771201767322700160630ustar00rootroot00000000000000 IB01BD - SLICOT Library Routine Documentation

IB01BD

Estimating system matrices, Kalman gain, and covariances (driver)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the system matrices A, C, B, and D, the noise
  covariance matrices Q, Ry, and S, and the Kalman gain matrix K
  of a linear time-invariant state space model, using the
  processed triangular factor R of the concatenated block Hankel
  matrices, provided by SLICOT Library routine IB01AD.
Specification 
      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     .. 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( * )
Arguments

Mode Parameters 

  METH    CHARACTER*1
          Specifies the subspace identification method to be used,
          as follows:
          = 'M':  MOESP  algorithm with past inputs and outputs;
          = 'N':  N4SID  algorithm;
          = 'C':  combined method:  MOESP  algorithm for finding the
                  matrices A and C, and  N4SID  algorithm for
                  finding the matrices B and D.

  JOB     CHARACTER*1
          Specifies which matrices should be computed, as follows:
          = 'A':  compute all system matrices, A, B, C, and D;
          = 'C':  compute the matrices A and C only;
          = 'B':  compute the matrix B only;
          = 'D':  compute the matrices B and D only.

  JOBCK   CHARACTER*1
          Specifies whether or not the covariance matrices and the
          Kalman gain matrix are to be computed, as follows:
          = 'C':  the covariance matrices only should be computed;
          = 'K':  the covariance matrices and the Kalman gain
                  matrix should be computed;
          = 'N':  the covariance matrices and the Kalman gain matrix
                  should not be computed.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          Hankel matrices processed by other routines.  NOBR > 1.

  N       (input) INTEGER
          The order of the system.  NOBR > N > 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMPL   (input) INTEGER
          If  JOBCK = 'C' or 'K',  the total number of samples used
          for calculating the covariance matrices.
          NSMPL >= 2*(M+L)*NOBR.
          This parameter is not meaningful if  JOBCK = 'N'.

  R       (input/workspace) DOUBLE PRECISION array, dimension
          ( LDR,2*(M+L)*NOBR )
          On entry, the leading  2*(M+L)*NOBR-by-2*(M+L)*NOBR  part
          of this array must contain the relevant data for the MOESP
          or N4SID algorithms, as constructed by SLICOT Library
          routine IB01AD. Let  R_ij,  i,j = 1:4,  be the
          ij submatrix of  R  (denoted  S  in IB01AD),  partitioned
          by  M*NOBR,  L*NOBR,  M*NOBR,  and  L*NOBR  rows and
          columns. The submatrix  R_22  contains the matrix of left
          singular vectors used. Also needed, for  METH = 'N'  or
          JOBCK <> 'N',  are the submatrices  R_11,  R_14 : R_44,
          and, for  METH = 'M' or 'C'  and  JOB <> 'C', the
          submatrices  R_31  and  R_12,  containing the processed
          matrices  R_1c  and  R_2c,  respectively, as returned by
          SLICOT Library routine IB01AD.
          Moreover, if  METH = 'N'  and  JOB = 'A' or 'C',  the
          block-row  R_41 : R_43  must contain the transpose of the
          block-column  R_14 : R_34  as returned by SLICOT Library
          routine IB01AD.
          The remaining part of  R  is used as workspace.
          On exit, part of this array is overwritten. Specifically,
          if  METH = 'M',  R_22  and  R_31  are overwritten if
              JOB = 'B' or 'D',  and  R_12,  R_22,  R_14 : R_34,
              and possibly  R_11  are overwritten if  JOBCK <> 'N';
          if  METH = 'N',  all needed submatrices are overwritten.
          The details of the contents of  R  need not be known if
          this routine is called once just after calling the SLICOT
          Library routine IB01AD.

  LDR     INTEGER
          The leading dimension of the array  R.
          LDR >= 2*(M+L)*NOBR.

  A       (input or output) DOUBLE PRECISION array, dimension
          (LDA,N)
          On entry, if  METH = 'N' or 'C'  and  JOB = 'B' or 'D',
          the leading N-by-N part of this array must contain the
          system state matrix.
          If  METH = 'M'  or  (METH = 'N' or 'C'  and JOB = 'A'
          or 'C'),  this array need not be set on input.
          On exit, if  JOB = 'A' or 'C'  and  INFO = 0,  the
          leading N-by-N part of this array contains the system
          state matrix.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= N,  if  JOB = 'A' or 'C',  or  METH = 'N' or 'C'
                         and  JOB = 'B' or 'D';
          LDA >= 1,  otherwise.

  C       (input or output) DOUBLE PRECISION array, dimension
          (LDC,N)
          On entry, if  METH = 'N' or 'C'  and  JOB = 'B' or 'D',
          the leading L-by-N part of this array must contain the
          system output matrix.
          If  METH = 'M'  or  (METH = 'N' or 'C'  and JOB = 'A'
          or 'C'),  this array need not be set on input.
          On exit, if  JOB = 'A' or 'C'  and  INFO = 0,  or
          INFO = 3  (or  INFO >= 0,  for  METH = 'M'),  the leading
          L-by-N part of this array contains the system output
          matrix.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= L,  if  JOB = 'A' or 'C',  or  METH = 'N' or 'C'
                         and  JOB = 'B' or 'D';
          LDC >= 1,  otherwise.

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          If  M > 0,  JOB = 'A', 'B', or 'D'  and  INFO = 0,  the
          leading N-by-M part of this array contains the system
          input matrix. If  M = 0  or  JOB = 'C',  this array is
          not referenced.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= N,  if M > 0 and JOB = 'A', 'B', or 'D';
          LDB >= 1,  if M = 0 or  JOB = 'C'.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          If  M > 0,  JOB = 'A' or 'D'  and  INFO = 0,  the leading
          L-by-M part of this array contains the system input-output
          matrix. If  M = 0  or  JOB = 'C' or 'B',  this array is
          not referenced.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= L,  if M > 0 and JOB = 'A' or 'D';
          LDD >= 1,  if M = 0 or  JOB = 'C' or 'B'.

  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
          If  JOBCK = 'C' or 'K',  the leading N-by-N part of this
          array contains the positive semidefinite state covariance
          matrix. If  JOBCK = 'K',  this matrix has been used as
          state weighting matrix for computing the Kalman gain.
          This parameter is not referenced if JOBCK = 'N'.

  LDQ     INTEGER
          The leading dimension of the array Q.
          LDQ >= N,  if JOBCK = 'C' or 'K';
          LDQ >= 1,  if JOBCK = 'N'.

  RY      (output) DOUBLE PRECISION array, dimension (LDRY,L)
          If  JOBCK = 'C' or 'K',  the leading L-by-L part of this
          array contains the positive (semi)definite output
          covariance matrix. If  JOBCK = 'K',  this matrix has been
          used as output weighting matrix for computing the Kalman
          gain.
          This parameter is not referenced if JOBCK = 'N'.

  LDRY    INTEGER
          The leading dimension of the array RY.
          LDRY >= L,  if JOBCK = 'C' or 'K';
          LDRY >= 1,  if JOBCK = 'N'.

  S       (output) DOUBLE PRECISION array, dimension (LDS,L)
          If  JOBCK = 'C' or 'K',  the leading N-by-L part of this
          array contains the state-output cross-covariance matrix.
          If  JOBCK = 'K',  this matrix has been used as state-
          output weighting matrix for computing the Kalman gain.
          This parameter is not referenced if JOBCK = 'N'.

  LDS     INTEGER
          The leading dimension of the array S.
          LDS >= N,  if JOBCK = 'C' or 'K';
          LDS >= 1,  if JOBCK = 'N'.

  K       (output) DOUBLE PRECISION array, dimension ( LDK,L )
          If  JOBCK = 'K',  the leading  N-by-L  part of this array
          contains the estimated Kalman gain matrix.
          If  JOBCK = 'C' or 'N',  this array is not referenced.

  LDK     INTEGER
          The leading dimension of the array  K.
          LDK >= N,  if JOBCK = 'K';
          LDK >= 1,  if JOBCK = 'C' or 'N'.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  an m-by-n matrix whose estimated
          condition number is less than  1/TOL  is considered to
          be of full rank.  If the user sets  TOL <= 0,  then an
          implicitly computed, default tolerance, defined by
          TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
          relative machine precision (see LAPACK Library routine
          DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= max(LIW1,LIW2), where
          LIW1 = N,                     if METH <> 'N' and M = 0
                                     or JOB = 'C' and JOBCK = 'N';
          LIW1 = M*NOBR+N,              if METH <> 'N', JOB = 'C',
                                        and JOBCK <> 'N';
          LIW1 = max(L*NOBR,M*NOBR),    if METH = 'M', JOB <> 'C',
                                        and JOBCK = 'N';
          LIW1 = max(L*NOBR,M*NOBR+N),  if METH = 'M', JOB <> 'C',
                                        and JOBCK = 'C' or 'K';
          LIW1 = max(M*NOBR+N,M*(N+L)), if METH = 'N', or METH = 'C'
                                        and JOB  <> 'C';
          LIW2 = 0,                     if JOBCK <> 'K';
          LIW2 = N*N,                   if JOBCK =  'K'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK,  and  DWORK(2),  DWORK(3),  DWORK(4),  and
          DWORK(5)  contain the reciprocal condition numbers of the
          triangular factors of the following matrices (defined in
          SLICOT Library routine IB01PD and in the lower level
          routines):
             GaL  (GaL = Un(1:(s-1)*L,1:n)),
             R_1c (if  METH = 'M' or 'C'),
             M    (if  JOBCK = 'C' or 'K'  or  METH = 'N'),  and
             Q or T  (see SLICOT Library routine IB01PY or IB01PX),
          respectively.
          If  METH = 'N',  DWORK(3)  is set to one without any
          calculations. Similarly, if  METH = 'M'  and  JOBCK = 'N',
          DWORK(4)  is set to one. If  M = 0  or  JOB = 'C',
          DWORK(3)  and  DWORK(5)  are set to one.
          If  JOBCK = 'K'  and  INFO = 0,  DWORK(6)  to  DWORK(13)
          contain information about the accuracy of the results when
          computing the Kalman gain matrix, as follows:
             DWORK(6)  - reciprocal condition number of the matrix
                         U11  of the Nth order system of algebraic
                         equations from which the solution matrix  X
                         of the Riccati equation is obtained;
             DWORK(7)  - reciprocal pivot growth factor for the LU
                         factorization of the matrix  U11;
             DWORK(8)  - reciprocal condition number of the matrix
                         As = A - S*inv(Ry)*C,  which is inverted by
                         the standard Riccati solver;
             DWORK(9)  - reciprocal pivot growth factor for the LU
                         factorization of the matrix  As;
             DWORK(10) - reciprocal condition number of the matrix
                         Ry;
             DWORK(11) - reciprocal condition number of the matrix
                         Ry + C*X*C';
             DWORK(12) - reciprocal condition number for the Riccati
                         equation solution;
             DWORK(13) - forward error bound for the Riccati
                         equation solution.
          On exit, if  INFO = -30,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( LDW1,LDW2,LDW3 ), where, if METH = 'M',
          LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ),
                  if JOB = 'C' or JOB = 'A' and M = 0;
          LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N,
                       (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+
                       max( L+M*NOBR, L*NOBR +
                                      max( 3*L*NOBR+1, M ) ) ),
                  if M > 0 and JOB = 'A', 'B', or 'D';
          LDW2 >= 0,                          if JOBCK = 'N';
          LDW2 >= L*NOBR*N+
                  max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L),
                       4*(M*NOBR+N)+1, M*NOBR+2*N+L ),
                                              if JOBCK = 'C' or 'K',
          where Aw = N+N*N, if M = 0 or JOB = 'C';
                Aw = 0,     otherwise;
          if METH = 'N',
          LDW1 >= L*NOBR*N+max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L,
                                2*(L*NOBR-L)*N+N*N+8*N,
                                N+4*(M*NOBR+N)+1, M*NOBR+3*N+L );
          LDW2 >= 0, if M = 0 or JOB = 'C';
          LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+
                             max( (N+L)**2, 4*M*(N+L)+1 ),
                  if M > 0 and JOB = 'A', 'B', or 'D';
          and, if METH = 'C', LDW1 as
          max( LDW1 for METH = 'M', JOB = 'C', LDW1 for METH = 'N'),
          and LDW2 for METH = 'N' are used;
          LDW3 >= 0,                     if JOBCK <> 'K';
          LDW3 >= max(  4*N*N+2*N*L+L*L+max( 3*L,N*L ),
                       14*N*N+12*N+5 ),  if JOBCK =  'K'.
          For good performance,  LDWORK  should be larger.

  BWORK   LOGICAL array, dimension (LBWORK)
          LBWORK = 2*N, if JOBCK =  'K';
          LBWORK = 0,   if JOBCK <> 'K'.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  a least squares problem to be solved has a
                rank-deficient coefficient matrix;
          = 5:  the computed covariance matrices are too small.
                The problem seems to be a deterministic one; the
                gain matrix is set to zero.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 2:  the singular value decomposition (SVD) algorithm did
                not converge;
          = 3:  a singular upper triangular matrix was found;
          = 3+i:  if  JOBCK = 'K'  and the associated Riccati
                equation could not be solved, where i = 1,...,6;
                (see the description of the parameter INFO for the
                SLICOT Library routine SB02RD for the meaning of
                the i values);
          = 10: the QR algorithm did not converge.
Method 
  In the MOESP approach, the matrices  A  and  C  are first
  computed from an estimated extended observability matrix [1],
  and then, the matrices  B  and  D  are obtained by solving an
  extended linear system in a least squares sense.
  In the N4SID approach, besides the estimated extended
  observability matrix, the solutions of two least squares problems
  are used to build another least squares problem, whose solution
  is needed to compute the system matrices  A,  C,  B,  and  D.  The
  solutions of the two least squares problems are also optionally
  used by both approaches to find the covariance matrices.
  The Kalman gain matrix is obtained by solving a discrete-time
  algebraic Riccati equation.
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error
      state-space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Van Overschee, P., and De Moor, B.
      N4SID: Two Subspace Algorithms for the Identification
      of Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [3] Van Overschee, P.
      Subspace Identification : Theory - Implementation -
      Applications.
      Ph. D. Thesis, Department of Electrical Engineering,
      Katholieke Universiteit Leuven, Belgium, Feb. 1995.

  [4] Sima, V.
      Subspace-based Algorithms for Multivariable System
      Identification.
      Studies in Informatics and Control, 5, pp. 335-344, 1996.
Numerical Aspects 
  The implemented method consists in numerically stable steps.
Further Comments 
  The covariance matrices are computed using the N4SID approach.
  Therefore, for efficiency reasons, it is advisable to set
  METH = 'N',  if the Kalman gain matrix or covariance matrices
  are needed  (JOBCK = 'K', or 'C').  When  JOBCK = 'N',  it could
  be more efficient to use the combined method,  METH = 'C'.
  Often, this combination will also provide better accuracy than
  MOESP algorithm.
  In some applications, it is useful to compute the system matrices
  using two calls to this routine, the first one with  JOB = 'C',
  and the second one with  JOB = 'B' or 'D'.  This is slightly less
  efficient than using a single call with  JOB = 'A',  because some
  calculations are repeated. If  METH = 'N',  all the calculations
  at the first call are performed again at the second call;
  moreover, it is required to save the needed submatrices of  R
  before the first call and restore them before the second call.
  If the covariance matrices and/or the Kalman gain are desired,
  JOBCK  should be set to  'C'  or  'K'  at the second call.
  If  B  and  D  are both needed, they should be computed at once.
Example

Program Text 

*     IB01BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LDA, LDB, LDC, LDD, LDK, LDQ, LDR, LDRY, LDS,
     $                 LDU, LDW1, LDW2, LDW3, LDWORK, LDY, LIWORK, LMAX,
     $                 MMAX, NMAX, NOBRMX, NSMPMX
      PARAMETER        ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000,
     $                   NMAX = NOBRMX - 1, LDA = NMAX, LDB = NMAX,
     $                   LDC  = LMAX, LDD  = LMAX, LDK = NMAX,
     $                   LDQ  = NMAX, LDRY = LMAX, LDS = NMAX,
     $                   LDR  = MAX( 2*( MMAX + LMAX )*NOBRMX,
     $                               3*MMAX*NOBRMX ), LDU = NSMPMX,
     $                   LDW1 = MAX( LMAX*( NOBRMX - 1 )*NMAX + NMAX +
     $                               MAX( 6*MMAX, 4*LMAX )*NOBRMX,
     $                               LMAX*NOBRMX*NMAX +
     $                               MAX( LMAX*( NOBRMX - 1 )*NMAX +
     $                                    3*NMAX + LMAX +
     $                                    ( 2*MMAX + LMAX )*NOBRMX,
     $                                    2*LMAX*( NOBRMX - 1 )*NMAX +
     $                                    NMAX*NMAX + 8*NMAX,
     $                                    NMAX +
     $                                    4*( MMAX*NOBRMX + NMAX ) ) ),
     $                   LDW2 = LMAX*NOBRMX*NMAX +
     $                          MMAX*NOBRMX*( NMAX + LMAX )*
     $                          ( MMAX*( NMAX + LMAX ) + 1 ) +
     $                          MAX( ( NMAX + LMAX )**2,
     $                          4*MMAX*( NMAX + LMAX ) + 1 ),
     $                   LDW3 = MAX( 4*NMAX*NMAX + 2*NMAX*LMAX +
     $                               LMAX*LMAX +
     $                               MAX( 3*LMAX, NMAX*LMAX ),
     $                               14*NMAX*NMAX + 12*NMAX + 5 ),
     $                   LDWORK = MAX( 6*( MMAX + LMAX )*NOBRMX,
     $                                 ( MMAX + LMAX )*( 4*NOBRMX*
     $                                 ( MMAX + LMAX + 2 ) - 2 ),
     $                                 ( MMAX + LMAX )*4*NOBRMX*
     $                                 ( NOBRMX + 1 ), LDW1, LDW2,
     $                                 LDW3 ),
     $                   LDY = NSMPMX,
     $                   LIWORK = MAX( ( MMAX + LMAX )*NOBRMX,
     $                                 MMAX*NOBRMX + NMAX, LMAX*NOBRMX,
     $                                 MMAX*( NMAX + LMAX ), NMAX*NMAX )
     $                 )
*     .. Local Scalars ..
      LOGICAL          NGIVEN
      CHARACTER        ALG, BATCH, CONCT, CTRL, JOB, JOBCK, JOBD, JOBDA,
     $                 METH, METHA
      INTEGER          I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE,
     $                 NGIV, NOBR, NSAMPL, NSMP
      DOUBLE PRECISION RCOND, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), B(LDB, MMAX), C(LDC, NMAX),
     $                 D(LDD, MMAX), DWORK(LDWORK), K(LDK, LMAX),
     $                 Q(LDQ, NMAX), R(LDR, 2*(MMAX+LMAX)*NOBRMX),
     $                 RY(LDRY, LMAX), S(LDS, LMAX), SV(LMAX*NOBRMX),
     $                 U(LDU, MMAX), Y(LDY, LMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(2*NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         IB01AD, IB01BD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
*     If the value of N is positive, it will be taken as system order.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL
      READ ( NIN, FMT = * ) METH, ALG, JOBD, BATCH, CONCT, CTRL, JOB,
     $                      JOBCK
      IF ( LSAME( BATCH, 'F' ) ) THEN
         READ ( NIN, FMT = * ) NCYCLE
      ELSE
         NCYCLE = 1
      END IF
      NSAMPL = NCYCLE*NSMP
*
      NGIVEN = N.GT.0
      IF( NGIVEN )
     $   NGIV = N
      IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN
         WRITE ( NOUT, FMT = 99997 ) NOBR
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99996 ) M
      ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) L
      ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR.
     $        ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'O' ) ) .OR.
     $        ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'L' ) ) .OR.
     $          NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR.
     $                                 LSAME( BATCH, 'I' ) ) ) THEN
         WRITE ( NOUT, FMT = 99994 ) NSMP
      ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NCYCLE
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99980 ) N
      ELSE
*        Read the matrices U and Y from the input file.
         IF ( M.GT.0 )
     $      READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1, M ), I = 1, NSAMPL )
         READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL )
*        Read A and C matrices, if METH <> 'M' and JOB = 'B' or 'D'.
         IF ( .NOT.LSAME( METH, 'M' ) .AND.
     $           ( LSAME( JOB,  'B' ) .OR. LSAME( JOB, 'D' ) ) ) THEN
            DO 10 I = 1, N
               READ ( NIN, FMT = * ) ( A(I,J), J = 1, N )
   10       CONTINUE
            DO 20 I = 1, L
               READ ( NIN, FMT = * ) ( C(I,J), J = 1, N )
   20       CONTINUE
         END IF
*        Force some options for IB01AD, depending on the specifications.
         IF ( LSAME( METH, 'C' ) ) THEN
            METHA = 'M'
            JOBDA = 'N'
         ELSE
            METHA = METH
            JOBDA = JOBD
         END IF
*        Compute the  R  factor from a QR (or Cholesky) factorization
*        of the Hankel-like matrix (or correlation matrix).
         DO 30 ICYCLE = 1, NCYCLE
            II = ( ICYCLE - 1 )*NSMP + 1
            IF ( NCYCLE.GT.1 ) THEN
               IF ( ICYCLE.GT.1 )      BATCH = 'I'
               IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L'
            END IF
            CALL IB01AD( METHA, ALG, JOBDA, BATCH, CONCT, CTRL, NOBR, M,
     $                   L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR,
     $                   SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN,
     $                   INFO )
   30    CONTINUE
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 )
     $         WRITE ( NOUT, FMT = 99990 ) IWARN
            IF( NGIVEN )
     $         N = NGIV
*           Compute the system matrices.
            CALL IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMP, R,
     $                   LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ,
     $                   RY, LDRY, S, LDS, K, LDK, RCOND, IWORK, DWORK,
     $                   LDWORK, BWORK, IWARN, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99992 ) INFO
            ELSE
               IF ( IWARN.NE.0 )
     $            WRITE ( NOUT, FMT = 99991 ) IWARN
               IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN
                  WRITE ( NOUT, FMT = 99989 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99988 ) ( A(I,J), J = 1,N )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99987 )
                  DO 50 I = 1, L
                     WRITE ( NOUT, FMT = 99988 ) ( C(I,J), J = 1,N )
   50             CONTINUE
               END IF
               IF ( .NOT.LSAME( JOB, 'C' ) ) THEN
                  WRITE ( NOUT, FMT = 99986 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99988 ) ( B(I,J), J = 1,M )
   60             CONTINUE
               END IF
               IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'D' ) ) THEN
                  WRITE ( NOUT, FMT = 99985 )
                  DO 70 I = 1, L
                     WRITE ( NOUT, FMT = 99988 ) ( D(I,J), J = 1,M )
   70             CONTINUE
               END IF
               IF ( LSAME( JOBCK, 'K' ) ) THEN
                  WRITE ( NOUT, FMT = 99984 )
                  DO 80 I = 1, N
                     WRITE ( NOUT, FMT = 99988 ) ( K(I,J), J = 1,L )
   80             CONTINUE
               END IF
               IF ( .NOT.LSAME( JOBCK, 'N' ) ) THEN
                  WRITE ( NOUT, FMT = 99983 )
                  DO 90 I = 1, N
                     WRITE ( NOUT, FMT = 99988 ) ( Q(I,J), J = 1,N )
   90             CONTINUE
                  WRITE ( NOUT, FMT = 99982 )
                  DO 100 I = 1, L
                     WRITE ( NOUT, FMT = 99988 ) ( RY(I,J), J = 1,L )
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99981 )
                  DO 110 I = 1, N
                     WRITE ( NOUT, FMT = 99988 ) ( S(I,J), J = 1,L )
  110             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
99999 FORMAT ( ' IB01BD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT ( ' INFO on exit from IB01AD = ',I2)
99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5)
99996 FORMAT (/' M is out of range.',/' M = ', I5)
99995 FORMAT (/' L is out of range.',/' L = ', I5)
99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5)
99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5)
99992 FORMAT ( ' INFO on exit from IB01BD = ',I2)
99991 FORMAT ( ' IWARN on exit from IB01BD = ',I2)
99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2)
99989 FORMAT (/' The system state matrix A is ')
99988 FORMAT (20(1X,F8.4))
99987 FORMAT (/' The system output matrix C is ')
99986 FORMAT (/' The system input matrix B is ')
99985 FORMAT (/' The system input-output matrix D is ')
99984 FORMAT (/' The Kalman gain matrix K is ')
99983 FORMAT (/' The state covariance matrix Q is ')
99982 FORMAT (/' The output covariance matrix Ry is ')
99981 FORMAT (/' The state-output cross-covariance matrix S is ')
99980 FORMAT (/' N is out of range.',/' N = ', I5)
      END
Program Data 
 IB01BD EXAMPLE PROGRAM DATA
  15     0     1     1  1000    0.0   -1.0
   C     C     N     O     N     N     A     K
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   4.766099
   4.763659
   4.839359
   5.002979
   5.017629
   5.056699
   5.154379
   5.361949
   5.425439
   5.569519
   5.681849
   5.742899
   5.803949
   5.918729
   5.821049
   5.447419
   5.061589
   4.629349
   4.267939
   4.011519
   3.850349
   3.711159
   3.569519
   3.518239
   3.652549
   3.818609
   3.862559
   4.011519
   4.353409
   4.705049
   5.083559
   5.344859
   5.274039
   5.127519
   4.761219
   4.451089
   4.221539
   4.045709
   3.874769
   3.730689
   3.662319
   3.576849
   3.542659
   3.479169
   3.454749
   3.359509
   3.298459
   3.225199
   3.200779
   3.225199
   3.227639
   3.274039
   3.457189
   3.867449
   4.321659
   4.492599
   4.431549
   4.243519
   4.050599
   3.857679
   3.730689
   3.791739
   3.921169
   3.955359
   3.847909
   3.725809
   3.611039
   3.716039
   4.092109
   4.480389
   4.814939
   5.054259
   5.303339
   5.486489
   5.672089
   5.779529
   5.799069
   5.664759
   5.291129
   4.880879
   4.558529
   4.184909
   3.889419
   3.708719
   3.623249
   3.569519
   3.718479
   4.033499
   4.412009
   4.629349
   4.558529
   4.394919
   4.180019
   4.197119
   4.431549
   4.714819
   4.961459
   5.300899
   5.567079
   5.681849
   5.545099
   5.188569
   4.883319
   4.600049
   4.270379
   4.038389
   3.838139
   3.711159
   3.591499
   3.535329
   3.486489
   3.476729
   3.425439
   3.381489
   3.369279
   3.364389
   3.347299
   3.381489
   3.420559
   3.413229
   3.452309
   3.635459
   4.038389
   4.375379
   4.727029
   5.056699
   5.298459
   5.532889
   5.466959
   5.195899
   4.885759
   4.763659
   4.875989
   5.042049
   5.283809
   5.491379
   5.596379
   5.672089
   5.772209
   5.830819
   5.933379
   5.899189
   5.935819
   5.894309
   5.918729
   5.994429
   5.957799
   6.031059
   6.062809
   6.040829
   6.096999
   6.123859
   6.162929
   6.040829
   5.845469
   5.772209
   5.799069
   5.923609
   5.928499
   6.001759
   6.001759
   6.060369
   5.882099
   5.510909
   5.322879
   5.371719
   5.454749
   5.437649
   5.159269
   4.902859
   4.587839
   4.502369
   4.595159
   4.824709
   5.064029
   5.271599
   5.466959
   5.615919
   5.528009
   5.254499
   4.883319
   4.517019
   4.197119
   4.001759
   3.806399
   3.904079
   3.923609
   3.869889
   3.806399
   3.720929
   3.818609
   4.140949
   4.529229
   4.805179
   5.086009
   5.339969
   5.532889
   5.576849
   5.667199
   5.791739
   5.850349
   5.923609
   5.921169
   5.977339
   5.740459
   5.388809
   5.000539
   4.849129
   4.944369
   5.173919
   5.369279
   5.447419
   5.603709
   5.730689
   5.850349
   5.979779
   5.991989
   6.084789
   5.940709
   5.803949
   5.791739
   5.603709
   5.264269
   4.946809
   4.619579
   4.514579
   4.433989
   4.285029
   4.121419
   3.945589
   3.984659
   4.219099
   4.546319
   4.873549
   5.154379
   5.388809
   5.613479
   5.835699
   5.884539
   5.955359
   5.762439
   5.459629
   5.061589
   4.707499
   4.458409
   4.267939
   4.053039
   3.943149
   3.825929
   3.967569
   4.280149
   4.480389
   4.492599
   4.390039
   4.197119
   4.111649
   3.982219
   3.867449
   3.767319
   3.872329
   4.236189
   4.663539
   4.971229
   5.066469
   4.902859
   4.675749
   4.392479
   4.099439
   4.114089
   4.326539
   4.643999
   4.971229
   5.159269
   5.388809
   5.576849
   5.652549
   5.803949
   5.913839
   5.886979
   5.799069
   5.730689
   5.762439
   5.813719
   5.821049
   5.928499
   6.013969
   5.764879
   5.413229
   5.098219
   4.678189
   4.372939
   4.392479
   4.590279
   4.919949
   5.017629
   4.858899
   4.675749
   4.619579
   4.834479
   5.090889
   5.376599
   5.681849
   5.823489
   5.952919
   6.062809
   6.089669
   6.075019
   6.026179
   5.994429
   6.077459
   5.857679
   5.701389
   5.730689
   5.784419
   5.823489
   5.894309
   5.762439
   5.415679
   4.961459
   4.595159
   4.331429
   4.297239
   4.582949
   4.861339
   5.173919
   5.166589
   4.919949
   4.607369
   4.370499
   4.182469
   4.038389
   4.145839
   4.431549
   4.556089
   4.480389
   4.375379
   4.370499
   4.558529
   4.858899
   4.895529
   4.741679
   4.744129
   4.875989
   5.105539
   5.239849
   5.518239
   5.652549
   5.723369
   5.855239
   5.962679
   5.984659
   5.984659
   6.055479
   6.062809
   6.055479
   6.070129
   5.784419
   5.440099
   5.056699
   4.941929
   5.010299
   5.134849
   5.313109
   5.479169
   5.623249
   5.562199
   5.330209
   5.010299
   4.665979
   4.414459
   4.201999
   4.048159
   4.079899
   4.189789
   4.131179
   4.004199
   3.916289
   3.960239
   4.199559
   4.624469
   4.883319
   5.137289
   5.379049
   5.623249
   5.762439
   5.833259
   5.686739
   5.366839
   5.225199
   5.239849
   5.354629
   5.508469
   5.596379
   5.752669
   5.874769
   5.906519
   5.894309
   5.742899
   5.447419
   5.024959
   4.883319
   4.885759
   4.893089
   4.714819
   4.451089
   4.233749
   4.043269
   3.864999
   3.757559
   3.669639
   3.593939
   3.547539
   3.506029
   3.454749
   3.398579
   3.361949
   3.339969
   3.374159
   3.520679
   3.713599
   3.757559
   3.779529
   3.696509
   3.777089
   3.886979
   3.904079
   3.850349
   3.965129
   4.282589
   4.521899
   4.714819
   4.971229
   5.220319
   5.532889
   5.652549
   5.781979
   5.955359
   6.035939
   6.118969
   6.133629
   6.153159
   6.192229
   6.143389
   6.167809
   5.991989
   5.652549
   5.459629
   5.437649
   5.339969
   5.098219
   4.785639
   4.492599
   4.236189
   4.067689
   3.933379
   3.823489
   3.730689
   3.611039
   3.564639
   3.549989
   3.557309
   3.513359
   3.515799
   3.694059
   4.072579
   4.480389
   4.705049
   4.612259
   4.385149
   4.201999
   4.026179
   3.904079
   3.774649
   3.691619
   3.845469
   4.201999
   4.585399
   4.902859
   5.256949
   5.510909
   5.640339
   5.843029
   5.974889
   5.935819
   5.821049
   5.528009
   5.171479
   4.810059
   4.453529
   4.380269
   4.565859
   4.805179
   5.125079
   5.354629
   5.589059
   5.764879
   5.923609
   5.940709
   5.857679
   5.694059
   5.486489
   5.149499
   4.844249
   4.541439
   4.267939
   4.060369
   3.960239
   3.789299
   3.642779
   3.525569
   3.498699
   3.454749
   3.408349
   3.379049
   3.376599
   3.361949
   3.359509
   3.369279
   3.398579
   3.579289
   3.948029
   4.412009
   4.585399
   4.514579
   4.343639
   4.155599
   3.984659
   4.043269
   4.307009
   4.421779
   4.353409
   4.223979
   4.053039
   3.940709
   3.838139
   3.730689
   3.652549
   3.611039
   3.564639
   3.496259
   3.462069
   3.454749
   3.425439
   3.379049
   3.432769
   3.623249
   3.974889
   4.380269
   4.714819
   5.073799
   5.369279
   5.603709
   5.745349
   5.652549
   5.401019
   5.015189
   4.709939
   4.416899
   4.236189
   4.236189
   4.248399
   4.221539
   4.297239
   4.590279
   4.893089
   5.134849
   5.427889
   5.379049
   5.364389
   5.452309
   5.567079
   5.672089
   5.769769
   5.830819
   5.923609
   5.965129
   6.057919
   6.050599
   6.072579
   6.111649
   6.070129
   5.896749
   5.755109
   5.718479
   5.821049
   6.001759
   6.001759
   5.901629
   5.557309
   5.173919
   4.800289
   4.431549
   4.194679
   4.006639
   3.850349
   3.747789
   3.642779
   3.591499
   3.569519
   3.528009
   3.537779
   3.554869
   3.493819
   3.447419
   3.440099
   3.408349
   3.410789
   3.452309
   3.681849
   4.060369
   4.441319
   4.854019
   5.154379
   5.425439
   5.596379
   5.586619
   5.354629
   5.027399
   4.863779
   4.761219
   4.570739
   4.368059
   4.397359
   4.573189
   4.841809
   5.203219
   5.452309
   5.652549
   5.855239
   5.906519
   5.952919
   5.828369
   5.791739
   5.799069
   5.813719
   5.877209
   5.955359
   5.781979
   5.518239
   5.127519
   4.763659
   4.492599
   4.233749
   4.011519
   3.855239
   3.691619
   3.635459
   3.818609
   4.155599
   4.590279
   4.988329
   5.076239
   4.907739
   4.648889
   4.377829
   4.216649
   4.287469
   4.590279
   4.846689
   5.139729
   5.388809
   5.689179
   5.884539
   6.043269
   6.170259
   6.211769
   6.250839
   6.209329
   6.013969
   5.701389
   5.469399
   5.479169
   5.557309
   5.728249
   5.882099
   5.984659
   5.901629
   5.581729
   5.371719
   5.418119
   5.510909
   5.667199
   5.791739
   5.698949
   5.484049
   5.154379
   4.980999
   5.061589
   5.195899
   5.359509
   5.615919
   5.762439
   5.857679
   5.948029
   5.835699
   5.706269
   5.498699
   5.188569
   5.117749
   5.191009
   5.315549
   5.532889
   5.444979
   5.396139
   5.274039
   5.027399
   4.744129
   4.668419
   4.651329
   4.514579
   4.267939
   4.260609
   4.263049
   4.189789
   4.277699
   4.600049
   4.932159
   5.283809
   5.528009
   5.740459
   5.874769
   5.955359
   5.991989
   5.845469
   5.528009
   5.061589
   4.734359
   4.534109
   4.534109
   4.697729
   4.744129
   4.619579
   4.643999
   4.832039
   5.132399
   5.410789
   5.625689
   5.603709
   5.315549
   4.961459
   4.619579
   4.358289
   4.155599
   4.033499
   3.886979
   3.772209
   3.640339
   3.532889
   3.435209
   3.427889
   3.422999
   3.398579
   3.603709
   4.023729
   4.451089
   4.792969
   4.902859
   4.780759
   4.590279
   4.336309
   4.145839
   4.216649
   4.433989
   4.714819
   5.098219
   5.359509
   5.569519
   5.772209
   5.921169
   6.055479
   5.962679
   5.642779
   5.435209
   5.388809
   5.537779
   5.681849
   5.701389
   5.615919
   5.667199
   5.740459
   5.803949
   5.882099
   5.950469
   6.072579
   6.148279
   6.116529
   6.177579
   6.201999
   6.206889
   5.991989
   5.564639
   5.178799
   4.998089
   5.051819
   5.232529
   5.484049
   5.686739
   5.899189
   5.869889
   5.977339
   6.053039
   6.079899
   6.128739
   6.079899
   6.167809
   6.194679
   6.236189
   6.053039
   5.652549
   5.274039
   4.858899
   4.534109
   4.455969
   4.619579
   4.866229
   5.117749
   5.166589
   5.056699
   5.002979
   5.098219
   5.325319
   5.567079
   5.466959
   5.252059
   4.946809
   4.880879
   4.980999
   5.225199
   5.459629
   5.723369
   5.791739
   5.906519
   5.991989
   5.835699
   5.528009
   5.142169
   4.775869
   4.490159
   4.236189
   4.023729
   3.886979
   3.752669
   3.681849
   3.806399
   4.145839
   4.600049
   5.002979
   5.303339
   5.552429
   5.615919
   5.523119
   5.611039
   5.713599
   5.845469
   5.899189
   5.994429
   6.092109
   6.092109
   6.143389
   6.153159
   6.233749
   6.187349
   6.013969
   5.835699
   5.774649
   5.686739
   5.537779
   5.327759
   5.054259
   4.700169
   4.394919
   4.180019
   4.043269
   3.877209
   3.752669
   3.728249
   3.869889
   4.206889
   4.355849
   4.426669
   4.453529
   4.521899
   4.392479
   4.155599
   3.965129
   3.877209
   3.970009
   4.258169
   4.421779
   4.336309
   4.299679
   4.392479
   4.675749
   4.761219
   4.658659
   4.490159
   4.307009
   4.126299
   3.972449
   4.077459
   4.372939
   4.741679
   5.088449
   5.186129
   5.037169
   4.785639
   4.563419
   4.534109
   4.705049
   4.741679
   4.648889
   4.431549
   4.238629
   4.065249
   3.943149
   3.811279
   3.691619
   3.652549
   3.825929
   4.223979
   4.424219
   4.429109
   4.319219
   4.138509
   3.965129
   3.886979
   3.801509
   3.701389
   3.640339
   3.767319
   4.150719
   4.648889
   4.990769
   5.088449
   5.022509
   4.783199
   4.685519
   4.665979
   4.707499
   4.912619
   5.195899
   5.415679
   5.623249
   5.740459
   5.899189
   5.928499
   6.050599
   6.153159
   5.965129
   5.586619
   5.381489
   5.371719
   5.486489
   5.567079
   5.821049
   5.913839
   5.994429
   6.011519
   5.999309
   6.018849
   5.821049
   5.728249
   5.740459
   5.764879
   5.882099
   5.926049
   5.750229
   5.415679
   4.995649
   4.861339
   4.902859
   5.103099
   5.364389
   5.596379
   5.752669
   5.845469
   5.928499
   6.006639
   5.840579
   5.518239
   5.173919
   4.739239
   4.458409
   4.426669
   4.602489
   4.822269
   5.183689
   5.430329
   5.652549
   5.821049
   5.706269
   5.369279
   5.027399
   4.705049
   4.414459
   4.145839
   3.965129
   4.033499
   4.372939
   4.683079
Program Results 
 IB01BD EXAMPLE PROGRAM RESULTS


 The system state matrix A is 
   0.8924   0.3887   0.1285   0.1716
  -0.0837   0.6186  -0.6273  -0.4582
   0.0052   0.1307   0.6685  -0.6755
   0.0055   0.0734  -0.2148   0.4788

 The system output matrix C is 
  -0.4442   0.6663   0.3961   0.4102

 The system input matrix B is 
  -0.2142
  -0.1968
   0.0525
   0.0361

 The system input-output matrix D is 
  -0.0041

 The Kalman gain matrix K is 
  -1.9513
  -0.1867
   0.6348
  -0.3486

 The state covariance matrix Q is 
   0.0052   0.0005  -0.0017   0.0009
   0.0005   0.0000  -0.0002   0.0001
  -0.0017  -0.0002   0.0006  -0.0003
   0.0009   0.0001  -0.0003   0.0002

 The output covariance matrix Ry is 
   0.0012

 The state-output cross-covariance matrix S is 
  -0.0025
  -0.0002
   0.0008
  -0.0005

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/IB01CD.html000077500000000000000000001534471201767322700160640ustar00rootroot00000000000000 IB01CD - SLICOT Library Routine Documentation

IB01CD

Estimating the initial state and system matrices B and D using A, B, and input-output data (driver)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the initial state and, optionally, the system matrices
  B  and  D  of a linear time-invariant (LTI) discrete-time system,
  given the system matrices  (A,B,C,D),  or (when  B  and  D  are
  estimated) only the matrix pair  (A,C),  and the input and output
  trajectories of the system. The model structure is :

        x(k+1) = Ax(k) + Bu(k),   k >= 0,
        y(k)   = Cx(k) + Du(k),

  where  x(k)  is the  n-dimensional state vector (at time k),
         u(k)  is the  m-dimensional input vector,
         y(k)  is the  l-dimensional output vector,
  and  A, B, C, and D  are real matrices of appropriate dimensions.
  The input-output data can internally be processed sequentially.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOBX0   CHARACTER*1
          Specifies whether or not the initial state should be
          computed, as follows:
          = 'X':  compute the initial state x(0);
          = 'N':  do not compute the initial state (possibly,
                  because x(0) is known to be zero).

  COMUSE  CHARACTER*1
          Specifies whether the system matrices B and D should be
          computed or used, as follows:
          = 'C':  compute the system matrices B and D, as specified
                  by JOB;
          = 'U':  use the system matrices B and D, as specified by
                  JOB;
          = 'N':  do not compute/use the matrices B and D.
          If  JOBX0 = 'N'  and  COMUSE <> 'N',  then  x(0)  is set
          to zero.
          If  JOBX0 = 'N'  and  COMUSE =  'N',  then  x(0)  is
          neither computed nor set to zero.

  JOB     CHARACTER*1
          If  COMUSE = 'C'  or  'U',  specifies which of the system
          matrices  B and D  should be computed or used, as follows:
          = 'B':  compute/use the matrix B only (D is known to be
                  zero);
          = 'D':  compute/use the matrices B and D.
          The value of  JOB  is irrelevant if  COMUSE = 'N'  or if
          JOBX0 = 'N'  and  COMUSE = 'U'.
          The combinations of options, the data used, and the
          returned results, are given in the table below, where
          '*'  denotes an irrelevant value.

           JOBX0   COMUSE    JOB     Data used    Returned results
          ----------------------------------------------------------
             X       C        B       A,C,u,y          x,B
             X       C        D       A,C,u,y          x,B,D
             N       C        B       A,C,u,y          x=0,B
             N       C        D       A,C,u,y          x=0,B,D
          ----------------------------------------------------------
             X       U        B      A,B,C,u,y            x
             X       U        D      A,B,C,D,u,y          x
             N       U        *          -               x=0
          ----------------------------------------------------------
             X       N        *        A,C,y              x
             N       N        *          -                -
          ----------------------------------------------------------

          For  JOBX0 = 'N'  and  COMUSE = 'N',  the routine just
          sets  DWORK(1)  to 2 and  DWORK(2)  to 1, and returns
          (see the parameter DWORK).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMP    (input) INTEGER
          The number of rows of matrices  U  and  Y  (number of
          samples,  t).
          NSMP >= 0,            if  JOBX0 = 'N'  and  COMUSE <> 'C';
          NSMP >= N,            if  JOBX0 = 'X'  and  COMUSE <> 'C';
          NSMP >= N*M + a + e,  if  COMUSE = 'C',
          where   a = 0,  if  JOBX0 = 'N';
                  a = N,  if  JOBX0 = 'X';
                  e = 0,  if  JOBX0 = 'X'  and  JOB = 'B';
                  e = 1,  if  JOBX0 = 'N'  and  JOB = 'B';
                  e = M,  if  JOB   = 'D'.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If  JOBX0 = 'X'  or  COMUSE = 'C',  the leading N-by-N
          part of this array must contain the system state matrix A.
          If  N = 0,  or  JOBX0 = 'N'  and  COMUSE <> 'C',  this
          array is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N),  if  JOBX0 = 'X'  or   COMUSE =  'C';
          LDA >= 1,         if  JOBX0 = 'N'  and  COMUSE <> 'C'.

  B       (input or output) DOUBLE PRECISION array, dimension
          (LDB,M)
          If  JOBX0 = 'X'  and  COMUSE = 'U',  B  is an input
          parameter and, on entry, the leading N-by-M part of this
          array must contain the system input matrix  B.
          If  COMUSE = 'C',  B  is an output parameter and, on exit,
          if  INFO = 0,  the leading N-by-M part of this array
          contains the estimated system input matrix  B.
          If  min(N,M) = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',
          or  COMUSE = 'N',  this array is not referenced.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N),  if  M > 0,  COMUSE = 'U',  JOBX0 = 'X',
                            or  M > 0,  COMUSE = 'C';
          LDB >= 1,         if  min(N,M) = 0,  or  COMUSE = 'N',
                            or  JOBX0  = 'N'  and  COMUSE = 'U'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          If  JOBX0 = 'X'  or  COMUSE = 'C',  the leading L-by-N
          part of this array must contain the system output
          matrix  C.
          If  N = 0,  or  JOBX0 = 'N'  and  COMUSE <> 'C',  this
          array is not referenced.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= L,  if  N > 0, and  JOBX0 = 'X'  or  COMUSE = 'C';
          LDC >= 1,  if  N = 0, or  JOBX0 = 'N'  and  COMUSE <> 'C'.

  D       (input or output) DOUBLE PRECISION array, dimension
          (LDD,M)
          If  JOBX0 = 'X',  COMUSE = 'U',  and  JOB = 'D',  D  is an
          input parameter and, on entry, the leading L-by-M part of
          this array must contain the system input-output matrix  D.
          If  COMUSE = 'C'  and  JOB = 'D',  D  is an output
          parameter and, on exit, if  INFO = 0,  the leading
          L-by-M part of this array contains the estimated system
          input-output matrix  D.
          If  M = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',  or
          COMUSE = 'N',  or  JOB = 'B',  this array is not
          referenced.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= L,  if  M > 0,   JOBX0 = 'X',  COMUSE = 'U',  and
                                                JOB = 'D',  or
                     if  M > 0,  COMUSE = 'C',  and  JOB = 'D';
          LDD >= 1,  if  M = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',
                     or  COMUSE = 'N',  or  JOB = 'B'.

  U       (input or input/output) DOUBLE PRECISION array, dimension
          (LDU,M)
          On entry, if  COMUSE = 'C',  or  JOBX0 = 'X'  and
          COMUSE = 'U',  the leading NSMP-by-M part of this array
          must contain the t-by-m input-data sequence matrix  U,
          U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
          NSMP  values of the j-th input component for consecutive
          time increments.
          On exit, if  COMUSE = 'C'  and  JOB = 'D',  the leading
          NSMP-by-M part of this array contains details of the
          QR factorization of the t-by-m matrix  U,  possibly
          computed sequentially (see METHOD).
          If  COMUSE = 'C'  and  JOB = 'B',  or  COMUSE = 'U',  this
          array is unchanged on exit.
          If  M = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',  or
          COMUSE = 'N',  this array is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= MAX(1,NSMP),  if  M > 0    and  COMUSE = 'C'  or
                               JOBX0 = 'X'  and  COMUSE = 'U;
          LDU >= 1,            if  M = 0,   or   COMUSE = 'N',  or
                               JOBX0 = 'N'  and  COMUSE = 'U'.

  Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
          On entry, if  JOBX0 = 'X'  or  COMUSE = 'C',  the leading
          NSMP-by-L part of this array must contain the t-by-l
          output-data sequence matrix  Y,  Y = [y_1 y_2 ... y_l].
          Column  j  of  Y  contains the  NSMP  values of the j-th
          output component for consecutive time increments.
          If  JOBX0 = 'N'  and  COMUSE <> 'C',  this array is not
          referenced.

  LDY     INTEGER
          The leading dimension of the array Y.
          LDY >= MAX(1,NSMP),  if  JOBX0 = 'X'  or   COMUSE = 'C;
          LDY >= 1,            if  JOBX0 = 'N'  and  COMUSE <> 'C'.

  X0      (output) DOUBLE PRECISION array, dimension (N)
          If  INFO = 0  and  JOBX0 = 'X',  this array contains the
          estimated initial state of the system,  x(0).
          If  JOBX0 = 'N'  and  COMUSE = 'C',  this array is used as
          workspace and finally it is set to zero.
          If  JOBX0 = 'N'  and  COMUSE = 'U',  then  x(0)  is set to
          zero without any calculations.
          If  JOBX0 = 'N'  and  COMUSE = 'N',  this array is not
          referenced.

  V       (output) DOUBLE PRECISION array, dimension (LDV,N)
          On exit, if  INFO = 0  or 2,  JOBX0 = 'X'  or
          COMUSE = 'C',  the leading N-by-N part of this array
          contains the orthogonal matrix V of a real Schur
          factorization of the matrix  A.
          If  JOBX0 = 'N'  and  COMUSE <> 'C',  this array is not
          referenced.

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= MAX(1,N),  if  JOBX0 = 'X'  or   COMUSE =  'C;
          LDV >= 1,         if  JOBX0 = 'N'  and  COMUSE <> 'C'.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  a matrix whose estimated condition
          number is less than  1/TOL  is considered to be of full
          rank.  If the user sets  TOL <= 0,  then  EPS  is used
          instead, where  EPS  is the relative machine precision
          (see LAPACK Library routine DLAMCH).  TOL <= 1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK), where
          LIWORK >= 0,          if  JOBX0 = 'N'  and  COMUSE <> 'C';
          LIWORK >= N,          if  JOBX0 = 'X'  and  COMUSE <> 'C';
          LIWORK >= N*M + a,        if COMUSE = 'C' and JOB = 'B',
          LIWORK >= max(N*M + a,M), if COMUSE = 'C' and JOB = 'D',
          with  a = 0,  if  JOBX0 = 'N';
                a = N,  if  JOBX0 = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK;  DWORK(2)  contains the reciprocal condition
          number of the triangular factor of the QR factorization of
          the matrix  W2,  if  COMUSE = 'C',  or of the matrix
          Gamma,  if  COMUSE = 'U'  (see METHOD); if  JOBX0 = 'N'
          and  COMUSE <> 'C',  DWORK(2)  is set to one;
          if  COMUSE = 'C',  M > 0,  and  JOB = 'D',   DWORK(3)
          contains the reciprocal condition number of the triangular
          factor of the QR factorization of  U;  denoting
             g = 2,  if  JOBX0  = 'X'  and  COMUSE <> 'C'  or
                         COMUSE = 'C'  and  M = 0  or   JOB = 'B',
             g = 3,  if  COMUSE = 'C'  and  M > 0  and  JOB = 'D',
          then  DWORK(i), i = g+1:g+N*N,
                DWORK(j), j = g+1+N*N:g+N*N+L*N,  and
                DWORK(k), k = g+1+N*N+L*N:g+N*N+L*N+N*M,
          contain the transformed system matrices  At, Ct, and Bt,
          respectively, corresponding to the real Schur form of the
          given system state matrix  A,  i.e.,
             At = V'*A*V,  Bt = V'*B,  Ct = C*V.
          The matrices  At, Ct, Bt  are not computed if  JOBX0 = 'N'
          and  COMUSE <> 'C'.
          On exit, if  INFO = -26,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 2,  if  JOBX0 = 'N'  and  COMUSE <> 'C',  or
                        if  max( N, M ) = 0.
          Otherwise,
          LDWORK >= LDW1 + N*( N + M + L ) +
                           max( 5*N, LDW1, min( LDW2, LDW3 ) ),
          where, if  COMUSE = 'C',  then
          LDW1 = 2,          if  M = 0  or   JOB = 'B',
          LDW1 = 3,          if  M > 0  and  JOB = 'D',
          LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ),
          LDW2 = LDWa,       if  M = 0  or  JOB = 'B',
          LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ),
                             if  M > 0  and JOB = 'D',
          LDWb = (b + r)*(r + 1) +
                  max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ),
          LDW3 = LDWb,       if  M = 0  or  JOB = 'B',
          LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ),
                             if  M > 0  and JOB = 'D',
             r = N*M + a,
             a = 0,                  if  JOBX0 = 'N',
             a = N,                  if  JOBX0 = 'X';
             b = 0,                  if  JOB   = 'B',
             b = L*M,                if  JOB   = 'D';
             c = 0,                  if  JOBX0 = 'N',
             c = L*N,                if  JOBX0 = 'X';
             d = 0,                  if  JOBX0 = 'N',
             d = 2*N*N + N,          if  JOBX0 = 'X';
             f = 2*r,                if  JOB   = 'B'   or  M = 0,
             f = M + max( 2*r, M ),  if  JOB   = 'D'  and  M > 0;
             q = b + r*L;
          and, if  JOBX0 = 'X'  and  COMUSE <> 'C',  then
          LDW1 = 2,
          LDW2 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ),
          LDW3 = N*(N + 1) + 2*N + max( q*(N + 1) + 2*N*N + L*N,
                                        4*N ),
             q = N*L.
          For good performance,  LDWORK  should be larger.
          If  LDWORK >= LDW2,  or if  COMUSE = 'C'  and
              LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c +
                        max( d, f ),
          then standard QR factorizations of the matrices  U  and/or
          W2,  if  COMUSE = 'C',  or of the matrix  Gamma,  if
          JOBX0 = 'X'  and  COMUSE <> 'C'  (see METHOD), are used.
          Otherwise, the QR factorizations are computed sequentially
          by performing  NCYCLE  cycles, each cycle (except possibly
          the last one) processing  s < t  samples, where  s  is
          chosen by equating  LDWORK  to the first term of  LDWb,
          if  COMUSE = 'C',  or of  LDW3,  if  COMUSE <> 'C',  for
          q  replaced by  s*L.  (s  is larger than or equal to the
          minimum value of  NSMP.)  The computational effort may
          increase and the accuracy may slightly decrease with the
          decrease of  s.  Recommended value is  LDWORK = LDW2,
          assuming a large enough cache size, to also accommodate
          A,  (B,)  C,  (D,)  U,  and  Y.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  the least squares problem to be solved has a
                rank-deficient coefficient matrix;
          = 6:  the matrix  A  is unstable;  the estimated  x(0)
                and/or  B and D  could be inaccurate.
          NOTE: the value 4 of  IWARN  has no significance for the
                identification problem.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the QR algorithm failed to compute all the
                eigenvalues of the matrix A (see LAPACK Library
                routine DGEES); the locations  DWORK(i),  for
                i = g+1:g+N*N,  contain the partially converged
                Schur form;
          = 2:  the singular value decomposition (SVD) algorithm did
                not converge.
Method 
  Matrix  A  is initially reduced to a real Schur form, A = V*At*V',
  and the given system matrices are transformed accordingly. For the
  reduced system, an extension and refinement of the method in [1,2]
  is used. Specifically, for  JOBX0 = 'X',  COMUSE = 'C',  and
  JOB = 'D',  denoting

        X = [ vec(D')' vec(B)' x0' ]',

  where  vec(M)  is the vector obtained by stacking the columns of
  the matrix  M,  then  X  is the least squares solution of the
  system  S*X = vec(Y),  with the matrix  S = [ diag(U)  W ],
  defined by

        ( U         |     | ... |     |     | ... |     |         )
        (   U       |  11 | ... |  n1 |  12 | ... |  nm |         )
    S = (     :     | y   | ... | y   | y   | ... | y   | P*Gamma ),
        (       :   |     | ... |     |     | ... |     |         )
        (         U |     | ... |     |     | ... |     |         )
                                                                  ij
  diag(U)  having  L  block rows and columns.  In this formula,  y
  are the outputs of the system for zero initial state computed
  using the following model, for j = 1:m, and for i = 1:n,
         ij          ij                    ij
        x  (k+1) = Ax  (k) + e_i u_j(k),  x  (0) = 0,

         ij          ij
        y  (k)   = Cx  (k),

  where  e_i  is the i-th n-dimensional unit vector,  Gamma  is
  given by

             (     C     )
             (    C*A    )
     Gamma = (   C*A^2   ),
             (     :     )
             ( C*A^(t-1) )

  and  P  is a permutation matrix that groups together the rows of
  Gamma  depending on the same row of  C,  namely
  [ c_j;  c_j*A;  c_j*A^2; ...  c_j*A^(t-1) ],  for j = 1:L.
  The first block column,  diag(U),  is not explicitly constructed,
  but its structure is exploited. The last block column is evaluated
  using powers of A with exponents 2^k. No interchanges are applied.
  A special QR decomposition of the matrix  S  is computed. Let
  U = q*[ r' 0 ]'  be the QR decomposition of  U,  if  M > 0,  where
  r  is  M-by-M.   Then,  diag(q')  is applied to  W  and  vec(Y).
  The block-rows of  S  and  vec(Y)  are implicitly permuted so that
  matrix  S  becomes

     ( diag(r)  W1 )
     (    0     W2 ),

  where  W1  has L*M rows. Then, the QR decomposition of  W2 is
  computed (sequentially, if  M > 0) and used to obtain  B  and  x0.
  The intermediate results and the QR decomposition of  U  are
  needed to find  D.  If a triangular factor is too ill conditioned,
  then singular value decomposition (SVD) is employed. SVD is not
  generally needed if the input sequence is sufficiently
  persistently exciting and  NSMP  is large enough.
  If the matrix  W  cannot be stored in the workspace (i.e.,
  LDWORK < LDW2),  the QR decompositions of  W2  and  U  are
  computed sequentially.
  For  JOBX0 = 'N'  and  COMUSE = 'C',  or  JOB = 'B',  a simpler
  problem is solved efficiently.

  For  JOBX0 = 'X'  and  COMUSE <> 'C',  a simpler method is used.
  Specifically, the output y0(k) of the system for zero initial
  state is computed for k = 0, 1, ...,  t-1 using the given model.
  Then the following least squares problem is solved for x(0)

                      (   y(0) - y0(0)   )
                      (   y(1) - y0(1)   )
     Gamma * x(0)  =  (        :         ).
                      (        :         )
                      ( y(t-1) - y0(t-1) )

  The coefficient matrix  Gamma  is evaluated using powers of A with
  exponents 2^k. The QR decomposition of this matrix is computed.
  If its triangular factor  R  is too ill conditioned, then singular
  value decomposition of  R  is used.
  If the coefficient matrix cannot be stored in the workspace (i.e.,
  LDWORK < LDW2),  the QR decomposition is computed sequentially.
References 
  [1] Verhaegen M., and Varga, A.
      Some Experience with the MOESP Class of Subspace Model
      Identification Methods in Identifying the BO105 Helicopter.
      Report TR R165-94, DLR Oberpfaffenhofen, 1994.

  [2] Sima, V., and Varga, A.
      RASP-IDENT : Subspace Model Identification Programs.
      Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V.,
      Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994.
Numerical Aspects 
  The implemented method is numerically stable.
Further Comments 
  The algorithm for computing the system matrices  B  and  D  is
  less efficient than the MOESP or N4SID algorithms implemented in
  SLICOT Library routines IB01BD/IB01PD, because a large least
  squares problem has to be solved, but the accuracy is better, as
  the computed matrices  B  and  D  are fitted to the input and
  output trajectories. However, if matrix  A  is unstable, the
  computed matrices  B  and  D  could be inaccurate.
Example

Program Text 

*     IB01CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LDA, LDB, LDC, LDD, LDR, LDU, LDV, LDW1, LDW2,
     $                 LDW4, LDW5, LDWORK, LDY, LIWORK, LMAX, MMAX,
     $                 NMAX, NOBRMX, NSMPMX
      PARAMETER        ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000,
     $                   NMAX = NOBRMX - 1, LDA = NMAX, LDB = NMAX,
     $                   LDC  = LMAX, LDD = LMAX, LDV = NMAX,
     $                   LDR  = MAX( 2*( MMAX + LMAX )*NOBRMX,
     $                               3*MMAX*NOBRMX ), LDU = NSMPMX,
     $                   LDW1 = MAX( LMAX*( NOBRMX - 1 )*NMAX + NMAX +
     $                               MAX( 6*MMAX, 4*LMAX )*NOBRMX,
     $                               LMAX*NOBRMX*NMAX +
     $                               MAX( LMAX*( NOBRMX - 1 )*NMAX +
     $                                    3*NMAX + LMAX +
     $                                    ( 2*MMAX + LMAX )*NOBRMX,
     $                                    2*LMAX*( NOBRMX - 1 )*NMAX +
     $                                    NMAX*NMAX + 8*NMAX,
     $                                    NMAX +
     $                                    4*( MMAX*NOBRMX + NMAX ) ) ),
     $                   LDW2 = LMAX*NOBRMX*NMAX +
     $                          MMAX*NOBRMX*( NMAX + LMAX )*
     $                          ( MMAX*( NMAX + LMAX ) + 1 ) +
     $                          MAX( ( NMAX + LMAX )**2,
     $                          4*MMAX*( NMAX + LMAX ) + 1 ),
     $                   LDW4 = NSMPMX*LMAX*NMAX*( MMAX + 1 ) +
     $                          MAX( NMAX +
     $                               MAX( 2*NMAX*NMAX + NMAX,
     $                                    MMAX +
     $                                    MAX( 2*NMAX*( MMAX + 1 ),
     $                                         MMAX ),
     $                                    6*NMAX*( MMAX + 1 ) ),
     $                               2*MMAX*MMAX*NMAX + 6*MMAX ),
     $                   LDW5 = ( LMAX*MMAX + NMAX*( MMAX + 1 ) )*
     $                          NMAX*( MMAX + 1 ) +
     $                          MAX( ( LMAX*MMAX +
     $                               LMAX*NMAX*( MMAX + 1 ) )*
     $                               NMAX*( MMAX + 1 ) +
     $                               NMAX*NMAX*MMAX + LMAX*NMAX +
     $                               MAX( 2*NMAX*NMAX + NMAX,
     $                                    MMAX +
     $                                    MAX( 2*NMAX*( MMAX + 1 ),
     $                                         MMAX ),
     $                                    6*NMAX*( MMAX + 1 ) ),
     $                               2*MMAX*MMAX*NMAX + 6*MMAX ),
     $                   LDWORK = MAX( 6*( MMAX + LMAX )*NOBRMX,
     $                                 ( MMAX + LMAX )*( 4*NOBRMX*
     $                                 ( MMAX + LMAX + 2 ) - 2 ),
     $                                 ( MMAX + LMAX )*4*NOBRMX*
     $                                 ( NOBRMX + 1 ), LDW1, LDW2,
     $                                 3 + ( NMAX + MMAX + LMAX )*NMAX +
     $                                 MAX( 5*NMAX, 3,
     $                                      MIN( LDW4, LDW5 ) ) ),
     $                   LDY = NSMPMX,
     $                   LIWORK = MAX( ( MMAX + LMAX )*NOBRMX,
     $                                 MMAX*NOBRMX + NMAX,
     $                                 MMAX*( NMAX + LMAX ),
     $                                 NMAX*MMAX + NMAX, MMAX )
     $                 )
*     .. Local Scalars ..
      LOGICAL          NGIVEN
      CHARACTER        ALG, BATCH, COMUSE, CONCT, CTRL, JOB, JOBBD,
     $                 JOBCK, JOBD, JOBDA, JOBX0, METH, METHA
      INTEGER          I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE,
     $                 NGIV, NOBR, NSAMPL, NSMP
      DOUBLE PRECISION RCOND, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), B(LDB, MMAX), C(LDC, NMAX),
     $                 D(LDD, MMAX), DUM(1), DWORK(LDWORK),
     $                 R(LDR, 2*(MMAX+LMAX)*NOBRMX),
     $                 SV(LMAX*NOBRMX), U(LDU, MMAX), V(LDV, NMAX),
     $                 X0(NMAX), Y(LDY, LMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         IB01AD, IB01BD, IB01CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
*     If the value of N is positive, it will be taken as system order.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL
      READ ( NIN, FMT = * ) METH, ALG, JOBD, BATCH, CONCT, CTRL, JOB,
     $                      COMUSE, JOBX0
      IF ( LSAME( BATCH, 'F' ) ) THEN
         READ ( NIN, FMT = * ) NCYCLE
      ELSE
         NCYCLE = 1
      END IF
      NSAMPL = NCYCLE*NSMP
*
      NGIVEN = N.GT.0
      IF( NGIVEN )
     $   NGIV = N
      IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN
         WRITE ( NOUT, FMT = 99997 ) NOBR
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99996 ) M
      ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) L
      ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR.
     $        ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'O' ) ) .OR.
     $        ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'L' ) ) .OR.
     $          NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR.
     $                                 LSAME( BATCH, 'I' ) ) ) THEN
         WRITE ( NOUT, FMT = 99994 ) NSMP
      ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NCYCLE
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) N
      ELSE
*        Read the matrices U and Y from the input file.
         IF ( M.GT.0 )
     $      READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1, M ), I = 1, NSAMPL )
         READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL )
*        Force some options, depending on the specifications.
         IF ( LSAME( METH, 'C' ) ) THEN
            METHA = 'M'
            JOBDA = 'N'
         ELSE
            METHA = METH
            JOBDA = JOBD
         END IF
*        The covariances and Kalman gain matrix are not computed.
         JOBCK = 'N'
         IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN
            JOBBD = 'D'
         ELSE
            JOBBD = JOB
         END IF
         IF ( LSAME( COMUSE, 'C' ) ) THEN
            JOB = 'C'
         ELSE IF ( LSAME( COMUSE, 'U' ) ) THEN
            JOB = 'A'
         END IF
*        Compute the  R  factor from a QR (or Cholesky) factorization
*        of the Hankel-like matrix (or correlation matrix).
         DO 10 ICYCLE = 1, NCYCLE
            II = ( ICYCLE - 1 )*NSMP + 1
            IF ( NCYCLE.GT.1 ) THEN
               IF ( ICYCLE.GT.1 )      BATCH = 'I'
               IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L'
            END IF
            CALL IB01AD( METHA, ALG, JOBDA, BATCH, CONCT, CTRL, NOBR, M,
     $                   L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR,
     $                   SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN,
     $                   INFO )
   10    CONTINUE
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 )
     $         WRITE ( NOUT, FMT = 99990 ) IWARN
            IF( NGIVEN )
     $         N = NGIV
*           Compute the system matrices and x0.
            CALL IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMP, R,
     $                   LDR, A, LDA, C, LDC, B, LDB, D, LDD, DUM, 1,
     $                   DUM, 1, DUM, 1, DUM, 1, RCOND, IWORK, DWORK,
     $                   LDWORK, BWORK, IWARN, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99982 ) INFO
            ELSE
               IF ( IWARN.NE.0 )
     $            WRITE ( NOUT, FMT = 99981 ) IWARN
               CALL IB01CD( JOBX0, COMUSE, JOBBD, N, M, L, NSMP, A, LDA,
     $                      B, LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0,
     $                      V, LDV, RCOND, IWORK, DWORK, LDWORK, IWARN,
     $                      INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99992 ) INFO
               ELSE
                  IF ( IWARN.NE.0 )
     $               WRITE ( NOUT, FMT = 99991 ) IWARN
                  IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN
                     WRITE ( NOUT, FMT = 99989 )
                     DO 20 I = 1, N
                        WRITE ( NOUT, FMT = 99988 ) ( A(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99987 )
                     DO 30 I = 1, L
                        WRITE ( NOUT, FMT = 99988 ) ( C(I,J), J = 1,N )
   30                CONTINUE
                  END IF
                  IF ( LSAME( COMUSE, 'C' ) ) THEN
                     WRITE ( NOUT, FMT = 99986 )
                     DO 40 I = 1, N
                        WRITE ( NOUT, FMT = 99988 ) ( B(I,J), J = 1,M )
   40                CONTINUE
                     IF ( LSAME( JOBBD, 'D' ) ) THEN
                        WRITE ( NOUT, FMT = 99985 )
                        DO 50 I = 1, L
                           WRITE ( NOUT, FMT = 99988 )
     $                           ( D(I,J), J = 1,M )
   50                   CONTINUE
                     END IF
                  END IF
                  IF ( LSAME( JOBX0, 'X' ) ) THEN
                     WRITE ( NOUT, FMT = 99984 )
                     WRITE ( NOUT, FMT = 99988 ) ( X0(I), I = 1,N )
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
99999 FORMAT ( ' IB01CD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT ( ' INFO on exit from IB01AD = ',I2)
99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5)
99996 FORMAT (/' M is out of range.',/' M = ', I5)
99995 FORMAT (/' L is out of range.',/' L = ', I5)
99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5)
99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5)
99992 FORMAT ( ' INFO on exit from IB01CD = ',I2)
99991 FORMAT ( ' IWARN on exit from IB01CD = ',I2)
99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2)
99989 FORMAT (/' The system state matrix A is ')
99988 FORMAT (20(1X,F8.4))
99987 FORMAT (/' The system output matrix C is ')
99986 FORMAT (/' The system input matrix B is ')
99985 FORMAT (/' The system input-output matrix D is ')
99984 FORMAT (/' The initial state vector x0 is ')
99983 FORMAT (/' N is out of range.',/' N = ', I5)
99982 FORMAT ( ' INFO on exit from IB01BD = ',I2)
99981 FORMAT ( ' IWARN on exit from IB01BD = ',I2)
      END
Program Data 
 IB01CD EXAMPLE PROGRAM DATA
  15     0     1     1  1000    0.0   -1.0
   C     C     N     O     N     N     A     C     X
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   3.41
   6.41
   6.41
   6.41
   6.41
   6.41
   6.41
   4.766099
   4.763659
   4.839359
   5.002979
   5.017629
   5.056699
   5.154379
   5.361949
   5.425439
   5.569519
   5.681849
   5.742899
   5.803949
   5.918729
   5.821049
   5.447419
   5.061589
   4.629349
   4.267939
   4.011519
   3.850349
   3.711159
   3.569519
   3.518239
   3.652549
   3.818609
   3.862559
   4.011519
   4.353409
   4.705049
   5.083559
   5.344859
   5.274039
   5.127519
   4.761219
   4.451089
   4.221539
   4.045709
   3.874769
   3.730689
   3.662319
   3.576849
   3.542659
   3.479169
   3.454749
   3.359509
   3.298459
   3.225199
   3.200779
   3.225199
   3.227639
   3.274039
   3.457189
   3.867449
   4.321659
   4.492599
   4.431549
   4.243519
   4.050599
   3.857679
   3.730689
   3.791739
   3.921169
   3.955359
   3.847909
   3.725809
   3.611039
   3.716039
   4.092109
   4.480389
   4.814939
   5.054259
   5.303339
   5.486489
   5.672089
   5.779529
   5.799069
   5.664759
   5.291129
   4.880879
   4.558529
   4.184909
   3.889419
   3.708719
   3.623249
   3.569519
   3.718479
   4.033499
   4.412009
   4.629349
   4.558529
   4.394919
   4.180019
   4.197119
   4.431549
   4.714819
   4.961459
   5.300899
   5.567079
   5.681849
   5.545099
   5.188569
   4.883319
   4.600049
   4.270379
   4.038389
   3.838139
   3.711159
   3.591499
   3.535329
   3.486489
   3.476729
   3.425439
   3.381489
   3.369279
   3.364389
   3.347299
   3.381489
   3.420559
   3.413229
   3.452309
   3.635459
   4.038389
   4.375379
   4.727029
   5.056699
   5.298459
   5.532889
   5.466959
   5.195899
   4.885759
   4.763659
   4.875989
   5.042049
   5.283809
   5.491379
   5.596379
   5.672089
   5.772209
   5.830819
   5.933379
   5.899189
   5.935819
   5.894309
   5.918729
   5.994429
   5.957799
   6.031059
   6.062809
   6.040829
   6.096999
   6.123859
   6.162929
   6.040829
   5.845469
   5.772209
   5.799069
   5.923609
   5.928499
   6.001759
   6.001759
   6.060369
   5.882099
   5.510909
   5.322879
   5.371719
   5.454749
   5.437649
   5.159269
   4.902859
   4.587839
   4.502369
   4.595159
   4.824709
   5.064029
   5.271599
   5.466959
   5.615919
   5.528009
   5.254499
   4.883319
   4.517019
   4.197119
   4.001759
   3.806399
   3.904079
   3.923609
   3.869889
   3.806399
   3.720929
   3.818609
   4.140949
   4.529229
   4.805179
   5.086009
   5.339969
   5.532889
   5.576849
   5.667199
   5.791739
   5.850349
   5.923609
   5.921169
   5.977339
   5.740459
   5.388809
   5.000539
   4.849129
   4.944369
   5.173919
   5.369279
   5.447419
   5.603709
   5.730689
   5.850349
   5.979779
   5.991989
   6.084789
   5.940709
   5.803949
   5.791739
   5.603709
   5.264269
   4.946809
   4.619579
   4.514579
   4.433989
   4.285029
   4.121419
   3.945589
   3.984659
   4.219099
   4.546319
   4.873549
   5.154379
   5.388809
   5.613479
   5.835699
   5.884539
   5.955359
   5.762439
   5.459629
   5.061589
   4.707499
   4.458409
   4.267939
   4.053039
   3.943149
   3.825929
   3.967569
   4.280149
   4.480389
   4.492599
   4.390039
   4.197119
   4.111649
   3.982219
   3.867449
   3.767319
   3.872329
   4.236189
   4.663539
   4.971229
   5.066469
   4.902859
   4.675749
   4.392479
   4.099439
   4.114089
   4.326539
   4.643999
   4.971229
   5.159269
   5.388809
   5.576849
   5.652549
   5.803949
   5.913839
   5.886979
   5.799069
   5.730689
   5.762439
   5.813719
   5.821049
   5.928499
   6.013969
   5.764879
   5.413229
   5.098219
   4.678189
   4.372939
   4.392479
   4.590279
   4.919949
   5.017629
   4.858899
   4.675749
   4.619579
   4.834479
   5.090889
   5.376599
   5.681849
   5.823489
   5.952919
   6.062809
   6.089669
   6.075019
   6.026179
   5.994429
   6.077459
   5.857679
   5.701389
   5.730689
   5.784419
   5.823489
   5.894309
   5.762439
   5.415679
   4.961459
   4.595159
   4.331429
   4.297239
   4.582949
   4.861339
   5.173919
   5.166589
   4.919949
   4.607369
   4.370499
   4.182469
   4.038389
   4.145839
   4.431549
   4.556089
   4.480389
   4.375379
   4.370499
   4.558529
   4.858899
   4.895529
   4.741679
   4.744129
   4.875989
   5.105539
   5.239849
   5.518239
   5.652549
   5.723369
   5.855239
   5.962679
   5.984659
   5.984659
   6.055479
   6.062809
   6.055479
   6.070129
   5.784419
   5.440099
   5.056699
   4.941929
   5.010299
   5.134849
   5.313109
   5.479169
   5.623249
   5.562199
   5.330209
   5.010299
   4.665979
   4.414459
   4.201999
   4.048159
   4.079899
   4.189789
   4.131179
   4.004199
   3.916289
   3.960239
   4.199559
   4.624469
   4.883319
   5.137289
   5.379049
   5.623249
   5.762439
   5.833259
   5.686739
   5.366839
   5.225199
   5.239849
   5.354629
   5.508469
   5.596379
   5.752669
   5.874769
   5.906519
   5.894309
   5.742899
   5.447419
   5.024959
   4.883319
   4.885759
   4.893089
   4.714819
   4.451089
   4.233749
   4.043269
   3.864999
   3.757559
   3.669639
   3.593939
   3.547539
   3.506029
   3.454749
   3.398579
   3.361949
   3.339969
   3.374159
   3.520679
   3.713599
   3.757559
   3.779529
   3.696509
   3.777089
   3.886979
   3.904079
   3.850349
   3.965129
   4.282589
   4.521899
   4.714819
   4.971229
   5.220319
   5.532889
   5.652549
   5.781979
   5.955359
   6.035939
   6.118969
   6.133629
   6.153159
   6.192229
   6.143389
   6.167809
   5.991989
   5.652549
   5.459629
   5.437649
   5.339969
   5.098219
   4.785639
   4.492599
   4.236189
   4.067689
   3.933379
   3.823489
   3.730689
   3.611039
   3.564639
   3.549989
   3.557309
   3.513359
   3.515799
   3.694059
   4.072579
   4.480389
   4.705049
   4.612259
   4.385149
   4.201999
   4.026179
   3.904079
   3.774649
   3.691619
   3.845469
   4.201999
   4.585399
   4.902859
   5.256949
   5.510909
   5.640339
   5.843029
   5.974889
   5.935819
   5.821049
   5.528009
   5.171479
   4.810059
   4.453529
   4.380269
   4.565859
   4.805179
   5.125079
   5.354629
   5.589059
   5.764879
   5.923609
   5.940709
   5.857679
   5.694059
   5.486489
   5.149499
   4.844249
   4.541439
   4.267939
   4.060369
   3.960239
   3.789299
   3.642779
   3.525569
   3.498699
   3.454749
   3.408349
   3.379049
   3.376599
   3.361949
   3.359509
   3.369279
   3.398579
   3.579289
   3.948029
   4.412009
   4.585399
   4.514579
   4.343639
   4.155599
   3.984659
   4.043269
   4.307009
   4.421779
   4.353409
   4.223979
   4.053039
   3.940709
   3.838139
   3.730689
   3.652549
   3.611039
   3.564639
   3.496259
   3.462069
   3.454749
   3.425439
   3.379049
   3.432769
   3.623249
   3.974889
   4.380269
   4.714819
   5.073799
   5.369279
   5.603709
   5.745349
   5.652549
   5.401019
   5.015189
   4.709939
   4.416899
   4.236189
   4.236189
   4.248399
   4.221539
   4.297239
   4.590279
   4.893089
   5.134849
   5.427889
   5.379049
   5.364389
   5.452309
   5.567079
   5.672089
   5.769769
   5.830819
   5.923609
   5.965129
   6.057919
   6.050599
   6.072579
   6.111649
   6.070129
   5.896749
   5.755109
   5.718479
   5.821049
   6.001759
   6.001759
   5.901629
   5.557309
   5.173919
   4.800289
   4.431549
   4.194679
   4.006639
   3.850349
   3.747789
   3.642779
   3.591499
   3.569519
   3.528009
   3.537779
   3.554869
   3.493819
   3.447419
   3.440099
   3.408349
   3.410789
   3.452309
   3.681849
   4.060369
   4.441319
   4.854019
   5.154379
   5.425439
   5.596379
   5.586619
   5.354629
   5.027399
   4.863779
   4.761219
   4.570739
   4.368059
   4.397359
   4.573189
   4.841809
   5.203219
   5.452309
   5.652549
   5.855239
   5.906519
   5.952919
   5.828369
   5.791739
   5.799069
   5.813719
   5.877209
   5.955359
   5.781979
   5.518239
   5.127519
   4.763659
   4.492599
   4.233749
   4.011519
   3.855239
   3.691619
   3.635459
   3.818609
   4.155599
   4.590279
   4.988329
   5.076239
   4.907739
   4.648889
   4.377829
   4.216649
   4.287469
   4.590279
   4.846689
   5.139729
   5.388809
   5.689179
   5.884539
   6.043269
   6.170259
   6.211769
   6.250839
   6.209329
   6.013969
   5.701389
   5.469399
   5.479169
   5.557309
   5.728249
   5.882099
   5.984659
   5.901629
   5.581729
   5.371719
   5.418119
   5.510909
   5.667199
   5.791739
   5.698949
   5.484049
   5.154379
   4.980999
   5.061589
   5.195899
   5.359509
   5.615919
   5.762439
   5.857679
   5.948029
   5.835699
   5.706269
   5.498699
   5.188569
   5.117749
   5.191009
   5.315549
   5.532889
   5.444979
   5.396139
   5.274039
   5.027399
   4.744129
   4.668419
   4.651329
   4.514579
   4.267939
   4.260609
   4.263049
   4.189789
   4.277699
   4.600049
   4.932159
   5.283809
   5.528009
   5.740459
   5.874769
   5.955359
   5.991989
   5.845469
   5.528009
   5.061589
   4.734359
   4.534109
   4.534109
   4.697729
   4.744129
   4.619579
   4.643999
   4.832039
   5.132399
   5.410789
   5.625689
   5.603709
   5.315549
   4.961459
   4.619579
   4.358289
   4.155599
   4.033499
   3.886979
   3.772209
   3.640339
   3.532889
   3.435209
   3.427889
   3.422999
   3.398579
   3.603709
   4.023729
   4.451089
   4.792969
   4.902859
   4.780759
   4.590279
   4.336309
   4.145839
   4.216649
   4.433989
   4.714819
   5.098219
   5.359509
   5.569519
   5.772209
   5.921169
   6.055479
   5.962679
   5.642779
   5.435209
   5.388809
   5.537779
   5.681849
   5.701389
   5.615919
   5.667199
   5.740459
   5.803949
   5.882099
   5.950469
   6.072579
   6.148279
   6.116529
   6.177579
   6.201999
   6.206889
   5.991989
   5.564639
   5.178799
   4.998089
   5.051819
   5.232529
   5.484049
   5.686739
   5.899189
   5.869889
   5.977339
   6.053039
   6.079899
   6.128739
   6.079899
   6.167809
   6.194679
   6.236189
   6.053039
   5.652549
   5.274039
   4.858899
   4.534109
   4.455969
   4.619579
   4.866229
   5.117749
   5.166589
   5.056699
   5.002979
   5.098219
   5.325319
   5.567079
   5.466959
   5.252059
   4.946809
   4.880879
   4.980999
   5.225199
   5.459629
   5.723369
   5.791739
   5.906519
   5.991989
   5.835699
   5.528009
   5.142169
   4.775869
   4.490159
   4.236189
   4.023729
   3.886979
   3.752669
   3.681849
   3.806399
   4.145839
   4.600049
   5.002979
   5.303339
   5.552429
   5.615919
   5.523119
   5.611039
   5.713599
   5.845469
   5.899189
   5.994429
   6.092109
   6.092109
   6.143389
   6.153159
   6.233749
   6.187349
   6.013969
   5.835699
   5.774649
   5.686739
   5.537779
   5.327759
   5.054259
   4.700169
   4.394919
   4.180019
   4.043269
   3.877209
   3.752669
   3.728249
   3.869889
   4.206889
   4.355849
   4.426669
   4.453529
   4.521899
   4.392479
   4.155599
   3.965129
   3.877209
   3.970009
   4.258169
   4.421779
   4.336309
   4.299679
   4.392479
   4.675749
   4.761219
   4.658659
   4.490159
   4.307009
   4.126299
   3.972449
   4.077459
   4.372939
   4.741679
   5.088449
   5.186129
   5.037169
   4.785639
   4.563419
   4.534109
   4.705049
   4.741679
   4.648889
   4.431549
   4.238629
   4.065249
   3.943149
   3.811279
   3.691619
   3.652549
   3.825929
   4.223979
   4.424219
   4.429109
   4.319219
   4.138509
   3.965129
   3.886979
   3.801509
   3.701389
   3.640339
   3.767319
   4.150719
   4.648889
   4.990769
   5.088449
   5.022509
   4.783199
   4.685519
   4.665979
   4.707499
   4.912619
   5.195899
   5.415679
   5.623249
   5.740459
   5.899189
   5.928499
   6.050599
   6.153159
   5.965129
   5.586619
   5.381489
   5.371719
   5.486489
   5.567079
   5.821049
   5.913839
   5.994429
   6.011519
   5.999309
   6.018849
   5.821049
   5.728249
   5.740459
   5.764879
   5.882099
   5.926049
   5.750229
   5.415679
   4.995649
   4.861339
   4.902859
   5.103099
   5.364389
   5.596379
   5.752669
   5.845469
   5.928499
   6.006639
   5.840579
   5.518239
   5.173919
   4.739239
   4.458409
   4.426669
   4.602489
   4.822269
   5.183689
   5.430329
   5.652549
   5.821049
   5.706269
   5.369279
   5.027399
   4.705049
   4.414459
   4.145839
   3.965129
   4.033499
   4.372939
   4.683079
Program Results 
 IB01CD EXAMPLE PROGRAM RESULTS


 The system state matrix A is 
   0.8924   0.3887   0.1285   0.1716
  -0.0837   0.6186  -0.6273  -0.4582
   0.0052   0.1307   0.6685  -0.6755
   0.0055   0.0734  -0.2148   0.4788

 The system output matrix C is 
  -0.4442   0.6663   0.3961   0.4102

 The system input matrix B is 
  -0.2150
  -0.1962
   0.0511
   0.0373

 The system input-output matrix D is 
  -0.0018

 The initial state vector x0 is 
 -11.4329  -0.6767   0.0472   0.3600

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/IB01MD.html000077500000000000000000000342361201767322700160700ustar00rootroot00000000000000 IB01MD - SLICOT Library Routine Documentation

IB01MD

Upper triangular factor in the QR factorization of the block-Hankel matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct an upper triangular factor  R  of the concatenated
  block Hankel matrices using input-output data.  The input-output
  data can, optionally, be processed sequentially.
Specification 
      SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U,
     $                   LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK,
     $                   IWARN, INFO )
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, *)
Arguments

Mode Parameters 

  METH    CHARACTER*1
          Specifies the subspace identification method to be used,
          as follows:
          = 'M':  MOESP  algorithm with past inputs and outputs;
          = 'N':  N4SID  algorithm.

  ALG     CHARACTER*1
          Specifies the algorithm for computing the triangular
          factor R, as follows:
          = 'C':  Cholesky algorithm applied to the correlation
                  matrix of the input-output data;
          = 'F':  Fast QR algorithm;
          = 'Q':  QR algorithm applied to the concatenated block
                  Hankel matrices.

  BATCH   CHARACTER*1
          Specifies whether or not sequential data processing is to
          be used, and, for sequential processing, whether or not
          the current data block is the first block, an intermediate
          block, or the last block, as follows:
          = 'F':  the first block in sequential data processing;
          = 'I':  an intermediate block in sequential data
                  processing;
          = 'L':  the last block in sequential data processing;
          = 'O':  one block only (non-sequential data processing).
          NOTE that when  100  cycles of sequential data processing
               are completed for  BATCH = 'I',  a warning is
               issued, to prevent for an infinite loop.

  CONCT   CHARACTER*1
          Specifies whether or not the successive data blocks in
          sequential data processing belong to a single experiment,
          as follows:
          = 'C':  the current data block is a continuation of the
                  previous data block and/or it will be continued
                  by the next data block;
          = 'N':  there is no connection between the current data
                  block and the previous and/or the next ones.
          This parameter is not used if BATCH = 'O'.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          block Hankel matrices to be processed.  NOBR > 0.
          (In the MOESP theory,  NOBR  should be larger than  n,
          the estimated dimension of state vector.)

  M       (input) INTEGER
          The number of system inputs.  M >= 0.
          When M = 0, no system inputs are processed.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMP    (input) INTEGER
          The number of rows of matrices  U  and  Y  (number of
          samples,  t). (When sequential data processing is used,
          NSMP  is the number of samples of the current data
          block.)
          NSMP >= 2*(M+L+1)*NOBR - 1,  for non-sequential
                                       processing;
          NSMP >= 2*NOBR,  for sequential processing.
          The total number of samples when calling the routine with
          BATCH = 'L'  should be at least  2*(M+L+1)*NOBR - 1.
          The  NSMP  argument may vary from a cycle to another in
          sequential data processing, but  NOBR, M,  and  L  should
          be kept constant. For efficiency, it is advisable to use
          NSMP  as large as possible.

  U       (input) DOUBLE PRECISION array, dimension (LDU,M)
          The leading NSMP-by-M part of this array must contain the
          t-by-m input-data sequence matrix  U,
          U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
          NSMP  values of the j-th input component for consecutive
          time increments.
          If M = 0, this array is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= NSMP, if M > 0;
          LDU >= 1,    if M = 0.

  Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
          The leading NSMP-by-L part of this array must contain the
          t-by-l output-data sequence matrix  Y,
          Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
          NSMP  values of the j-th output component for consecutive
          time increments.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= NSMP.

  R       (output or input/output) DOUBLE PRECISION array, dimension
          ( LDR,2*(M+L)*NOBR )
          On exit, if INFO = 0 and ALG = 'Q', or (ALG = 'C' or 'F',
          and BATCH = 'L' or 'O'), the leading
          2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of
          this array contains the (current) upper triangular factor
          R from the QR factorization of the concatenated block
          Hankel matrices. The diagonal elements of R are positive
          when the Cholesky algorithm was successfully used.
          On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading
          2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this
          array contains the current upper triangular part of the
          correlation matrix in sequential data processing.
          If ALG = 'F' and BATCH = 'F' or 'I', the array R is not
          referenced.
          On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or
          'L', the leading  2*(M+L)*NOBR-by-2*(M+L)*NOBR  upper
          triangular part of this array must contain the upper
          triangular matrix R computed at the previous call of this
          routine in sequential data processing. The array R need
          not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'.

  LDR     INTEGER
          The leading dimension of the array  R.
          LDR >= 2*(M+L)*NOBR.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= M+L, if ALG = 'F';
          LIWORK >= 0,   if ALG = 'C' or 'Q'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -17,  DWORK(1)  returns the minimum
          value of LDWORK.
          Let
          k = 0,               if CONCT = 'N' and ALG = 'C' or 'Q';
          k = 2*NOBR-1,        if CONCT = 'C' and ALG = 'C' or 'Q';
          k = 2*NOBR*(M+L+1),  if CONCT = 'N' and ALG = 'F';
          k = 2*NOBR*(M+L+2),  if CONCT = 'C' and ALG = 'F'.
          The first (M+L)*k elements of  DWORK  should be preserved
          during successive calls of the routine with  BATCH = 'F'
          or  'I',  till the final call with  BATCH = 'L'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH <> 'O' and
                                  CONCT = 'C';
          LDWORK >= 1,            if ALG = 'C', BATCH = 'O' or
                                  CONCT = 'N';
          LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F',
                                  BATCH <> 'O' and CONCT = 'C';
          LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F',
                                  BATCH = 'F', 'I' and CONCT = 'N';
          LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F',
                                  BATCH = 'L' and CONCT = 'N', or
                                  BATCH = 'O';
          LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O',
                                  and LDR >= NS = NSMP - 2*NOBR + 1;
          LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O',
                                  and LDR < NS, or BATCH = 'I' or
                                  'L' and CONCT = 'N';
          LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I'
                                  or 'L' and CONCT = 'C'.
          The workspace used for ALG = 'Q' is
                    LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR,
          where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended
          value LDRWRK = NS, assuming a large enough cache size.
          For good performance,  LDWORK  should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  the number of 100 cycles in sequential data
                processing has been exhausted without signaling
                that the last block of data was get; the cycle
                counter was reinitialized;
          = 2:  a fast algorithm was requested (ALG = 'C' or 'F'),
                but it failed, and the QR algorithm was then used
                (non-sequential data processing).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  a fast algorithm was requested (ALG = 'C', or 'F')
                in sequential data processing, but it failed. The
                routine can be repeatedly called again using the
                standard QR algorithm.
Method 
  1) For non-sequential data processing using QR algorithm, a
  t x 2(m+l)s  matrix H is constructed, where

       H = [ Uf'         Up'      Y'      ],  for METH = 'M',
               s+1,2s,t    1,s,t   1,2s,t

       H = [ U'       Y'      ],              for METH = 'N',
              1,2s,t   1,2s,t

  and  Up     , Uf        , U      , and  Y        are block Hankel
         1,s,t    s+1,2s,t   1,2s,t        1,2s,t
  matrices defined in terms of the input and output data [3].
  A QR factorization is used to compress the data.
  The fast QR algorithm uses a QR factorization which exploits
  the block-Hankel structure. Actually, the Cholesky factor of H'*H
  is computed.

  2) For sequential data processing using QR algorithm, the QR
  decomposition is done sequentially, by updating the upper
  triangular factor  R.  This is also performed internally if the
  workspace is not large enough to accommodate an entire batch.

  3) For non-sequential or sequential data processing using
  Cholesky algorithm, the correlation matrix of input-output data is
  computed (sequentially, if requested), taking advantage of the
  block Hankel structure [7].  Then, the Cholesky factor of the
  correlation matrix is found, if possible.
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error
      state-space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Verhaegen M.
      Subspace Model Identification. Part 3: Analysis of the
      ordinary output-error state-space model identification
      algorithm.
      Int. J. Control, 58, pp. 555-586, 1993.

  [3] Verhaegen M.
      Identification of the deterministic part of MIMO state space
      models given in innovations form from input-output data.
      Automatica, Vol.30, No.1, pp.61-74, 1994.

  [4] Van Overschee, P., and De Moor, B.
      N4SID: Subspace Algorithms for the Identification of
      Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [5] Peternell, K., Scherrer, W. and Deistler, M.
      Statistical Analysis of Novel Subspace Identification Methods.
      Signal Processing, 52, pp. 161-177, 1996.

  [6] Sima, V.
      Subspace-based Algorithms for Multivariable System
      Identification.
      Studies in Informatics and Control, 5, pp. 335-344, 1996.

  [7] Sima, V.
      Cholesky or QR Factorization for Data Compression in
      Subspace-based Identification ?
      Proceedings of the Second NICONET Workshop on ``Numerical
      Control Software: SLICOT, a Useful Tool in Industry'',
      December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999.
Numerical Aspects 
  The implemented method is numerically stable (when QR algorithm is
  used), reliable and efficient. The fast Cholesky or QR algorithms
  are more efficient, but the accuracy could diminish by forming the
  correlation matrix.
                                     2
  The QR algorithm needs 0(t(2(m+l)s) ) floating point operations.
                                        2              3
  The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating
  point operations.
                                       2           3 2
  The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating
  point operations.
Further Comments 
  For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the
  calculations could be rather inefficient if only minimal workspace
  (see argument LDWORK) is provided. It is advisable to provide as
  much workspace as possible. Almost optimal efficiency can be
  obtained for  LDWORK = (NS+2)*(2*(M+L)*NOBR),  assuming that the
  cache size is large enough to accommodate R, U, Y, and DWORK.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01MY.html000077500000000000000000000235641201767322700161170ustar00rootroot00000000000000 IB01MY - SLICOT Library Routine Documentation

IB01MY

Upper triangular factor in the QR factorization of the block Hankel matrix, using a fast QR algorithm

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct an upper triangular factor  R  of the concatenated
  block Hankel matrices using input-output data, via a fast QR
  algorithm based on displacement rank.  The input-output data can,
  optionally, be processed sequentially.
Specification 
      SUBROUTINE IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU,
     $                   Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN,
     $                   INFO )
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, *)
Arguments

Mode Parameters 

  METH    CHARACTER*1
          Specifies the subspace identification method to be used,
          as follows:
          = 'M':  MOESP  algorithm with past inputs and outputs;
          = 'N':  N4SID  algorithm.

  BATCH   CHARACTER*1
          Specifies whether or not sequential data processing is to
          be used, and, for sequential processing, whether or not
          the current data block is the first block, an intermediate
          block, or the last block, as follows:
          = 'F':  the first block in sequential data processing;
          = 'I':  an intermediate block in sequential data
                  processing;
          = 'L':  the last block in sequential data processing;
          = 'O':  one block only (non-sequential data processing).
          NOTE that when  100  cycles of sequential data processing
               are completed for  BATCH = 'I',  a warning is
               issued, to prevent for an infinite loop.

  CONCT   CHARACTER*1
          Specifies whether or not the successive data blocks in
          sequential data processing belong to a single experiment,
          as follows:
          = 'C':  the current data block is a continuation of the
                  previous data block and/or it will be continued
                  by the next data block;
          = 'N':  there is no connection between the current data
                  block and the previous and/or the next ones.
          This parameter is not used if BATCH = 'O'.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          block Hankel matrices to be processed.  NOBR > 0.
          (In the MOESP theory,  NOBR  should be larger than  n, the
          estimated dimension of state vector.)

  M       (input) INTEGER
          The number of system inputs.  M >= 0.
          When M = 0, no system inputs are processed.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMP    (input) INTEGER
          The number of rows of matrices  U  and  Y  (number of
          samples,  t). (When sequential data processing is used,
          NSMP  is the number of samples of the current data
          block.)
          NSMP >= 2*(M+L+1)*NOBR - 1,  for non-sequential
                                       processing;
          NSMP >= 2*NOBR,  for sequential processing.
          The total number of samples when calling the routine with
          BATCH = 'L'  should be at least  2*(M+L+1)*NOBR - 1.
          The  NSMP  argument may vary from a cycle to another in
          sequential data processing, but  NOBR, M,  and  L  should
          be kept constant. For efficiency, it is advisable to use
          NSMP  as large as possible.

  U       (input) DOUBLE PRECISION array, dimension (LDU,M)
          The leading NSMP-by-M part of this array must contain the
          t-by-m input-data sequence matrix  U,
          U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
          NSMP  values of the j-th input component for consecutive
          time increments.
          If M = 0, this array is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= NSMP, if M > 0;
          LDU >= 1,    if M = 0.

  Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
          The leading NSMP-by-L part of this array must contain the
          t-by-l output-data sequence matrix  Y,
          Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
          NSMP  values of the j-th output component for consecutive
          time increments.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= NSMP.

  R       (output) DOUBLE PRECISION array, dimension
          ( LDR,2*(M+L)*NOBR )
          If INFO = 0 and BATCH = 'L' or 'O', the leading
          2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this
          array contains the upper triangular factor R from the
          QR factorization of the concatenated block Hankel
          matrices.

  LDR     INTEGER
          The leading dimension of the array  R.
          LDR >= 2*(M+L)*NOBR.
Workspace 
  IWORK   INTEGER array, dimension (M+L)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -16,  DWORK(1)  returns the minimum
          value of LDWORK.
          The first (M+L)*2*NOBR*(M+L+c) elements of  DWORK  should
          be preserved during successive calls of the routine
          with  BATCH = 'F'  or  'I',  till the final call with
          BATCH = 'L',  where
          c = 1,  if the successive data blocks do not belong to a
                  single experiment  (CONCT = 'N');
          c = 2,  if the successive data blocks belong to a single
                  experiment  (CONCT = 'C').

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= (M+L)*2*NOBR*(M+L+3),
                           if BATCH <> 'O' and CONCT = 'C';
          LDWORK >= (M+L)*2*NOBR*(M+L+1),
                           if BATCH = 'F' or 'I' and CONCT = 'N';
          LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR,
                           if BATCH = 'L' and CONCT = 'N',
                           or BATCH = 'O'.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  the number of 100 cycles in sequential data
                processing has been exhausted without signaling
                that the last block of data was get.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the fast QR factorization algorithm failed. The
                matrix H'*H is not (numerically) positive definite.
Method 
  Consider the  t x 2(m+l)s  matrix H of concatenated block Hankel
  matrices

       H = [ Uf'         Up'      Y'      ],  for METH = 'M',
               s+1,2s,t    1,s,t   1,2s,t

       H = [ U'       Y'      ],              for METH = 'N',
              1,2s,t   1,2s,t

  where  Up     , Uf        , U      , and  Y        are block
           1,s,t    s+1,2s,t   1,2s,t        1,2s,t
  Hankel matrices defined in terms of the input and output data [3].
  The fast QR algorithm uses a factorization of H'*H which exploits
  the block-Hankel structure, via a displacement rank technique [5].
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error
      state-space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Verhaegen M.
      Subspace Model Identification. Part 3: Analysis of the
      ordinary output-error state-space model identification
      algorithm.
      Int. J. Control, 58, pp. 555-586, 1993.

  [3] Verhaegen M.
      Identification of the deterministic part of MIMO state space
      models given in innovations form from input-output data.
      Automatica, Vol.30, No.1, pp.61-74, 1994.

  [4] Van Overschee, P., and De Moor, B.
      N4SID: Subspace Algorithms for the Identification of
      Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [5] Kressner, D., Mastronardi, N., Sima, V., Van Dooren, P., and
      Van Huffel, S.
      A Fast Algorithm for Subspace State-space System
      Identification via Exploitation of the Displacement Structure.
      J. Comput. Appl. Math., Vol.132, No.1, pp. 71-81, 2001.
Numerical Aspects 
  The implemented method is reliable and efficient. Numerical
  difficulties are possible when the matrix H'*H is nearly rank
  defficient. The method cannot be used if the matrix H'*H is not
  numerically positive definite.
                                  2           3 2
  The algorithm requires 0(2t(m+l) s)+0(4(m+l) s ) floating point
  operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01ND.html000077500000000000000000000221031201767322700160570ustar00rootroot00000000000000 IB01ND - SLICOT Library Routine Documentation

IB01ND

Singular value decomposition giving the system order

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find the singular value decomposition (SVD) giving the system
  order, using the triangular factor of the concatenated block
  Hankel matrices. Related preliminary calculations needed for
  computing the system matrices are also performed.
Specification 
      SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK,
     $                   DWORK, LDWORK, IWARN, INFO )
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(*)
Arguments

Mode Parameters 

  METH    CHARACTER*1
          Specifies the subspace identification method to be used,
          as follows:
          = 'M':  MOESP  algorithm with past inputs and outputs;
          = 'N':  N4SID  algorithm.

  JOBD    CHARACTER*1
          Specifies whether or not the matrices B and D should later
          be computed using the MOESP approach, as follows:
          = 'M':  the matrices B and D should later be computed
                  using the MOESP approach;
          = 'N':  the matrices B and D should not be computed using
                  the MOESP approach.
          This parameter is not relevant for METH = 'N'.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          block Hankel matrices.  NOBR > 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  R       (input/output) DOUBLE PRECISION array, dimension
          ( LDR,2*(M+L)*NOBR )
          On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper
          triangular part of this array must contain the upper
          triangular factor R from the QR factorization of the
          concatenated block Hankel matrices. Denote  R_ij,
          i,j = 1:4,  the ij submatrix of  R,  partitioned by
          M*NOBR,  M*NOBR,  L*NOBR,  and  L*NOBR  rows and columns.
          On exit, if INFO = 0, the leading
          2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this
          array contains the matrix S, the processed upper
          triangular factor R, as required by other subroutines.
          Specifically, let  S_ij, i,j = 1:4,  be the ij submatrix
          of  S,  partitioned by  M*NOBR,  L*NOBR,  M*NOBR,  and
          L*NOBR  rows and columns. The submatrix  S_22  contains
          the matrix of left singular vectors needed subsequently.
          Useful information is stored in  S_11  and in the
          block-column  S_14 : S_44.  For METH = 'M' and JOBD = 'M',
          the upper triangular part of  S_31  contains the upper
          triangular factor in the QR factorization of the matrix
          R_1c = [ R_12'  R_22'  R_11' ]',  and  S_12  contains the
          corresponding leading part of the transformed matrix
          R_2c = [ R_13'  R_23'  R_14' ]'.  For  METH = 'N',  the
          subarray  S_41 : S_43  contains the transpose of the
          matrix contained in  S_14 : S_34.

  LDR     INTEGER
          The leading dimension of the array  R.
          LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ),
                               for METH = 'M' and JOBD = 'M';
          LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or
                               for METH = 'N'.

  SV      (output) DOUBLE PRECISION array, dimension ( L*NOBR )
          The singular values of the relevant part of the triangular
          factor from the QR factorization of the concatenated block
          Hankel matrices.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  an m-by-n matrix whose estimated
          condition number is less than  1/TOL  is considered to
          be of full rank.  If the user sets  TOL <= 0,  then an
          implicitly computed, default tolerance, defined by
          TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
          relative machine precision (see LAPACK Library routine
          DLAMCH).
          This parameter is not used for  METH = 'M'.
Workspace 
  IWORK   INTEGER array, dimension ((M+L)*NOBR)
          This parameter is not referenced for METH = 'M'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK,  and, for  METH = 'N',  DWORK(2)  and  DWORK(3)
          contain the reciprocal condition numbers of the
          triangular factors of the matrices  U_f  and  r_1  [6].
          On exit, if  INFO = -12,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ),
                                      if METH = 'M' and JOBD = 'M';
          LDWORK >=  5*L*NOBR,        if METH = 'M' and JOBD = 'N';
          LDWORK >=  5*(M+L)*NOBR+1,  if METH = 'N'.
          For good performance,  LDWORK  should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  the least squares problems with coefficient matrix
                U_f,  used for computing the weighted oblique
                projection (for METH = 'N'), have a rank-deficient
                coefficient matrix;
          = 5:  the least squares problem with coefficient matrix
                r_1  [6], used for computing the weighted oblique
                projection (for METH = 'N'), has a rank-deficient
                coefficient matrix.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 2:  the singular value decomposition (SVD) algorithm did
                not converge.
Method 
  A singular value decomposition (SVD) of a certain matrix is
  computed, which reveals the order  n  of the system as the number
  of "non-zero" singular values. For the MOESP approach, this matrix
  is  [ R_24'  R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s),
  where  R  is the upper triangular factor  R  constructed by SLICOT
  Library routine  IB01MD.  For the N4SID approach, a weighted
  oblique projection is computed from the upper triangular factor  R
  and its SVD is then found.
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error
      state-space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Verhaegen M.
      Subspace Model Identification. Part 3: Analysis of the
      ordinary output-error state-space model identification
      algorithm.
      Int. J. Control, 58, pp. 555-586, 1993.

  [3] Verhaegen M.
      Identification of the deterministic part of MIMO state space
      models given in innovations form from input-output data.
      Automatica, Vol.30, No.1, pp.61-74, 1994.

  [4] Van Overschee, P., and De Moor, B.
      N4SID: Subspace Algorithms for the Identification of
      Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [5] Van Overschee, P., and De Moor, B.
      Subspace Identification for Linear Systems: Theory -
      Implementation - Applications.
      Kluwer Academic Publishers, Boston/London/Dordrecht, 1996.

  [6] Sima, V.
      Subspace-based Algorithms for Multivariable System
      Identification.
      Studies in Informatics and Control, 5, pp. 335-344, 1996.
Numerical Aspects 
  The implemented method is numerically stable.
                                   3
  The algorithm requires 0(((m+l)s) ) floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01OD.html000077500000000000000000000075231201767322700160710ustar00rootroot00000000000000 IB01OD - SLICOT Library Routine Documentation

IB01OD

Estimating the system order

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the system order, based on the singular values of the
  relevant part of the triangular factor of the concatenated block
  Hankel matrices.
Specification 
      SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, N, NOBR
      CHARACTER          CTRL
C     .. Array Arguments ..
      DOUBLE PRECISION   SV(*)
Arguments

Mode Parameters 

  CTRL    CHARACTER*1
          Specifies whether or not the user's confirmation of the
          system order estimate is desired, as follows:
          = 'C':  user's confirmation;
          = 'N':  no confirmation.
          If  CTRL = 'C',  a reverse communication routine,  IB01OY,
          is called, and, after inspecting the singular values and
          system order estimate,  n,  the user may accept  n  or set
          a new value.
          IB01OY  is not called by the routine if CTRL = 'N'.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the processed input and
          output block Hankel matrices.  NOBR > 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  SV      (input) DOUBLE PRECISION array, dimension ( L*NOBR )
          The singular values of the relevant part of the triangular
          factor from the QR factorization of the concatenated block
          Hankel matrices.

  N       (output) INTEGER
          The estimated order of the system.
Tolerances 
  TOL     DOUBLE PRECISION
          Absolute tolerance used for determining an estimate of
          the system order. If  TOL >= 0,  the estimate is
          indicated by the index of the last singular value greater
          than or equal to  TOL.  (Singular values less than  TOL
          are considered as zero.) When  TOL = 0,  an internally
          computed default value,  TOL = NOBR*EPS*SV(1),  is used,
          where  SV(1)  is the maximal singular value, and  EPS  is
          the relative machine precision (see LAPACK Library routine
          DLAMCH). When  TOL < 0,  the estimate is indicated by the
          index of the singular value that has the largest
          logarithmic gap to its successor.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 3:  all singular values were exactly zero, hence  N = 0.
                (Both input and output were identically zero.)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The singular values are compared to the given, or default TOL, and
  the estimated order  n  is returned, possibly after user's
  confirmation.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01OY.html000077500000000000000000000043771201767322700161220ustar00rootroot00000000000000 IB01OY - SLICOT Library Routine Documentation

IB01OY

User's confirmation of the system order

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To ask for user's confirmation of the system order found by
  SLICOT Library routine IB01OD. This routine may be modified,
  but its interface must be preserved.
Specification 
      SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, N, NMAX, NS
C     .. Array Arguments ..
      DOUBLE PRECISION   SV( * )
Arguments

Input/Output Parameters 

  NS      (input) INTEGER
          The number of singular values.  NS > 0.

  NMAX    (input) INTEGER
          The maximum value of the system order.  0 <= NMAX <= NS.

  N       (input/output) INTEGER
          On entry, the estimate of the system order computed by
          IB01OD routine.  0 <= N <= NS.
          On exit, the user's estimate of the system order, which
          could be identical with the input value of  N.
          Note that the output value of  N  should be less than
          or equal to  NMAX.

  SV      (input) DOUBLE PRECISION array, dimension ( NS )
          The singular values, in descending order, used for
          determining the system order.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01PD.html000077500000000000000000000410531201767322700160660ustar00rootroot00000000000000 IB01PD - SLICOT Library Routine Documentation

IB01PD

Estimating system matrices and covariances

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the matrices A, C, B, and D of a linear time-invariant
  (LTI) state space model, using the singular value decomposition
  information provided by other routines. Optionally, the system and
  noise covariance matrices, needed for the Kalman gain, are also
  determined.
Specification 
      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     .. 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( * )
Arguments

Mode Parameters 

  METH    CHARACTER*1
          Specifies the subspace identification method to be used,
          as follows:
          = 'M':  MOESP  algorithm with past inputs and outputs;
          = 'N':  N4SID  algorithm.

  JOB     CHARACTER*1
          Specifies which matrices should be computed, as follows:
          = 'A':  compute all system matrices, A, B, C, and D;
          = 'C':  compute the matrices A and C only;
          = 'B':  compute the matrix B only;
          = 'D':  compute the matrices B and D only.

  JOBCV   CHARACTER*1
          Specifies whether or not the covariance matrices are to
          be computed, as follows:
          = 'C':  the covariance matrices should be computed;
          = 'N':  the covariance matrices should not be computed.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          Hankel matrices processed by other routines.  NOBR > 1.

  N       (input) INTEGER
          The order of the system.  NOBR > N > 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMPL   (input) INTEGER
          If JOBCV = 'C', the total number of samples used for
          calculating the covariance matrices.
          NSMPL >= 2*(M+L)*NOBR.
          This parameter is not meaningful if  JOBCV = 'N'.

  R       (input/workspace) DOUBLE PRECISION array, dimension
          ( LDR,2*(M+L)*NOBR )
          On entry, the leading  2*(M+L)*NOBR-by-2*(M+L)*NOBR  part
          of this array must contain the relevant data for the MOESP
          or N4SID algorithms, as constructed by SLICOT Library
          routines IB01AD or IB01ND. Let  R_ij,  i,j = 1:4,  be the
          ij submatrix of  R  (denoted  S  in IB01AD and IB01ND),
          partitioned by  M*NOBR,  L*NOBR,  M*NOBR,  and  L*NOBR
          rows and columns. The submatrix  R_22  contains the matrix
          of left singular vectors used. Also needed, for
          METH = 'N'  or  JOBCV = 'C',  are the submatrices  R_11,
          R_14 : R_44,  and, for  METH = 'M'  and  JOB <> 'C',  the
          submatrices  R_31  and  R_12,  containing the processed
          matrices  R_1c  and  R_2c,  respectively, as returned by
          SLICOT Library routines IB01AD or IB01ND.
          Moreover, if  METH = 'N'  and  JOB = 'A' or 'C',  the
          block-row  R_41 : R_43  must contain the transpose of the
          block-column  R_14 : R_34  as returned by SLICOT Library
          routines IB01AD or IB01ND.
          The remaining part of  R  is used as workspace.
          On exit, part of this array is overwritten. Specifically,
          if  METH = 'M',  R_22  and  R_31  are overwritten if
              JOB = 'B' or 'D',  and  R_12,  R_22,  R_14 : R_34,
              and possibly  R_11  are overwritten if  JOBCV = 'C';
          if  METH = 'N',  all needed submatrices are overwritten.

  LDR     INTEGER
          The leading dimension of the array  R.
          LDR >= 2*(M+L)*NOBR.

  A       (input or output) DOUBLE PRECISION array, dimension
          (LDA,N)
          On entry, if  METH = 'N'  and  JOB = 'B' or 'D',  the
          leading N-by-N part of this array must contain the system
          state matrix.
          If  METH = 'M'  or  (METH = 'N'  and JOB = 'A' or 'C'),
          this array need not be set on input.
          On exit, if  JOB = 'A' or 'C'  and  INFO = 0,  the
          leading N-by-N part of this array contains the system
          state matrix.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= N,  if  JOB = 'A' or 'C',  or  METH = 'N'  and
                         JOB = 'B' or 'D';
          LDA >= 1,  otherwise.

  C       (input or output) DOUBLE PRECISION array, dimension
          (LDC,N)
          On entry, if  METH = 'N'  and  JOB = 'B' or 'D',  the
          leading L-by-N part of this array must contain the system
          output matrix.
          If  METH = 'M'  or  (METH = 'N'  and JOB = 'A' or 'C'),
          this array need not be set on input.
          On exit, if  JOB = 'A' or 'C'  and  INFO = 0,  or
          INFO = 3  (or  INFO >= 0,  for  METH = 'M'),  the leading
          L-by-N part of this array contains the system output
          matrix.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= L,  if  JOB = 'A' or 'C',  or  METH = 'N'  and
                         JOB = 'B' or 'D';
          LDC >= 1,  otherwise.

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          If  M > 0,  JOB = 'A', 'B', or 'D'  and  INFO = 0,  the
          leading N-by-M part of this array contains the system
          input matrix. If  M = 0  or  JOB = 'C',  this array is
          not referenced.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= N,  if M > 0 and JOB = 'A', 'B', or 'D';
          LDB >= 1,  if M = 0 or  JOB = 'C'.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          If  M > 0,  JOB = 'A' or 'D'  and  INFO = 0,  the leading
          L-by-M part of this array contains the system input-output
          matrix. If  M = 0  or  JOB = 'C' or 'B',  this array is
          not referenced.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= L,  if M > 0 and JOB = 'A' or 'D';
          LDD >= 1,  if M = 0 or  JOB = 'C' or 'B'.

  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
          If JOBCV = 'C', the leading N-by-N part of this array
          contains the positive semidefinite state covariance matrix
          to be used as state weighting matrix when computing the
          Kalman gain.
          This parameter is not referenced if JOBCV = 'N'.

  LDQ     INTEGER
          The leading dimension of the array Q.
          LDQ >= N,  if JOBCV = 'C';
          LDQ >= 1,  if JOBCV = 'N'.

  RY      (output) DOUBLE PRECISION array, dimension (LDRY,L)
          If JOBCV = 'C', the leading L-by-L part of this array
          contains the positive (semi)definite output covariance
          matrix to be used as output weighting matrix when
          computing the Kalman gain.
          This parameter is not referenced if JOBCV = 'N'.

  LDRY    INTEGER
          The leading dimension of the array RY.
          LDRY >= L,  if JOBCV = 'C';
          LDRY >= 1,  if JOBCV = 'N'.

  S       (output) DOUBLE PRECISION array, dimension (LDS,L)
          If JOBCV = 'C', the leading N-by-L part of this array
          contains the state-output cross-covariance matrix to be
          used as cross-weighting matrix when computing the Kalman
          gain.
          This parameter is not referenced if JOBCV = 'N'.

  LDS     INTEGER
          The leading dimension of the array S.
          LDS >= N,  if JOBCV = 'C';
          LDS >= 1,  if JOBCV = 'N'.

  O       (output) DOUBLE PRECISION array, dimension ( LDO,N )
          If  METH = 'M'  and  JOBCV = 'C',  or  METH = 'N',
          the leading  L*NOBR-by-N  part of this array contains
          the estimated extended observability matrix, i.e., the
          first  N  columns of the relevant singular vectors.
          If  METH = 'M'  and  JOBCV = 'N',  this array is not
          referenced.

  LDO     INTEGER
          The leading dimension of the array  O.
          LDO >= L*NOBR,  if  JOBCV = 'C'  or  METH = 'N';
          LDO >= 1,       otherwise.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  an m-by-n matrix whose estimated
          condition number is less than  1/TOL  is considered to
          be of full rank.  If the user sets  TOL <= 0,  then an
          implicitly computed, default tolerance, defined by
          TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
          relative machine precision (see LAPACK Library routine
          DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = N,                   if METH = 'M' and M = 0
                                     or JOB = 'C' and JOBCV = 'N';
          LIWORK = M*NOBR+N,            if METH = 'M', JOB = 'C',
                                        and JOBCV = 'C';
          LIWORK = max(L*NOBR,M*NOBR),  if METH = 'M', JOB <> 'C',
                                        and JOBCV = 'N';
          LIWORK = max(L*NOBR,M*NOBR+N),  if METH = 'M', JOB <> 'C',
                                          and JOBCV = 'C';
          LIWORK = max(M*NOBR+N,M*(N+L)), if METH = 'N'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK,  and  DWORK(2),  DWORK(3),  DWORK(4),  and
          DWORK(5)  contain the reciprocal condition numbers of the
          triangular factors of the matrices, defined in the code,
          GaL  (GaL = Un(1:(s-1)*L,1:n)),  R_1c  (if  METH = 'M'),
          M  (if  JOBCV = 'C'  or  METH = 'N'),  and  Q  or  T  (see
          SLICOT Library routines IB01PY or IB01PX),  respectively.
          If  METH = 'N',  DWORK(3)  is set to one without any
          calculations. Similarly, if  METH = 'M'  and  JOBCV = 'N',
          DWORK(4)  is set to one. If  M = 0  or  JOB = 'C',
          DWORK(3)  and  DWORK(5)  are set to one.
          On exit, if  INFO = -30,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( LDW1,LDW2 ), where, if METH = 'M',
          LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ),
                  if JOB = 'C' or JOB = 'A' and M = 0;
          LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N,
                       (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+
                       max( L+M*NOBR, L*NOBR +
                                      max( 3*L*NOBR+1, M ) ) )
                  if M > 0 and JOB = 'A', 'B', or 'D';
          LDW2 >= 0,                                 if JOBCV = 'N';
          LDW2 >= max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L),
                       4*(M*NOBR+N)+1, M*NOBR+2*N+L ),
                                                     if JOBCV = 'C',
          where Aw = N+N*N, if M = 0 or JOB = 'C';
                Aw = 0,     otherwise;
          and, if METH = 'N',
          LDW1 >= max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L,
                       2*(L*NOBR-L)*N+N*N+8*N, N+4*(M*NOBR+N)+1,
                       M*NOBR+3*N+L );
          LDW2 >= 0, if M = 0 or JOB = 'C';
          LDW2 >= M*NOBR*(N+L)*(M*(N+L)+1)+
                  max( (N+L)**2, 4*M*(N+L)+1 ),
                  if M > 0 and JOB = 'A', 'B', or 'D'.
          For good performance,  LDWORK  should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  a least squares problem to be solved has a
                rank-deficient coefficient matrix;
          = 5:  the computed covariance matrices are too small.
                The problem seems to be a deterministic one.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 2:  the singular value decomposition (SVD) algorithm did
                not converge;
          = 3:  a singular upper triangular matrix was found.
Method 
  In the MOESP approach, the matrices  A  and  C  are first
  computed from an estimated extended observability matrix [1],
  and then, the matrices  B  and  D  are obtained by solving an
  extended linear system in a least squares sense.
  In the N4SID approach, besides the estimated extended
  observability matrix, the solutions of two least squares problems
  are used to build another least squares problem, whose solution
  is needed to compute the system matrices  A,  C,  B,  and  D.  The
  solutions of the two least squares problems are also optionally
  used by both approaches to find the covariance matrices.
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error state-
      space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Van Overschee, P., and De Moor, B.
      N4SID: Two Subspace Algorithms for the Identification
      of Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [3] Van Overschee, P.
      Subspace Identification : Theory - Implementation -
      Applications.
      Ph. D. Thesis, Department of Electrical Engineering,
      Katholieke Universiteit Leuven, Belgium, Feb. 1995.

  [4] Sima, V.
      Subspace-based Algorithms for Multivariable System
      Identification.
      Studies in Informatics and Control, 5, pp. 335-344, 1996.
Numerical Aspects 
  The implemented method is numerically stable.
Further Comments 
  In some applications, it is useful to compute the system matrices
  using two calls to this routine, the first one with  JOB = 'C',
  and the second one with  JOB = 'B' or 'D'.  This is slightly less
  efficient than using a single call with  JOB = 'A',  because some
  calculations are repeated. If  METH = 'N',  all the calculations
  at the first call are performed again at the second call;
  moreover, it is required to save the needed submatrices of  R
  before the first call and restore them before the second call.
  If the covariance matrices are desired,  JOBCV  should be set
  to  'C'  at the second call. If  B  and  D  are both needed, they
  should be computed at once.
  It is possible to compute the matrices A and C using the MOESP
  algorithm (METH = 'M'), and the matrices B and D using the N4SID
  algorithm (METH = 'N'). This combination could be slightly more
  efficient than N4SID algorithm alone and it could be more accurate
  than MOESP algorithm. No saving/restoring is needed in such a
  combination, provided  JOBCV  is set to  'N'  at the first call.
  Recommended usage:  either one call with  JOB = 'A',  or
     first  call with  METH = 'M',  JOB = 'C',  JOBCV = 'N',
     second call with  METH = 'M',  JOB = 'D',  JOBCV = 'C',  or
     first  call with  METH = 'M',  JOB = 'C',  JOBCV = 'N',
     second call with  METH = 'N',  JOB = 'D',  JOBCV = 'C'.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01PX.html000077500000000000000000000245761201767322700161250ustar00rootroot00000000000000 IB01PX - SLICOT Library Routine Documentation

IB01PX

Estimating system matrices B and D using Kronecker products

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To build and solve the least squares problem  T*X = Kv,  and
  estimate the matrices B and D of a linear time-invariant (LTI)
  state space model, using the solution  X,  and the singular
  value decomposition information and other intermediate results,
  provided by other routines.

  The matrix  T  is computed as a sum of Kronecker products,

     T = T + kron(Uf(:,(i-1)*m+1:i*m),N_i),  for i = 1 : s,

  (with  T  initialized by zero), where  Uf  is the triangular
  factor of the QR factorization of the future input part (see
  SLICOT Library routine IB01ND),  N_i  is given by the i-th block
  row of the matrix

         [ Q_11  Q_12  ...  Q_1,s-2  Q_1,s-1  Q_1s ]   [ I_L  0  ]
         [ Q_12  Q_13  ...  Q_1,s-1    Q_1s    0   ]   [         ]
     N = [ Q_13  Q_14  ...    Q_1s      0      0   ] * [         ],
         [  :     :            :        :      :   ]   [         ]
         [ Q_1s   0    ...     0        0      0   ]   [  0  GaL ]

  and where

            [   -L_1|1    ]          [ M_i-1 - L_1|i ]
     Q_11 = [             ],  Q_1i = [               ],  i = 2:s,
            [ I_L - L_2|1 ]          [     -L_2|i    ]

  are  (n+L)-by-L  matrices, and  GaL  is built from the first  n
  relevant singular vectors,  GaL = Un(1:L(s-1),1:n),  computed
  by IB01ND.

  The vector  Kv  is vec(K), with the matrix  K  defined by

     K = [ K_1  K_2  K_3  ...  K_s ],

  where  K_i = K(:,(i-1)*m+1:i*m),  i = 1:s,  is  (n+L)-by-m.
  The given matrices are  Uf,  GaL,  and

         [ L_1|1  ...  L_1|s ]
     L = [                   ],   (n+L)-by-L*s,
         [ L_2|1  ...  L_2|s ]

     M = [ M_1  ...  M_s-1 ],      n-by-L*(s-1),  and
     K,                            (n+L)-by-m*s.

  Matrix  M  is the pseudoinverse of the matrix  GaL,  computed by
  SLICOT Library routine IB01PD.
Specification 
      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     .. 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( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies which of the matrices B and D should be
          computed, as follows:
          = 'B':  compute the matrix B, but not the matrix D;
          = 'D':  compute both matrices B and D.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          Hankel matrices processed by other routines.  NOBR > 1.

  N       (input) INTEGER
          The order of the system.  NOBR > N > 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  UF      (input/output) DOUBLE PRECISION array, dimension
          ( LDUF,M*NOBR )
          On entry, the leading  M*NOBR-by-M*NOBR  upper triangular
          part of this array must contain the upper triangular
          factor of the QR factorization of the future input part,
          as computed by SLICOT Library routine IB01ND.
          The strict lower triangle need not be set to zero.
          On exit, the leading  M*NOBR-by-M*NOBR  upper triangular
          part of this array is unchanged, and the strict lower
          triangle is set to zero.

  LDUF    INTEGER
          The leading dimension of the array  UF.
          LDUF >= MAX( 1, M*NOBR ).

  UN      (input) DOUBLE PRECISION array, dimension ( LDUN,N )
          The leading  L*(NOBR-1)-by-N  part of this array must
          contain the matrix  GaL,  i.e., the leading part of the
          first  N  columns of the matrix  Un  of relevant singular
          vectors.

  LDUN    INTEGER
          The leading dimension of the array  UN.
          LDUN >= L*(NOBR-1).

  UL      (input/output) DOUBLE PRECISION array, dimension
          ( LDUL,L*NOBR )
          On entry, the leading  (N+L)-by-L*NOBR  part of this array
          must contain the given matrix  L.
          On exit, if  M > 0,  the leading  (N+L)-by-L*NOBR  part of
          this array is overwritten by the matrix
          [ Q_11  Q_12  ...  Q_1,s-2  Q_1,s-1  Q_1s ].

  LDUL    INTEGER
          The leading dimension of the array  UL.  LDUL >= N+L.

  PGAL    (input) DOUBLE PRECISION array, dimension
          ( LDPGAL,L*(NOBR-1) )
          The leading  N-by-L*(NOBR-1)  part of this array must
          contain the pseudoinverse of the matrix  GaL,  computed by
          SLICOT Library routine IB01PD.

  LDPGAL  INTEGER
          The leading dimension of the array  PGAL.  LDPGAL >= N.

  K       (input) DOUBLE PRECISION array, dimension ( LDK,M*NOBR )
          The leading  (N+L)-by-M*NOBR  part of this array must
          contain the given matrix  K.

  LDK     INTEGER
          The leading dimension of the array  K.  LDK >= N+L.

  R       (output) DOUBLE PRECISION array, dimension ( LDR,M*(N+L) )
          The leading  (N+L)*M*NOBR-by-M*(N+L)  part of this array
          contains details of the complete orthogonal factorization
          of the coefficient matrix  T  of the least squares problem
          which is solved for getting the system matrices B and D.

  LDR     INTEGER
          The leading dimension of the array  R.
          LDR >= MAX( 1, (N+L)*M*NOBR ).

  X       (output) DOUBLE PRECISION array, dimension
          ( (N+L)*M*NOBR )
          The leading  M*(N+L)  elements of this array contain the
          least squares solution of the system  T*X = Kv.
          The remaining elements are used as workspace (to store the
          corresponding part of the vector Kv = vec(K)).

  B       (output) DOUBLE PRECISION array, dimension ( LDB,M )
          The leading N-by-M part of this array contains the system
          input matrix.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N.

  D       (output) DOUBLE PRECISION array, dimension ( LDD,M )
          If  JOB = 'D',  the leading L-by-M part of this array
          contains the system input-output matrix.
          If  JOB = 'B',  this array is not referenced.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= L, if  JOB = 'D';
          LDD >= 1, if  JOB = 'B'.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  an m-by-n matrix whose estimated
          condition number is less than  1/TOL  is considered to
          be of full rank.  If the user sets  TOL <= 0,  then an
          implicitly computed, default tolerance, defined by
          TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
          relative machine precision (see LAPACK Library routine
          DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension ( M*(N+L) )

  DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK,  and, if  M > 0,  DWORK(2)  contains the
          reciprocal condition number of the triangular factor of
          the matrix  T.
          On exit, if  INFO = -26,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( (N+L)*(N+L), 4*M*(N+L)+1 ).
          For good performance,  LDWORK  should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  the least squares problem to be solved has a
                rank-deficient coefficient matrix.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix  T  is computed, evaluating the sum of Kronecker
  products, and then the linear system  T*X = Kv  is solved in a
  least squares sense. The matrices  B  and  D  are then directly
  obtained from the least squares solution.
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error
      state-space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Van Overschee, P., and De Moor, B.
      N4SID: Two Subspace Algorithms for the Identification
      of Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [3] Van Overschee, P.
      Subspace Identification : Theory - Implementation -
      Applications.
      Ph. D. Thesis, Department of Electrical Engineering,
      Katholieke Universiteit Leuven, Belgium, Feb. 1995.
Numerical Aspects 
  The implemented method is numerically stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01PY.html000077500000000000000000000364041201767322700161170ustar00rootroot00000000000000 IB01PY - SLICOT Library Routine Documentation

IB01PY

Estimating system matrices B and D using a structure exploiting QR factorization

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  1. To compute the triangular  (QR)  factor of the  p-by-L*s
  structured matrix  Q,

      [ Q_1s  Q_1,s-1  Q_1,s-2  ...  Q_12  Q_11 ]
      [  0      Q_1s   Q_1,s-1  ...  Q_13  Q_12 ]
  Q = [  0       0       Q_1s   ...  Q_14  Q_13 ],
      [  :       :        :           :     :   ]
      [  0       0        0     ...   0    Q_1s ]

  and apply the transformations to the p-by-m matrix  Kexpand,

            [ K_1 ]
            [ K_2 ]
  Kexpand = [ K_3 ],
            [  :  ]
            [ K_s ]

  where, for MOESP approach (METH = 'M'), p = s*(L*s-n), and
  Q_1i = u2(L*(i-1)+1:L*i,:)'  is  (Ls-n)-by-L,  for  i = 1:s,
  u2 = Un(1:L*s,n+1:L*s),  K_i = K(:,(i-1)*m+1:i*m)  (i = 1:s)
  is  (Ls-n)-by-m, and for N4SID approach (METH = 'N'), p = s*(n+L),
  and

            [   -L_1|1    ]          [ M_i-1 - L_1|i ]
     Q_11 = [             ],  Q_1i = [               ],  i = 2:s,
            [ I_L - L_2|1 ]          [     -L_2|i    ]

  are  (n+L)-by-L  matrices, and
  K_i = K(:,(i-1)*m+1:i*m),  i = 1:s,  is  (n+L)-by-m.
  The given matrices are:
  For  METH = 'M',  u2 = Un(1:L*s,n+1:L*s),
                    K(1:Ls-n,1:m*s);

                        [ L_1|1  ...  L_1|s ]
  For  METH = 'N',  L = [                   ],   (n+L)-by-L*s,
                        [ L_2|1  ...  L_2|s ]

                    M = [ M_1  ...  M_s-1 ],  n-by-L*(s-1),  and
                    K,                        (n+L)-by-m*s.
                    Matrix M is the pseudoinverse of the matrix GaL,
                    built from the first  n  relevant singular
                    vectors,  GaL = Un(1:L(s-1),1:n),  and computed
                    by SLICOT Library routine IB01PD for METH = 'N'.

  Matrix  Q  is triangularized  (in  R),  exploiting its structure,
  and the transformations are applied from the left to  Kexpand.

  2. To estimate the matrices B and D of a linear time-invariant
  (LTI) state space model, using the factor  R,  transformed matrix
  Kexpand, and the singular value decomposition information provided
  by other routines.

  IB01PY  routine is intended for speed and efficient use of the
  memory space. It is generally not recommended for  METH = 'N',  as
  IB01PX  routine can produce more accurate results.
Specification 
      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     .. 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( * )
Arguments

Mode Parameters 

  METH    CHARACTER*1
          Specifies the subspace identification method to be used,
          as follows:
          = 'M':  MOESP  algorithm with past inputs and outputs;
          = 'N':  N4SID  algorithm.

  JOB     CHARACTER*1
          Specifies whether or not the matrices B and D should be
          computed, as follows:
          = 'B':  compute the matrix B, but not the matrix D;
          = 'D':  compute both matrices B and D;
          = 'N':  do not compute the matrices B and D, but only the
                  R  factor of  Q  and the transformed Kexpand.
Input/Output Parameters 
  NOBR    (input) INTEGER
          The number of block rows,  s,  in the input and output
          Hankel matrices processed by other routines.  NOBR > 1.

  N       (input) INTEGER
          The order of the system.  NOBR > N > 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  RANKR1  (input) INTEGER
          The effective rank of the upper triangular matrix  r1,
          i.e., the triangular QR factor of the matrix  GaL,
          computed by SLICOT Library routine IB01PD. It is also
          the effective rank of the matrix  GaL.  0 <= RANKR1 <= N.
          If  JOB = 'N',  or  M = 0,  or  METH = 'N',  this
          parameter is not used.

  UL      (input/workspace) DOUBLE PRECISION array, dimension
          ( LDUL,L*NOBR )
          On entry, if  METH = 'M',  the leading  L*NOBR-by-L*NOBR
          part of this array must contain the matrix  Un  of
          relevant singular vectors. The first  N  columns of  UN
          need not be specified for this routine.
          On entry, if  METH = 'N',  the leading  (N+L)-by-L*NOBR
          part of this array must contain the given matrix  L.
          On exit, the leading  LDF-by-L*(NOBR-1) part of this array
          is overwritten by the matrix  F  of the algorithm in [4],
          where  LDF = MAX( 1, L*NOBR-N-L ), if  METH = 'M';
                 LDF = N,                    if  METH = 'N'.

  LDUL    INTEGER
          The leading dimension of the array  UL.
          LDUL >= L*NOBR, if  METH = 'M';
          LDUL >= N+L,    if  METH = 'N'.

  R1      (input) DOUBLE PRECISION array, dimension ( LDR1,N )
          If  JOB <> 'N',  M > 0,  METH = 'M',  and  RANKR1 = N,
          the leading  L*(NOBR-1)-by-N  part of this array must
          contain details of the QR factorization of the matrix
          GaL,  as computed by SLICOT Library routine IB01PD.
          Specifically, the leading N-by-N upper triangular part
          must contain the upper triangular factor  r1  of  GaL,
          and the lower  L*(NOBR-1)-by-N  trapezoidal part, together
          with array TAU1, must contain the factored form of the
          orthogonal matrix  Q1  in the QR factorization of  GaL.
          If  JOB = 'N',  or  M = 0,  or  METH = 'N', or  METH = 'M'
          and  RANKR1 < N,  this array is not referenced.

  LDR1    INTEGER
          The leading dimension of the array  R1.
          LDR1 >= L*(NOBR-1), if  JOB <> 'N',  M > 0,  METH = 'M',
                              and  RANKR1 = N;
          LDR1 >= 1,          otherwise.

  TAU1    (input) DOUBLE PRECISION array, dimension ( N )
          If  JOB <> 'N',  M > 0,  METH = 'M',  and  RANKR1 = N,
          this array must contain the scalar factors of the
          elementary reflectors used in the QR factorization of the
          matrix  GaL,  computed by SLICOT Library routine IB01PD.
          If  JOB = 'N',  or  M = 0,  or  METH = 'N', or  METH = 'M'
          and  RANKR1 < N,  this array is not referenced.

  PGAL    (input) DOUBLE PRECISION array, dimension
          ( LDPGAL,L*(NOBR-1) )
          If  METH = 'N',  or  JOB <> 'N',  M > 0,  METH = 'M'  and
          RANKR1 < N,  the leading  N-by-L*(NOBR-1)  part of this
          array must contain the pseudoinverse of the matrix  GaL,
          as computed by SLICOT Library routine IB01PD.
          If  METH = 'M'  and  JOB = 'N',  or  M = 0,  or
          RANKR1 = N,  this array is not referenced.

  LDPGAL  INTEGER
          The leading dimension of the array  PGAL.
          LDPGAL >= N,  if   METH = 'N',  or  JOB <> 'N',  M > 0,
                        and  METH = 'M'  and RANKR1 < N;
          LDPGAL >= 1,  otherwise.

  K       (input/output) DOUBLE PRECISION array, dimension
          ( LDK,M*NOBR )
          On entry, the leading  (p/s)-by-M*NOBR  part of this array
          must contain the given matrix  K  defined above.
          On exit, the leading  (p/s)-by-M*NOBR  part of this array
          contains the transformed matrix  K.

  LDK     INTEGER
          The leading dimension of the array  K.  LDK >= p/s.

  R       (output) DOUBLE PRECISION array, dimension ( LDR,L*NOBR )
          If  JOB = 'N',  or  M = 0,  or  Q  has full rank, the
          leading  L*NOBR-by-L*NOBR  upper triangular part of this
          array contains the  R  factor of the QR factorization of
          the matrix  Q.
          If  JOB <> 'N',  M > 0,  and  Q  has not a full rank, the
          leading  L*NOBR-by-L*NOBR  upper trapezoidal part of this
          array contains details of the complete orhogonal
          factorization of the matrix  Q,  as constructed by SLICOT
          Library routines MB03OD and MB02QY.

  LDR     INTEGER
          The leading dimension of the array  R.  LDR >= L*NOBR.

  H       (output) DOUBLE PRECISION array, dimension ( LDH,M )
          If  JOB = 'N'  or  M = 0,  the leading  L*NOBR-by-M  part
          of this array contains the updated part of the matrix
          Kexpand  corresponding to the upper triangular factor  R
          in the QR factorization of the matrix  Q.
          If  JOB <> 'N',  M > 0,  and  METH = 'N'  or  METH = 'M'
          and  RANKR1 < N,  the leading  L*NOBR-by-M  part of this
          array contains the minimum norm least squares solution of
          the linear system  Q*X = Kexpand,  from which the matrices
          B  and  D  are found. The first  NOBR-1  row blocks of  X
          appear in the reverse order in  H.
          If  JOB <> 'N',  M > 0,  METH = 'M'  and  RANKR1 = N,  the
          leading  L*(NOBR-1)-by-M  part of this array contains the
          matrix product  Q1'*X,  and the subarray
          L*(NOBR-1)+1:L*NOBR-by-M  contains the  corresponding
          submatrix of  X,  with  X  defined in the phrase above.

  LDH     INTEGER
          The leading dimension of the array  H.  LDH >= L*NOBR.

  B       (output) DOUBLE PRECISION array, dimension ( LDB,M )
          If  M > 0,  JOB = 'B' or 'D'  and  INFO = 0,  the leading
          N-by-M part of this array contains the system input
          matrix.
          If  M = 0  or  JOB = 'N',  this array is not referenced.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= N, if  M > 0 and JOB = 'B' or 'D';
          LDB >= 1, if  M = 0 or  JOB = 'N'.

  D       (output) DOUBLE PRECISION array, dimension ( LDD,M )
          If  M > 0,  JOB = 'D'  and  INFO = 0,  the leading
          L-by-M part of this array contains the system input-output
          matrix.
          If  M = 0  or  JOB = 'B'  or  'N',  this array is not
          referenced.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= L, if  M > 0 and JOB = 'D';
          LDD >= 1, if  M = 0 or  JOB = 'B' or 'N'.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  an m-by-n matrix whose estimated
          condition number is less than  1/TOL  is considered to
          be of full rank.  If the user sets  TOL <= 0,  then an
          implicitly computed, default tolerance, defined by
          TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
          relative machine precision (see LAPACK Library routine
          DLAMCH).
          This parameter is not used if  M = 0  or  JOB = 'N'.
Workspace 
  IWORK   INTEGER array, dimension ( LIWORK )
          where  LIWORK >= 0,       if  JOB =  'N',  or   M = 0;
                 LIWORK >= L*NOBR,  if  JOB <> 'N',  and  M > 0.

  DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of  LDWORK,  and, if  JOB <> 'N',  and  M > 0,  DWORK(2)
          contains the reciprocal condition number of the triangular
          factor of the matrix  R.
          On exit, if  INFO = -28,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 2*L, L*NOBR, L+M*NOBR ),
                                      if  JOB = 'N',  or  M = 0;
          LDWORK >= MAX( L+M*NOBR, L*NOBR + MAX( 3*L*NOBR+1, M ) ),
                                      if  JOB <> 'N',  and  M > 0.
          For good performance,  LDWORK  should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  the least squares problem to be solved has a
                rank-deficient coefficient matrix.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 3:  a singular upper triangular matrix was found.
Method 
  The QR factorization is computed exploiting the structure,
  as described in [4].
  The matrices  B  and  D  are then obtained by solving certain
  linear systems in a least squares sense.
References 
  [1] Verhaegen M., and Dewilde, P.
      Subspace Model Identification. Part 1: The output-error
      state-space model identification class of algorithms.
      Int. J. Control, 56, pp. 1187-1210, 1992.

  [2] Van Overschee, P., and De Moor, B.
      N4SID: Two Subspace Algorithms for the Identification
      of Combined Deterministic-Stochastic Systems.
      Automatica, Vol.30, No.1, pp. 75-93, 1994.

  [3] Van Overschee, P.
      Subspace Identification : Theory - Implementation -
      Applications.
      Ph. D. Thesis, Department of Electrical Engineering,
      Katholieke Universiteit Leuven, Belgium, Feb. 1995.

  [4] Sima, V.
      Subspace-based Algorithms for Multivariable System
      Identification.
      Studies in Informatics and Control, 5, pp. 335-344, 1996.
Numerical Aspects 
  The implemented method for computing the triangular factor and
  updating Kexpand is numerically stable.
Further Comments 
  The computed matrices B and D are not the least squares solutions
  delivered by either MOESP or N4SID algorithms, except for the
  special case n = s - 1, L = 1. However, the computed B and D are
  frequently good enough estimates, especially for  METH = 'M'.
  Better estimates could be obtained by calling SLICOT Library
  routine IB01PX, but it is less efficient, and requires much more
  workspace.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01QD.html000077500000000000000000000341351201767322700160720ustar00rootroot00000000000000 IB01QD - SLICOT Library Routine Documentation

IB01QD

Estimating initial state and system matrices B and D, given A, C, and input-output trajectories

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the initial state and the system matrices  B  and  D
  of a linear time-invariant (LTI) discrete-time system, given the
  matrix pair  (A,C)  and the input and output trajectories of the
  system. The model structure is :

        x(k+1) = Ax(k) + Bu(k),   k >= 0,
        y(k)   = Cx(k) + Du(k),

  where  x(k)  is the  n-dimensional state vector (at time k),
         u(k)  is the  m-dimensional input vector,
         y(k)  is the  l-dimensional output vector,
  and  A, B, C, and D  are real matrices of appropriate dimensions.
  Matrix  A  is assumed to be in a real Schur form.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOBX0   CHARACTER*1
          Specifies whether or not the initial state should be
          computed, as follows:
          = 'X':  compute the initial state x(0);
          = 'N':  do not compute the initial state (x(0) is known
                  to be zero).

  JOB     CHARACTER*1
          Specifies which matrices should be computed, as follows:
          = 'B':  compute the matrix B only (D is known to be zero);
          = 'D':  compute the matrices B and D.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMP    (input) INTEGER
          The number of rows of matrices  U  and  Y  (number of
          samples,  t).
          NSMP >= N*M + a + e,  where
          a = 0,  if  JOBX0 = 'N';
          a = N,  if  JOBX0 = 'X';
          e = 0,  if  JOBX0 = 'X'  and  JOB = 'B';
          e = 1,  if  JOBX0 = 'N'  and  JOB = 'B';
          e = M,  if  JOB   = 'D'.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix  A  in a real Schur form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading L-by-N part of this array must contain the
          system output matrix  C  (corresponding to the real Schur
          form of  A).

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= L.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,M)
          On entry, the leading NSMP-by-M part of this array must
          contain the t-by-m input-data sequence matrix  U,
          U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
          NSMP  values of the j-th input component for consecutive
          time increments.
          On exit, if  JOB = 'D',  the leading NSMP-by-M part of
          this array contains details of the QR factorization of
          the t-by-m matrix  U, possibly computed sequentially
          (see METHOD).
          If  JOB = 'B',  this array is unchanged on exit.
          If M = 0, this array is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= MAX(1,NSMP),  if M > 0;
          LDU >= 1,            if M = 0.

  Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
          The leading NSMP-by-L part of this array must contain the
          t-by-l output-data sequence matrix  Y,
          Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
          NSMP  values of the j-th output component for consecutive
          time increments.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= MAX(1,NSMP).

  X0      (output) DOUBLE PRECISION array, dimension (N)
          If  JOBX0 = 'X',  the estimated initial state of the
          system,  x(0).
          If  JOBX0 = 'N',  x(0)  is set to zero without any
          calculations.

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          If  N > 0,  M > 0,  and  INFO = 0,  the leading N-by-M
          part of this array contains the system input matrix  B
          in the coordinates corresponding to the real Schur form
          of  A.
          If  N = 0  or  M = 0,  this array is not referenced.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= N,  if  N > 0  and  M > 0;
          LDB >= 1,  if  N = 0  or   M = 0.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          If  M > 0,  JOB = 'D',  and  INFO = 0,  the leading
          L-by-M part of this array contains the system input-output
          matrix  D.
          If  M = 0  or  JOB = 'B',  this array is not referenced.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= L,  if  M > 0  and  JOB = 'D';
          LDD >= 1,  if  M = 0  or   JOB = 'B'.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  a matrix whose estimated condition
          number is less than  1/TOL  is considered to be of full
          rank.  If the user sets  TOL <= 0,  then  EPS  is used
          instead, where  EPS  is the relative machine precision
          (see LAPACK Library routine DLAMCH).  TOL <= 1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK), where
          LIWORK >= N*M + a,            if  JOB = 'B',
          LIWORK >= max( N*M + a, M ),  if  JOB = 'D',
          with  a = 0,  if  JOBX0 = 'N';
                a = N,  if  JOBX0 = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK;  DWORK(2)  contains the reciprocal condition
          number of the triangular factor of the QR factorization of
          the matrix  W2  (see METHOD); if  M > 0  and  JOB = 'D',
          DWORK(3)  contains the reciprocal condition number of the
          triangular factor of the QR factorization of  U.
          On exit, if  INFO = -23,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( LDW1, min( LDW2, LDW3 ) ),  where
          LDW1 = 2,          if  M = 0  or   JOB = 'B',
          LDW1 = 3,          if  M > 0  and  JOB = 'D',
          LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ),
          LDW2 = LDWa,       if  M = 0  or  JOB = 'B',
          LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ),
                             if  M > 0  and JOB = 'D',
          LDWb = (b + r)*(r + 1) +
                  max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ),
          LDW3 = LDWb,       if  M = 0  or  JOB = 'B',
          LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ),
                             if  M > 0  and JOB = 'D',
             r = N*M + a,
             a = 0,                  if  JOBX0 = 'N',
             a = N,                  if  JOBX0 = 'X';
             b = 0,                  if  JOB   = 'B',
             b = L*M,                if  JOB   = 'D';
             c = 0,                  if  JOBX0 = 'N',
             c = L*N,                if  JOBX0 = 'X';
             d = 0,                  if  JOBX0 = 'N',
             d = 2*N*N + N,          if  JOBX0 = 'X';
             f = 2*r,                if  JOB   = 'B'   or  M = 0,
             f = M + max( 2*r, M ),  if  JOB   = 'D'  and  M > 0;
             q = b + r*L.
          For good performance,  LDWORK  should be larger.
          If  LDWORK >= LDW2  or
              LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c +
                        max( d, f ),
          then standard QR factorizations of the matrices  U  and/or
          W2  (see METHOD) are used.
          Otherwise, the QR factorizations are computed sequentially
          by performing  NCYCLE  cycles, each cycle (except possibly
          the last one) processing  s < t  samples, where  s  is
          chosen from the equation
            LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c +
                     max( d, f ).
          (s  is at least  N*M+a+e,  the minimum value of  NSMP.)
          The computational effort may increase and the accuracy may
          decrease with the decrease of  s.  Recommended value is
          LDWORK = LDW2,  assuming a large enough cache size, to
          also accommodate  A,  C,  U,  and  Y.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  the least squares problem to be solved has a
                rank-deficient coefficient matrix.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 2:  the singular value decomposition (SVD) algorithm did
                not converge.
Method 
  An extension and refinement of the method in [1,2] is used.
  Specifically, denoting

        X = [ vec(D')' vec(B)' x0' ]',

  where  vec(M)  is the vector obtained by stacking the columns of
  the matrix  M,  then  X  is the least squares solution of the
  system  S*X = vec(Y),  with the matrix  S = [ diag(U)  W ],
  defined by

        ( U         |     | ... |     |     | ... |     |         )
        (   U       |  11 | ... |  n1 |  12 | ... |  nm |         )
    S = (     :     | y   | ... | y   | y   | ... | y   | P*Gamma ),
        (       :   |     | ... |     |     | ... |     |         )
        (         U |     | ... |     |     | ... |     |         )
                                                                  ij
  diag(U)  having  L  block rows and columns.  In this formula,  y
  are the outputs of the system for zero initial state computed
  using the following model, for j = 1:m, and for i = 1:n,
         ij          ij                    ij
        x  (k+1) = Ax  (k) + e_i u_j(k),  x  (0) = 0,

         ij          ij
        y  (k)   = Cx  (k),

  where  e_i  is the i-th n-dimensional unit vector,  Gamma  is
  given by

             (     C     )
             (    C*A    )
     Gamma = (   C*A^2   ),
             (     :     )
             ( C*A^(t-1) )

  and  P  is a permutation matrix that groups together the rows of
  Gamma  depending on the same row of  C,  namely
  [ c_j;  c_j*A;  c_j*A^2; ...  c_j*A^(t-1) ],  for j = 1:L.
  The first block column,  diag(U),  is not explicitly constructed,
  but its structure is exploited. The last block column is evaluated
  using powers of A with exponents 2^k. No interchanges are applied.
  A special QR decomposition of the matrix  S  is computed. Let
  U = q*[ r' 0 ]'  be the QR decomposition of  U,  if  M > 0,  where
  r  is  M-by-M.   Then,  diag(q')  is applied to  W  and  vec(Y).
  The block-rows of  S  and  vec(Y)  are implicitly permuted so that
  matrix  S  becomes

     ( diag(r)  W1 )
     (    0     W2 ),

  where  W1  has L*M rows. Then, the QR decomposition of  W2 is
  computed (sequentially, if  M > 0) and used to obtain  B  and  x0.
  The intermediate results and the QR decomposition of  U  are
  needed to find  D.  If a triangular factor is too ill conditioned,
  then singular value decomposition (SVD) is employed. SVD is not
  generally needed if the input sequence is sufficiently
  persistently exciting and  NSMP  is large enough.
  If the matrix  W  cannot be stored in the workspace (i.e.,
  LDWORK < LDW2),  the QR decompositions of  W2  and  U  are
  computed sequentially.
References 
  [1] Verhaegen M., and Varga, A.
      Some Experience with the MOESP Class of Subspace Model
      Identification Methods in Identifying the BO105 Helicopter.
      Report TR R165-94, DLR Oberpfaffenhofen, 1994.

  [2] Sima, V., and Varga, A.
      RASP-IDENT : Subspace Model Identification Programs.
      Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V.,
      Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994.
Numerical Aspects 
  The implemented method is numerically stable.
Further Comments 
  The algorithm for computing the system matrices  B  and  D  is
  less efficient than the MOESP or N4SID algorithms implemented in
  SLICOT Library routine IB01PD, because a large least squares
  problem has to be solved, but the accuracy is better, as the
  computed matrices  B  and  D  are fitted to the input and output
  trajectories. However, if matrix  A  is unstable, the computed
  matrices  B  and  D  could be inaccurate.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB01RD.html000077500000000000000000000222221201767322700160650ustar00rootroot00000000000000 IB01RD - SLICOT Library Routine Documentation

IB01RD

Estimating initial state, given A, B, C, D, and input-output trajectories

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the initial state of a linear time-invariant (LTI)
  discrete-time system, given the system matrices  (A,B,C,D)  and
  the input and output trajectories of the system. The model
  structure is :

        x(k+1) = Ax(k) + Bu(k),   k >= 0,
        y(k)   = Cx(k) + Du(k),

  where  x(k)  is the  n-dimensional state vector (at time k),
         u(k)  is the  m-dimensional input vector,
         y(k)  is the  l-dimensional output vector,
  and  A, B, C, and D  are real matrices of appropriate dimensions.
  Matrix  A  is assumed to be in a real Schur form.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies whether or not the matrix D is zero, as follows:
          = 'Z':  the matrix  D  is zero;
          = 'N':  the matrix  D  is not zero.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L > 0.

  NSMP    (input) INTEGER
          The number of rows of matrices  U  and  Y  (number of
          samples used,  t).  NSMP >= N.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix  A  in a real Schur form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix  B  (corresponding to the real Schur
          form of  A).
          If  N = 0  or  M = 0,  this array is not referenced.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= N,  if  N > 0  and  M > 0;
          LDB >= 1,  if  N = 0  or   M = 0.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading L-by-N part of this array must contain the
          system output matrix  C  (corresponding to the real Schur
          form of  A).

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= L.

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading L-by-M part of this array must contain the
          system input-output matrix.
          If  M = 0  or  JOB = 'Z',  this array is not referenced.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= L,  if  M > 0  and  JOB = 'N';
          LDD >= 1,  if  M = 0  or   JOB = 'Z'.

  U       (input) DOUBLE PRECISION array, dimension (LDU,M)
          If  M > 0,  the leading NSMP-by-M part of this array must
          contain the t-by-m input-data sequence matrix  U,
          U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
          NSMP  values of the j-th input component for consecutive
          time increments.
          If M = 0, this array is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= MAX(1,NSMP),  if M > 0;
          LDU >= 1,            if M = 0.

  Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
          The leading NSMP-by-L part of this array must contain the
          t-by-l output-data sequence matrix  Y,
          Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
          NSMP  values of the j-th output component for consecutive
          time increments.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= MAX(1,NSMP).

  X0      (output) DOUBLE PRECISION array, dimension (N)
          The estimated initial state of the system,  x(0).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for estimating the rank of
          matrices. If the user sets  TOL > 0,  then the given value
          of  TOL  is used as a lower bound for the reciprocal
          condition number;  a matrix whose estimated condition
          number is less than  1/TOL  is considered to be of full
          rank.  If the user sets  TOL <= 0,  then  EPS  is used
          instead, where  EPS  is the relative machine precision
          (see LAPACK Library routine DLAMCH).  TOL <= 1.
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK and  DWORK(2)  contains the reciprocal condition
          number of the triangular factor of the QR factorization of
          the matrix  Gamma  (see METHOD).
          On exit, if  INFO = -22,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( 2, min( LDW1, LDW2 ) ),  where
          LDW1 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ),
          LDW2 =   N*(N + 1) + 2*N +
                   max( q*(N + 1) + 2*N*N + L*N, 4*N ),
             q = N*L.
          For good performance,  LDWORK  should be larger.
          If  LDWORK >= LDW1,  then standard QR factorization of
          the matrix  Gamma  (see METHOD) is used. Otherwise, the
          QR factorization is computed sequentially by performing
          NCYCLE  cycles, each cycle (except possibly the last one)
          processing  s  samples, where  s  is chosen by equating
          LDWORK  to  LDW2,  for  q  replaced by  s*L.
          The computational effort may increase and the accuracy may
          decrease with the decrease of  s.  Recommended value is
          LDRWRK = LDW1,  assuming a large enough cache size, to
          also accommodate  A, B, C, D, U,  and  Y.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 4:  the least squares problem to be solved has a
                rank-deficient coefficient matrix.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 2:  the singular value decomposition (SVD) algorithm did
                not converge.
Method 
  An extension and refinement of the method in [1] is used.
  Specifically, the output y0(k) of the system for zero initial
  state is computed for k = 0, 1, ...,  t-1 using the given model.
  Then the following least squares problem is solved for x(0)

                      (     C     )            (   y(0) - y0(0)   )
                      (    C*A    )            (   y(1) - y0(1)   )
     Gamma * x(0)  =  (     :     ) * x(0)  =  (        :         ).
                      (     :     )            (        :         )
                      ( C*A^(t-1) )            ( y(t-1) - y0(t-1) )

  The coefficient matrix  Gamma  is evaluated using powers of A with
  exponents 2^k. The QR decomposition of this matrix is computed.
  If its triangular factor  R  is too ill conditioned, then singular
  value decomposition of  R  is used.

  If the coefficient matrix cannot be stored in the workspace (i.e.,
  LDWORK < LDW1),  the QR decomposition is computed sequentially.
References 
  [1] Verhaegen M., and Varga, A.
      Some Experience with the MOESP Class of Subspace Model
      Identification Methods in Identifying the BO105 Helicopter.
      Report TR R165-94, DLR Oberpfaffenhofen, 1994.
Numerical Aspects 
  The implemented method is numerically stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/IB03AD.html000077500000000000000000002017121201767322700160510ustar00rootroot00000000000000 IB03AD - SLICOT Library Routine Documentation

IB03AD

Estimating parameters of a Wiener system using Levenberg-Marquardt algorithm

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a set of parameters for approximating a Wiener system
  in a least-squares sense, using a neural network approach and a
  Levenberg-Marquardt algorithm. Conjugate gradients (CG) or
  Cholesky algorithms are used to solve linear systems of equations.
  The Wiener system is represented as

     x(t+1) = A*x(t) + B*u(t)
     z(t)   = C*x(t) + D*u(t),

     y(t)   = f(z(t),wb(1:L)),

  where t = 1, 2, ..., NSMP, and f is a nonlinear function,
  evaluated by the SLICOT Library routine NF01AY. The parameter
  vector X is partitioned as X = ( wb(1), ..., wb(L), theta ),
  where wb(i), i = 1 : L, correspond to the nonlinear part, and
  theta corresponds to the linear part. See SLICOT Library routine
  NF01AD for further details.

  The sum of squares of the error functions, defined by

     e(t) = y(t) - Y(t),  t = 1, 2, ..., NSMP,

  is minimized, where Y(t) is the measured output vector. The
  functions and their Jacobian matrices are evaluated by SLICOT
  Library routine NF01BB (the FCN routine in the call of MD03AD).
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  INIT    CHARACTER*1
          Specifies which parts have to be initialized, as follows:
          = 'L' : initialize the linear part only, X already
                  contains an initial approximation of the
                  nonlinearity;
          = 'S' : initialize the static nonlinearity only, X
                  already contains an initial approximation of the
                  linear part;
          = 'B' : initialize both linear and nonlinear parts;
          = 'N' : do not initialize anything, X already contains
                  an initial approximation.
          If INIT = 'S' or 'B', the error functions for the
          nonlinear part, and their Jacobian matrices, are evaluated
          by SLICOT Library routine NF01BA (used as a second FCN
          routine in the MD03AD call for the initialization step,
          see METHOD).

  ALG     CHARACTER*1
          Specifies the algorithm used for solving the linear
          systems involving a Jacobian matrix J, as follows:
          = 'D' :  a direct algorithm, which computes the Cholesky
                   factor of the matrix J'*J + par*I is used, where
                   par is the Levenberg factor;
          = 'I' :  an iterative Conjugate Gradients algorithm, which
                   only needs the matrix J, is used.
          In both cases, matrix J is stored in a compressed form.

  STOR    CHARACTER*1
          If ALG = 'D', specifies the storage scheme for the
          symmetric matrix J'*J, as follows:
          = 'F' :  full storage is used;
          = 'P' :  packed storage is used.
          The option STOR = 'F' usually ensures a faster execution.
          This parameter is not relevant if ALG = 'I'.
Input/Output Parameters 
  NOBR    (input) INTEGER
          If INIT = 'L' or 'B', NOBR is the number of block rows, s,
          in the input and output block Hankel matrices to be
          processed for estimating the linear part.  NOBR > 0.
          (In the MOESP theory,  NOBR  should be larger than  n,
          the estimated dimension of state vector.)
          This parameter is ignored if INIT is 'S' or 'N'.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L >= 0, and L > 0, if
          INIT = 'L' or 'B'.

  NSMP    (input) INTEGER
          The number of input and output samples, t.  NSMP >= 0, and
          NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'.

  N       (input/output) INTEGER
          The order of the linear part.
          If INIT = 'L' or 'B', and N < 0 on entry, the order is
          assumed unknown and it will be found by the routine.
          Otherwise, the input value will be used. If INIT = 'S'
          or 'N', N must be non-negative. The values N >= NOBR,
          or N = 0, are not acceptable if INIT = 'L' or 'B'.

  NN      (input) INTEGER
          The number of neurons which shall be used to approximate
          the nonlinear part.  NN >= 0.

  ITMAX1  (input) INTEGER
          The maximum number of iterations for the initialization of
          the static nonlinearity.
          This parameter is ignored if INIT is 'N' or 'L'.
          Otherwise, ITMAX1 >= 0.

  ITMAX2  (input) INTEGER
          The maximum number of iterations.  ITMAX2 >= 0.

  NPRINT  (input) INTEGER
          This parameter enables controlled printing of iterates if
          it is positive. In this case, FCN is called with IFLAG = 0
          at the beginning of the first iteration and every NPRINT
          iterations thereafter and immediately prior to return,
          and the current error norm is printed. Other intermediate
          results could be printed by modifying the corresponding
          FCN routine (NF01BA and/or NF01BB). If NPRINT <= 0, no
          special calls of FCN with IFLAG = 0 are made.

  U       (input) DOUBLE PRECISION array, dimension (LDU, M)
          The leading NSMP-by-M part of this array must contain the
          set of input samples,
          U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ).

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,NSMP).

  Y       (input) DOUBLE PRECISION array, dimension (LDY, L)
          The leading NSMP-by-L part of this array must contain the
          set of output samples,
          Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ).

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= MAX(1,NSMP).

  X       (input/output) DOUBLE PRECISION array dimension (LX)
          On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part
          of this array must contain the initial parameters for
          the nonlinear part of the system.
          On entry, if INIT = 'S', the elements lin1 : lin2 of this
          array must contain the initial parameters for the linear
          part of the system, corresponding to the output normal
          form, computed by SLICOT Library routine TB01VD, where
             lin1 = (NN*(L+2) + 1)*L + 1;
             lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M.
          On entry, if INIT = 'N', the elements 1 : lin2 of this
          array must contain the initial parameters for the
          nonlinear part followed by the initial parameters for the
          linear part of the system, as specified above.
          This array need not be set on entry if INIT = 'B'.
          On exit, the elements 1 : lin2 of this array contain the
          optimal parameters for the nonlinear part followed by the
          optimal parameters for the linear part of the system, as
          specified above.

  LX      (input/output) INTEGER
          On entry, this parameter must contain the intended length
          of X. If N >= 0, then LX >= NX := lin2 (see parameter X).
          If N is unknown (N < 0 on entry), a large enough estimate
          of N should be used in the formula of lin2.
          On exit, if N < 0 on entry, but LX is not large enough,
          then this parameter contains the actual length of X,
          corresponding to the computed N. Otherwise, its value
          is unchanged.
Tolerances 
  TOL1    DOUBLE PRECISION
          If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance
          which measures the relative error desired in the sum of
          squares, for the initialization step of nonlinear part.
          Termination occurs when the actual relative reduction in
          the sum of squares is at most TOL1. In addition, if
          ALG = 'I', TOL1 also measures the relative residual of
          the solutions computed by the CG algorithm (for the
          initialization step). Termination of a CG process occurs
          when the relative residual is at most TOL1.
          If the user sets  TOL1 < 0,  then  SQRT(EPS)  is used
          instead TOL1, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH).
          This parameter is ignored if INIT is 'N' or 'L'.

  TOL2    DOUBLE PRECISION
          If TOL2 >= 0, TOL2 is the tolerance which measures the
          relative error desired in the sum of squares, for the
          whole optimization process. Termination occurs when the
          actual relative reduction in the sum of squares is at
          most TOL2.
          If ALG = 'I', TOL2 also measures the relative residual of
          the solutions computed by the CG algorithm (for the whole
          optimization). Termination of a CG process occurs when the
          relative residual is at most TOL2.
          If the user sets  TOL2 < 0,  then  SQRT(EPS)  is used
          instead TOL2. This default value could require many
          iterations, especially if TOL1 is larger. If INIT = 'S'
          or 'B', it is advisable that TOL2 be larger than TOL1,
          and spend more time with cheaper iterations.
Workspace 
  IWORK   INTEGER array, dimension (MAX( 3, LIW1, LIW2 )), where
          LIW1 = LIW2 = 0,  if INIT = 'S' or 'N'; otherwise,
          LIW1 = M+L;
          LIW2 = MAX(M*NOBR+N,M*(N+L)).
          On output, if INFO = 0, IWORK(1) and IWORK(2) return the
          (total) number of function and Jacobian evaluations,
          respectively (including the initialization step, if it was
          performed), and if INIT = 'L' or INIT = 'B', IWORK(3)
          specifies how many locations of DWORK contain reciprocal
          condition number estimates (see below); otherwise,
          IWORK(3) = 0.

  DWORK   DOUBLE PRECISION array dimesion (LDWORK)
          On entry, if desired, and if INIT = 'S' or 'B', the
          entries DWORK(1:4) are set to initialize the random
          numbers generator for the nonlinear part parameters (see
          the description of the argument XINIT of SLICOT Library
          routine MD03AD); this enables to obtain reproducible
          results. The same seed is used for all outputs.
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, DWORK(2) returns the residual error norm (the
          sum of squares), DWORK(3) returns the number of iterations
          performed, DWORK(4) returns the number of conjugate
          gradients iterations performed, and DWORK(5) returns the
          final Levenberg factor, for optimizing the parameters of
          both the linear part and the static nonlinearity part.
          If INIT = 'S' or INIT = 'B' and INFO = 0, then the
          elements DWORK(6) to DWORK(10) contain the corresponding
          five values for the initialization step (see METHOD).
          (If L > 1, DWORK(10) contains the maximum of the Levenberg
          factors for all outputs.) If INIT = 'L' or INIT = 'B', and
          INFO = 0, DWORK(11) to DWORK(10+IWORK(3)) contain
          reciprocal condition number estimates set by SLICOT
          Library routines IB01AD, IB01BD, and IB01CD.
          On exit, if  INFO = -23,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          In the formulas below, N should be taken not larger than
          NOBR - 1, if N < 0 on entry.
          LDWORK = MAX( LW1, LW2, LW3, LW4 ), where
          LW1 = 0, if INIT = 'S' or 'N'; otherwise,
          LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR,
                     4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) +
                     MAX( LDW1, LDW2 ),
                     (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) +
                     MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ),
              where,
              LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N,
                           L*NOBR*N +
                           MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L,
                                2*(L*NOBR-L)*N+N*N+8*N,
                                N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) )
              LDW2 >= 0,                                  if M = 0;
              LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) +
                      MAX( (N+L)**2, 4*M*(N+L)+1 ),       if M > 0;
              LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ),
              LDW4 = N*(N+1) + 2*N +
                     MAX( N*L*(N+1) + 2*N*N + L*N, 4*N );
              LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L;
              LDW6 = NSMP*L + (N+L)*(N+M) + N +
                     MAX(1, N*N*L + N*L + N, N*N +
                         MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L),
                             N*M));
          LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise,
          LW2 = NSMP*L +
                MAX( 5, NSMP + 2*BSN + NSMP*BSN +
                        MAX( 2*NN + BSN, LDW7 ) );
              LDW7 = BSN*BSN,       if ALG = 'D' and STOR = 'F';
              LDW7 = BSN*(BSN+1)/2, if ALG = 'D' and STOR = 'P';
              LDW7 = 3*BSN + NSMP,  if ALG = 'I';
          LW3 = MAX( LDW8, NSMP*L + (N+L)*(2*N+M) + 2*N );
              LDW8 = NSMP*L + (N+L)*(N+M) + 3*N+M+L,  if M > 0;
              LDW8 = NSMP*L + (N+L)*N + 2*N+L,        if M = 0;
          LW4 = MAX( 5, NSMP*L + 2*NX + NSMP*L*( BSN + LTHS ) +
                        MAX( L1 + NX, NSMP*L + L1, L2 ) ),
               L0 = MAX( N*(N+L), N+M+L ),    if M > 0;
               L0 = MAX( N*(N+L), L ),        if M = 0;
               L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0);
               L2 = NX*NX,          if ALG = 'D' and STOR = 'F';
               L2 = NX*(NX+1)/2,    if ALG = 'D' and STOR = 'P';
               L2 = 3*NX + NSMP*L,  if ALG = 'I',
               with BSN  = NN*( L + 2 ) + 1,
                    LTHS = N*( L + M + 1 ) + L*M.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          < 0:  the user set IFLAG = IWARN in (one of) the
                subroutine(s) FCN, i.e., NF01BA, if INIT = 'S'
                or 'B', and/or NF01BB; this value cannot be returned
                without changing the FCN routine(s);
                otherwise, IWARN has the value k*100 + j*10 + i,
                where k is defined below, i refers to the whole
                optimization process, and j refers to the
                initialization step (j = 0, if INIT = 'L' or 'N'),
                and the possible values for i and j have the
                following meaning (where TOL* denotes TOL1 or TOL2,
                and similarly for ITMAX*):
          = 1:  the number of iterations has reached ITMAX* without
                satisfying the convergence condition;
          = 2:  if alg = 'I' and in an iteration of the Levenberg-
                Marquardt algorithm, the CG algorithm finished
                after 3*NX iterations (or 3*(lin1-1) iterations, for
                the initialization phase), without achieving the
                precision required in the call;
          = 3:  the cosine of the angle between the vector of error
                function values and any column of the Jacobian is at
                most FACTOR*EPS in absolute value (FACTOR = 100);
          = 4:  TOL* is too small: no further reduction in the sum
                of squares is possible.
          The digit k is normally 0, but if INIT = 'L' or 'B', it
          can have a value in the range 1 to 6 (see IB01AD, IB01BD
          and IB01CD). In all these cases, the entries DWORK(1:5),
          DWORK(6:10) (if INIT = 'S' or 'B'), and
          DWORK(11:10+IWORK(3)) (if INIT = 'L' or 'B'), are set as
          described above.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
                otherwise, INFO has the value k*100 + j*10 + i,
                where k is defined below, i refers to the whole
                optimization process, and j refers to the
                initialization step (j = 0, if INIT = 'L' or 'N'),
                and the possible values for i and j have the
                following meaning:
          = 1:  the routine FCN returned with INFO <> 0 for
                IFLAG = 1;
          = 2:  the routine FCN returned with INFO <> 0 for
                IFLAG = 2;
          = 3:  ALG = 'D' and SLICOT Library routines MB02XD or
                NF01BU (or NF01BV, if INIT = 'S' or 'B') or
                ALG = 'I' and SLICOT Library routines MB02WD or
                NF01BW (or NF01BX, if INIT = 'S' or 'B') returned
                with INFO <> 0.
          In addition, if INIT = 'L' or 'B', i could also be
          = 4:  if a Lyapunov equation could not be solved;
          = 5:  if the identified linear system is unstable;
          = 6:  if the QR algorithm failed on the state matrix
                of the identified linear system.
          The digit k is normally 0, but if INIT = 'L' or 'B', it
          can have a value in the range 1 to 10 (see IB01AD/IB01BD).
Method 
  If INIT = 'L' or 'B', the linear part of the system is
  approximated using the combined MOESP and N4SID algorithm. If
  necessary, this algorithm can also choose the order, but it is
  advantageous if the order is already known.

  If INIT = 'S' or 'B', the output of the approximated linear part
  is computed and used to calculate an approximation of the static
  nonlinearity using the Levenberg-Marquardt algorithm [1].
  This step is referred to as the (nonlinear) initialization step.

  As last step, the Levenberg-Marquardt algorithm is used again to
  optimize the parameters of the linear part and the static
  nonlinearity as a whole. Therefore, it is necessary to parametrise
  the matrices of the linear part. The output normal form [2]
  parameterisation is used.

  The Jacobian is computed analytically, for the nonlinear part, and
  numerically, for the linear part.
References 
  [1] Kelley, C.T.
      Iterative Methods for Optimization.
      Society for Industrial and Applied Mathematics (SIAM),
      Philadelphia (Pa.), 1999.

  [2] Peeters, R.L.M., Hanzon, B., and Olivi, M.
      Balanced realizations of discrete-time stable all-pass
      systems and the tangential Schur algorithm.
      Proceedings of the European Control Conference,
      31 August - 3 September 1999, Karlsruhe, Germany.
      Session CP-6, Discrete-time Systems, 1999.
Further Comments 
  None
Example

Program Text 

*     IB03AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           LDU, LDY, LIWORK, LMAX, MMAX, NMAX, NNMAX,
     $                  NOBRMX, NSMPMX
      PARAMETER         ( LMAX = 2, MMAX = 3, NOBRMX = 10, NNMAX = 12,
     $                    NMAX = 4, NSMPMX = 1024,
     $                    LDU  = NSMPMX, LDY = NSMPMX,
     $                    LIWORK = MAX( MMAX + LMAX, MMAX*NOBRMX + NMAX,
     $                                  MMAX*( NMAX + LMAX ) ) )
      INTEGER           BSNM, L0, L1M, L2M, LDW1, LDW2, LDW3, LDW4,
     $                  LDW5, LDW6, LDW7, LDW8, LDWORK, LTHS, LW1, LW2,
     $                  LW3, LW4, LXM
      PARAMETER         ( BSNM = NNMAX*( LMAX + 2 ) + 1,
     $                    LTHS = NMAX*( LMAX + MMAX + 1 ) + LMAX*MMAX,
     $                    L0   = MAX( NMAX*( NMAX + LMAX ),
     $                                NMAX + MMAX + LMAX ),
     $                    L1M  = NSMPMX*LMAX +
     $                           MAX( 2*NNMAX,
     $                                ( NMAX + LMAX )*( NMAX + MMAX ) +
     $                                2*NMAX + L0 ),
     $                    LXM  = BSNM*LMAX + LTHS,
     $                    L2M  = MAX( LXM*LXM, 3*LXM + NSMPMX*LMAX ),
     $                    LDW1 = MAX( 2*( LMAX*NOBRMX - LMAX )*NMAX +
     $                                2*NMAX,
     $                                ( LMAX*NOBRMX - LMAX )*NMAX +
     $                                NMAX*NMAX + 7*NMAX,
     $                                LMAX*NOBRMX*NMAX +
     $                                MAX( ( LMAX*NOBRMX - LMAX )*NMAX +
     $                                     2*NMAX + LMAX +
     $                                     ( 2*MMAX + LMAX )*NOBRMX,
     $                                     2*( LMAX*NOBRMX - LMAX )*NMAX
     $                                   + NMAX*NMAX + 8*NMAX,
     $                                     NMAX + 4*( MMAX*NOBRMX +
     $                                                NMAX ) + 1,
     $                                     MMAX*NOBRMX + 3*NMAX + LMAX )
     $                              ),
     $                    LDW2 = LMAX*NOBRMX*NMAX +
     $                           MMAX*NOBRMX*( NMAX + LMAX )*
     $                           ( MMAX*( NMAX + LMAX ) + 1 ) +
     $                           MAX( ( NMAX + LMAX )**2,
     $                           4*MMAX*( NMAX + LMAX ) + 1 ),
     $                    LDW3 = NSMPMX*LMAX*( NMAX + 1 ) + 2*NMAX +
     $                           MAX( 2*NMAX*NMAX, 4*NMAX ),
     $                    LDW4 = NMAX*( NMAX + 1 ) + 2*NMAX +
     $                           MAX( NMAX*LMAX*( NMAX + 1 ) +
     $                           2*NMAX*NMAX + LMAX*NMAX, 4*NMAX ),
     $                    LDW5 = NSMPMX*LMAX + ( NMAX + LMAX )*
     $                           ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX,
     $                    LDW6 = NSMPMX*LMAX + ( NMAX + LMAX )*
     $                           ( NMAX + MMAX ) + NMAX +
     $                           MAX( 1, NMAX*NMAX*LMAX + NMAX*LMAX +
     $                                NMAX, NMAX*NMAX +
     $                                MAX( NMAX*NMAX +
     $                                     NMAX*MAX( NMAX, LMAX ) +
     $                                     6*NMAX + MIN( NMAX, LMAX ),
     $                                     NMAX*MMAX ) ),
     $                    LDW7 = MAX( BSNM*BSNM, 3*BSNM + NSMPMX ),
     $                    LDW8 = NSMPMX*LMAX + ( NMAX + LMAX )*
     $                           ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX,
     $                    LW1  = MAX( 2*( MMAX + LMAX )*NOBRMX*
     $                                ( 2*( MMAX + LMAX )*( NOBRMX + 1 )
     $                                  + 3 ) + LMAX*NOBRMX,
     $                                4*( MMAX + LMAX )*NOBRMX*
     $                                ( MMAX + LMAX )*NOBRMX +
     $                                ( NMAX + LMAX )*( NMAX + MMAX ) +
     $                                MAX( LDW1, LDW2 ),
     $                                ( NMAX + LMAX )*( NMAX + MMAX ) +
     $                                NMAX + NMAX*NMAX + 2 +
     $                                NMAX*( NMAX + MMAX + LMAX ) +
     $                                MAX( 5*NMAX, 2, MIN( LDW3, LDW4 ),
     $                                     LDW5, LDW6 ) ),
     $                    LW2  = NSMPMX*LMAX +
     $                           MAX( 5, NSMPMX + 2*BSNM + NSMPMX*BSNM +
     $                                   MAX( 2*NNMAX + BSNM, LDW7 ) ),
     $                    LW3  = MAX( LDW8, NSMPMX*LMAX +
     $                                ( NMAX + LMAX )*( 2*NMAX + MMAX )+
     $                                2*NMAX ),
     $                    LW4  = MAX( 5, NSMPMX*LMAX + 2*LXM +
     $                                NSMPMX*LMAX*( BSNM + LTHS ) +
     $                                MAX( L1M + LXM, NSMPMX*LMAX + L1M,
     $                                     L2M ) ),
     $                    LDWORK = MAX( LW1, LW2, LW3, LW4 ) )
*     .. Local Scalars ..
      LOGICAL           INIT1, INITB, INITL, INITN, INITS
      CHARACTER*1       ALG, INIT, STOR
      INTEGER           BSN, I, INFO, INI, ITER, ITERCG, ITMAX1, ITMAX2,
     $                  IWARN, J, L, L1, L2, LPAR, LX, M, N, NN, NOBR,
     $                  NPRINT, NS, NSMP
      DOUBLE PRECISION  TOL1, TOL2
*     .. Array Arguments ..
      INTEGER           IWORK(LIWORK)
      DOUBLE PRECISION  DWORK(LDWORK), U(LDU,MMAX), X(LXM), Y(LDY,LMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          IB03AD
*     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2,
     $                      NPRINT, TOL1, TOL2, INIT, ALG, STOR
      INITL = LSAME( INIT, 'L' )
      INITS = LSAME( INIT, 'S' )
      INITB = LSAME( INIT, 'B' )
      INITN = LSAME( INIT, 'N' )
      INIT1 = INITL .OR. INITB
      IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE
         IF( L.LE.0 .OR. L.GT.LMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) L
         ELSE
            NS = N
            IF( INIT1 ) THEN
               IF( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN
                  WRITE ( NOUT, FMT = 99991 ) NOBR
                  STOP
               ELSEIF( NSMP.LT.2*( M + L + 1 )*NOBR - 1 ) THEN
                  WRITE ( NOUT, FMT = 99990 ) NSMP
                  STOP
               ELSEIF( N.EQ.0 .OR. N.GE.NOBR ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N
                  STOP
               END IF
               IF ( N.LT.0 )
     $            N = NOBR - 1
            ELSE
               IF( NSMP.LT.0 ) THEN
                  WRITE ( NOUT, FMT = 99990 ) NSMP
                  STOP
               ELSEIF( N.LT.0 .OR. N.GT.NMAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N
                  STOP
               END IF
            END IF
            IF( NN.LT.0 .OR. NN.GT.NNMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) NN
            ELSE
               BSN = NN*( L + 2 ) + 1
               L1  = BSN*L
               L2  = N*( L + M + 1 ) + L*M
               LX  = L1 + L2
               INI = 1
               IF ( INITL ) THEN
                  LPAR = L1
               ELSEIF ( INITS ) THEN
                  INI  = L1 + 1
                  LPAR = L2
               ELSEIF ( INITN ) THEN
                  LPAR = LX
               END IF
               IF( INIT1 )
     $            N = NS
*              Read the input-output data, initial parameters, and seed.
               READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,NSMP )
               READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1,L ), I = 1,NSMP )
               IF ( .NOT.INITB )
     $            READ ( NIN, FMT = * ) ( X(I), I = INI,INI+LPAR-1 )
               IF ( INITS .OR. INITB )
     $            READ ( NIN, FMT = * ) ( DWORK(I), I = 1,4 )
*              Solve a Wiener system identification problem.
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99987 ) IWARN
                  ITER   = DWORK(3)
                  ITERCG = DWORK(4)
                  WRITE ( NOUT, FMT = 99997 ) DWORK(2)
                  WRITE ( NOUT, FMT = 99996 ) ITER, ITERCG,
     $                                        IWORK(1), IWORK(2)
*                 Recompute LX is necessary.
                  IF ( INIT1 .AND. NS.LT.0 )
     $               LX = L1 + N*( L + M + 1 ) + L*M
                  WRITE ( NOUT, FMT = 99994 )
                  WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, LX )
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' IB03AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from IB03AD = ',I4)
99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7)
99996 FORMAT (/' Number of iterations                     = ', I7,
     $        /' Number of conjugate gradients iterations = ', I7,
     $        /' Number of function evaluations           = ', I7,
     $        /' Number of Jacobian evaluations           = ', I7)
99995 FORMAT (10(1X,F8.4))
99994 FORMAT (/' Final approximate solution is ' )
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' L is out of range.',/' L = ',I5)
99991 FORMAT (/' NOBR is out of range.',/' NOBR = ',I5)
99990 FORMAT (/' NSMP is out of range.',/' NSMP = ',I5)
99989 FORMAT (/' N is out of range.',/' N = ',I5)
99988 FORMAT (/' NN is out of range.',/' NN = ',I5)
99987 FORMAT (' IWARN on exit from IB03AD = ',I4)
      END
Program Data 
 IB03AD EXAMPLE PROGRAM DATA
 10     1     1  1024    4   12   500  1000     0  .00001  .00001   B   D   F
   2.2183165e-01
   3.9027807e-02
  -5.0295887e-02
   8.5386224e-03
   7.2431159e-02
  -1.7082198e-03
  -1.7176287e-01
  -2.6198104e-01
  -1.7194108e-01
   1.8566868e-02
   1.5625362e-01
   1.7463811e-01
   1.1564450e-01
   2.8779248e-02
  -8.4265993e-02
  -2.0978501e-01
  -2.6591828e-01
  -1.7268680e-01
   2.1525013e-02
   1.4363602e-01
   7.3101431e-02
  -1.0259212e-01
  -1.6380473e-01
  -1.0021167e-02
   2.0263451e-01
   2.1983417e-01
  -2.1636523e-02
  -3.0986057e-01
  -3.8521982e-01
  -2.1785179e-01
  -1.4761096e-02
   3.7005180e-02
  -2.8119028e-02
  -4.2167901e-02
   5.2117694e-02
   1.2023747e-01
   1.8863385e-02
  -1.9506434e-01
  -3.0192175e-01
  -1.7000747e-01
   8.0740471e-02
   2.0188076e-01
   8.5108288e-02
  -1.3270970e-01
  -2.3646822e-01
  -1.6505385e-01
  -4.7448014e-02
  -2.7886815e-02
  -1.0152026e-01
  -1.4155374e-01
  -6.1650823e-02
   8.3519614e-02
   1.5926650e-01
   8.6142760e-02
  -9.4385381e-02
  -2.6609066e-01
  -3.2883874e-01
  -2.5908050e-01
  -1.1648940e-01
  -3.0653766e-03
   1.0326675e-02
  -5.3445909e-02
  -9.2412724e-02
  -3.0279541e-02
   8.4846832e-02
   1.1133075e-01
  -3.2135250e-02
  -2.5308181e-01
  -3.5670882e-01
  -2.4458860e-01
  -2.5254261e-02
   9.3714332e-02
   1.8643667e-02
  -1.4592119e-01
  -2.2730880e-01
  -1.7140060e-01
  -7.4131665e-02
  -3.9669515e-02
  -5.1266129e-02
  -1.1752833e-02
   1.0785565e-01
   2.0665525e-01
   1.6117322e-01
  -2.6938653e-02
  -2.1941152e-01
  -2.7753567e-01
  -1.8805912e-01
  -4.6845025e-02
   5.8585698e-02
   1.2218407e-01
   1.7838638e-01
   2.2169815e-01
   1.9825589e-01
   8.0215288e-02
  -7.2135308e-02
  -1.4381520e-01
  -6.8724371e-02
   1.0191205e-01
   2.3766633e-01
   2.3876101e-01
   1.1678077e-01
  -2.0428168e-02
  -5.8973233e-02
   3.1326900e-02
   1.7391495e-01
   2.4558570e-01
   1.7650262e-01
   1.2444292e-02
  -1.1538234e-01
  -9.5917970e-02
   6.4762165e-02
   2.4258524e-01
   3.0102251e-01
   2.1222960e-01
   7.8706189e-02
   3.1500466e-02
   1.0297577e-01
   1.9875173e-01
   1.9434906e-01
   5.8146667e-02
  -1.1941921e-01
  -2.1038478e-01
  -1.5594967e-01
   1.8552198e-03
   1.6878529e-01
   2.5937416e-01
   2.2516346e-01
   6.6144472e-02
  -1.5623019e-01
  -3.3161105e-01
  -3.6695732e-01
  -2.6565333e-01
  -1.3254832e-01
  -8.0101064e-02
  -1.2531889e-01
  -1.8843171e-01
  -1.9038956e-01
  -1.3230055e-01
  -7.0889306e-02
  -3.9679280e-02
  -2.6286077e-02
  -2.3630770e-02
  -6.0652834e-02
  -1.4929250e-01
  -2.2155095e-01
  -1.7331044e-01
   5.2693564e-03
   1.7683919e-01
   1.8244690e-01
   2.5118458e-02
  -1.1051051e-01
  -5.1764984e-02
   1.6342054e-01
   3.1563281e-01
   2.3808751e-01
  -4.4871135e-03
  -1.8778679e-01
  -1.6017584e-01
   2.3481991e-02
   1.9209185e-01
   2.4281065e-01
   2.1224192e-01
   1.8825017e-01
   1.9811718e-01
   2.0202486e-01
   1.6812825e-01
   1.1444796e-01
   7.2452475e-02
   4.0090973e-02
  -6.7139529e-03
  -6.8721730e-02
  -1.1460099e-01
  -1.1914168e-01
  -8.9852521e-02
  -4.5942222e-02
   1.0932686e-02
   8.1900393e-02
   1.3092374e-01
   9.0790221e-02
  -6.3538148e-02
  -2.5119963e-01
  -3.2585173e-01
  -2.0850925e-01
   1.7922009e-02
   1.6783753e-01
   1.2518317e-01
  -4.3517162e-02
  -1.5783138e-01
  -1.0686847e-01
   4.4782565e-02
   1.3893172e-01
   9.8691579e-02
   2.6311282e-03
  -1.6073049e-02
   7.8512306e-02
   1.9453537e-01
   2.2504627e-01
   1.6121235e-01
   7.8124056e-02
   2.9774586e-02
  -5.3899280e-03
  -6.5745322e-02
  -1.2329059e-01
  -9.5096521e-02
   5.5471394e-02
   2.5017082e-01
   3.4773286e-01
   2.6656242e-01
   5.3705965e-02
  -1.6135006e-01
  -2.7310977e-01
  -2.6814818e-01
  -2.1074926e-01
  -1.7743213e-01
  -1.9796482e-01
  -2.4059041e-01
  -2.4663820e-01
  -1.8780129e-01
  -9.8317382e-02
  -4.7848155e-02
  -7.3425069e-02
  -1.3529842e-01
  -1.4739094e-01
  -6.2482366e-02
   6.8729554e-02
   1.3251322e-01
   6.1482940e-02
  -8.5065014e-02
  -1.6074078e-01
  -6.7974104e-02
   1.3976672e-01
   2.9838081e-01
   2.8233998e-01
   1.1391411e-01
  -7.1966946e-02
  -1.5876983e-01
  -1.3805556e-01
  -8.2998592e-02
  -5.7864811e-02
  -6.5300733e-02
  -7.0590592e-02
  -5.5847027e-02
  -4.1219301e-02
  -6.1578267e-02
  -1.3176243e-01
  -2.2968907e-01
  -3.0193311e-01
  -2.8770451e-01
  -1.5729276e-01
   5.4414593e-02
   2.5362617e-01
   3.4482230e-01
   3.0119122e-01
   1.8534835e-01
   9.6712488e-02
   9.3385279e-02
   1.6057572e-01
   2.4424680e-01
   3.0164891e-01
   3.1693510e-01
   2.8441517e-01
   1.9948758e-01
   7.3600888e-02
  -5.4291337e-02
  -1.3721320e-01
  -1.5626045e-01
  -1.3464149e-01
  -1.1510541e-01
  -1.2587072e-01
  -1.6605420e-01
  -2.1242088e-01
  -2.3059410e-01
  -1.8785957e-01
  -7.8188380e-02
   5.0484398e-02
   1.0697957e-01
   2.7421051e-02
  -1.4419852e-01
  -2.5888039e-01
  -1.8018121e-01
   7.8519535e-02
   3.4009981e-01
   4.0793257e-01
   2.3842529e-01
  -2.7029751e-02
  -1.9919385e-01
  -2.0420528e-01
  -1.1389043e-01
  -3.5602606e-02
   5.7385906e-04
   3.8759790e-02
   1.0691941e-01
   1.6303496e-01
   1.4314046e-01
   4.7786789e-02
  -4.1030659e-02
  -3.5960232e-02
   7.0498851e-02
   2.0120383e-01
   2.6638170e-01
   2.3249669e-01
   1.2937468e-01
   1.3309043e-02
  -6.2770099e-02
  -5.8936178e-02
   3.4143049e-02
   1.6425689e-01
   2.2228910e-01
   1.2062705e-01
  -1.0832755e-01
  -3.0711352e-01
  -3.2002334e-01
  -1.4072879e-01
   7.6263091e-02
   1.6385270e-01
   1.0093887e-01
   1.7269577e-02
   4.3458474e-02
   1.6769625e-01
   2.4967945e-01
   1.7314220e-01
  -2.7519776e-02
  -1.9806822e-01
  -2.1140982e-01
  -7.2758850e-02
   1.1057470e-01
   2.3440218e-01
   2.5956640e-01
   1.9629970e-01
   7.2200120e-02
  -6.6390448e-02
  -1.4805958e-01
  -1.1487691e-01
   1.3561014e-02
   1.3146288e-01
   1.3205007e-01
   1.5159726e-02
  -9.9141126e-02
  -7.9831031e-02
   8.4487631e-02
   2.6348526e-01
   2.9617209e-01
   1.3322758e-01
  -1.1642178e-01
  -2.7289866e-01
  -2.2996687e-01
  -3.5143323e-02
   1.5983180e-01
   2.3035457e-01
   1.7179773e-01
   7.3333592e-02
   1.1653452e-02
  -1.8499701e-02
  -6.7962911e-02
  -1.4361094e-01
  -1.7665147e-01
  -9.1259528e-02
   9.8323111e-02
   2.6912800e-01
   2.8047779e-01
   9.9377687e-02
  -1.5436535e-01
  -2.9569363e-01
  -2.3017874e-01
  -4.1007324e-02
   8.2484352e-02
   2.1760384e-02
  -1.5212456e-01
  -2.4257965e-01
  -1.2641528e-01
   1.0676585e-01
   2.2865135e-01
   1.0211687e-01
  -1.6408728e-01
  -3.0761461e-01
  -1.7309336e-01
   1.2302931e-01
   3.0157576e-01
   1.9992664e-01
  -6.5766948e-02
  -2.2490680e-01
  -1.3209725e-01
   9.1452627e-02
   1.9707770e-01
   7.0972862e-02
  -1.6016460e-01
  -2.7859962e-01
  -2.0288880e-01
  -4.9817844e-02
   1.3587087e-02
  -5.2447125e-02
  -1.4164147e-01
  -1.3776729e-01
  -3.9470574e-02
   5.4688171e-02
   5.9780155e-02
  -2.0666265e-02
  -1.2306679e-01
  -1.9150051e-01
  -1.9953793e-01
  -1.3072099e-01
   1.7129752e-02
   1.9139299e-01
   2.8015628e-01
   1.9737258e-01
  -1.0273734e-02
  -1.6921879e-01
  -1.2914132e-01
   8.3866166e-02
   2.8290870e-01
   3.0288568e-01
   1.5939055e-01
   1.4121758e-02
  -8.0309556e-03
   5.7046152e-02
   7.8808779e-02
  -4.0300321e-04
  -9.3021531e-02
  -6.6955916e-02
   1.0073094e-01
   2.8905786e-01
   3.4946321e-01
   2.4220689e-01
   5.3331283e-02
  -1.0609621e-01
  -1.9358889e-01
  -2.2728166e-01
  -2.1680862e-01
  -1.4144032e-01
  -5.2173696e-03
   1.1701944e-01
   1.2668247e-01
   4.8375112e-03
  -1.4889224e-01
  -1.9905951e-01
  -9.9563224e-02
   6.4580042e-02
   1.5505008e-01
   9.7617503e-02
  -6.4905019e-02
  -2.1769152e-01
  -2.6787937e-01
  -2.0919394e-01
  -1.1033568e-01
  -4.3266567e-02
  -1.8066266e-02
   1.3641281e-02
   9.0806946e-02
   1.8645977e-01
   2.3150216e-01
   1.9334856e-01
   1.1238648e-01
   4.9498545e-02
   1.3155560e-02
  -3.5876844e-02
  -1.0537074e-01
  -1.2612890e-01
  -1.8934023e-02
   1.8850628e-01
   3.4290627e-01
   3.0108912e-01
   9.0554124e-02
  -9.4812468e-02
  -8.8842381e-02
   6.3160674e-02
   1.4646977e-01
   1.7441277e-02
  -2.2104173e-01
  -3.1862778e-01
  -1.5530235e-01
   1.1291463e-01
   2.1663682e-01
   7.1521680e-02
  -1.2722266e-01
  -1.3147084e-01
   6.8036453e-02
   2.2914846e-01
   1.4875917e-01
  -8.5725554e-02
  -1.9280127e-01
  -3.7053987e-02
   1.9484616e-01
   2.0627194e-01
  -5.0290692e-02
  -2.9703694e-01
  -2.4262627e-01
   7.3980280e-02
   3.1209111e-01
   2.0500085e-01
  -1.4678863e-01
  -3.9620361e-01
  -3.3299784e-01
  -8.5315346e-02
   7.0026906e-02
   3.1783466e-02
  -5.6224174e-02
  -3.8238612e-02
   4.1162402e-02
   1.4020902e-02
  -1.6267337e-01
  -3.2229719e-01
  -2.8405914e-01
  -8.0208074e-02
   7.7279407e-02
   5.2461001e-02
  -5.6931255e-02
  -5.7081867e-02
   8.4722273e-02
   1.8989091e-01
   9.1251490e-02
  -1.4913841e-01
  -3.0047660e-01
  -2.2924644e-01
  -4.5027749e-02
   4.5847665e-02
  -1.0582268e-02
  -7.0165157e-02
   8.8253349e-03
   1.7968871e-01
   2.6336655e-01
   1.6274839e-01
  -3.4038513e-02
  -1.6866975e-01
  -1.7822821e-01
  -1.1212378e-01
  -2.2511191e-02
   9.2633595e-02
   2.2273027e-01
   2.8312792e-01
   1.8855450e-01
  -1.3339719e-02
  -1.4451328e-01
  -7.9411873e-02
   9.5243626e-02
   1.5825934e-01
   8.6924573e-03
  -1.9762612e-01
  -2.0963986e-01
   3.0881541e-02
   3.1088543e-01
   3.7605990e-01
   2.0371110e-01
   3.1659734e-03
  -4.2255731e-02
   2.7937777e-02
   4.3768827e-02
  -5.0975761e-02
  -1.2013869e-01
  -1.9514056e-02
   1.9409077e-01
   3.0061057e-01
   1.6772761e-01
  -8.4377993e-02
  -2.0596833e-01
  -8.8137439e-02
   1.3053768e-01
   2.3231724e-01
   1.5592782e-01
   3.3546556e-02
   1.2609146e-02
   8.8143918e-02
   1.3076425e-01
   5.2445727e-02
  -9.1540218e-02
  -1.6532665e-01
  -8.9700956e-02
   9.2256458e-02
   2.6287064e-01
   3.2206114e-01
   2.4782579e-01
   1.0180547e-01
  -1.2653507e-02
  -2.4053903e-02
   4.5165362e-02
   9.2697417e-02
   3.9645255e-02
  -7.0244568e-02
  -9.7812594e-02
   4.0489353e-02
   2.5706426e-01
   3.5970764e-01
   2.4838839e-01
   2.8758245e-02
  -9.2051146e-02
  -1.8531616e-02
   1.4540527e-01
   2.2483594e-01
   1.6366159e-01
   6.0613849e-02
   2.6700790e-02
   4.8805007e-02
   2.4088984e-02
  -8.7776563e-02
  -1.9182802e-01
  -1.5875230e-01
   2.1332672e-02
   2.1574747e-01
   2.8121193e-01
   1.9605244e-01
   5.2140821e-02
  -6.0594054e-02
  -1.3111027e-01
  -1.9003660e-01
  -2.3031943e-01
  -1.9896872e-01
  -7.1576527e-02
   8.7126470e-02
   1.5966083e-01
   8.0700885e-02
  -9.6050487e-02
  -2.3768453e-01
  -2.4174619e-01
  -1.1781079e-01
   2.4058534e-02
   6.3114157e-02
  -3.4924911e-02
  -1.8708629e-01
  -2.5777811e-01
  -1.7457598e-01
   2.3256558e-03
   1.2615984e-01
   9.1298660e-02
  -7.2869748e-02
  -2.3064584e-01
  -2.6487668e-01
  -1.7896622e-01
  -8.1019614e-02
  -7.2160218e-02
  -1.5109102e-01
  -2.2270453e-01
  -1.9311631e-01
  -5.5949947e-02
   1.0558527e-01
   1.9015867e-01
   1.5010510e-01
   9.3491571e-03
  -1.6206410e-01
  -2.7872156e-01
  -2.6789883e-01
  -1.0908763e-01
   1.3219241e-01
   3.2581004e-01
   3.6597785e-01
   2.5860903e-01
   1.1593033e-01
   5.3232658e-02
   8.9253999e-02
   1.5038178e-01
   1.6325136e-01
   1.2516262e-01
   8.1000365e-02
   5.6249003e-02
   4.1260796e-02
   3.6021307e-02
   7.0909773e-02
   1.5431016e-01
   2.1909293e-01
   1.6946538e-01
   1.3913978e-03
  -1.5472276e-01
  -1.5445369e-01
  -6.5114694e-03
   1.1511921e-01
   5.3537688e-02
  -1.4926948e-01
  -2.8563000e-01
  -2.0489020e-01
   2.2256191e-02
   1.8089745e-01
   1.3686717e-01
  -4.3194077e-02
  -1.9185844e-01
  -2.2260927e-01
  -1.8688905e-01
  -1.7299493e-01
  -1.9552456e-01
  -2.0311384e-01
  -1.6521655e-01
  -1.1035364e-01
  -7.5596967e-02
  -5.2167223e-02
  -5.0648414e-03
   6.7754101e-02
   1.2412118e-01
   1.2838133e-01
   9.0308482e-02
   4.0708671e-02
  -1.2463102e-02
  -7.6325303e-02
  -1.2432208e-01
  -9.0380523e-02
   5.7426602e-02
   2.4318485e-01
   3.1839858e-01
   2.0029814e-01
  -2.6893656e-02
  -1.7351791e-01
  -1.2458940e-01
   4.6580380e-02
   1.5624992e-01
   9.9382689e-02
  -5.1882624e-02
  -1.4100610e-01
  -1.0040874e-01
  -1.2845131e-02
  -3.6737447e-03
  -9.7637188e-02
  -2.0172142e-01
  -2.1938378e-01
  -1.5223806e-01
  -7.5818447e-02
  -3.6932476e-02
  -8.3361793e-03
   4.9321106e-02
   1.0828653e-01
   8.6261922e-02
  -5.6487106e-02
  -2.4839500e-01
  -3.5078033e-01
  -2.7598256e-01
  -6.2963150e-02
   1.5901166e-01
   2.7685307e-01
   2.7164897e-01
   2.1079033e-01
   1.7714997e-01
   2.0086813e-01
   2.4438441e-01
   2.4570310e-01
   1.8078261e-01
   9.0365447e-02
   4.4844498e-02
   7.6311118e-02
   1.4103984e-01
   1.5313326e-01
   6.6678933e-02
  -6.7720328e-02
  -1.3565971e-01
  -6.6316159e-02
   8.3832277e-02
   1.6588475e-01
   7.6147385e-02
  -1.3444251e-01
  -2.9759248e-01
  -2.8274479e-01
  -1.1318459e-01
   7.1421886e-02
   1.5414324e-01
   1.3182338e-01
   8.0829372e-02
   6.0814130e-02
   6.6565578e-02
   6.1490382e-02
   3.4525574e-02
   1.4709018e-02
   3.9340413e-02
   1.1733787e-01
   2.1846966e-01
   2.8684125e-01
   2.6688313e-01
   1.3632576e-01
  -6.7370697e-02
  -2.5502586e-01
  -3.3949317e-01
  -3.0013913e-01
  -1.9871892e-01
  -1.2610649e-01
  -1.2941580e-01
  -1.8923457e-01
  -2.5813995e-01
  -3.0533743e-01
  -3.1970649e-01
  -2.8788006e-01
  -1.9500297e-01
  -5.4155345e-02
   8.1116905e-02
   1.5269009e-01
   1.4976106e-01
   1.1681611e-01
   1.0728712e-01
   1.3670700e-01
   1.8344060e-01
   2.2041268e-01
   2.2972773e-01
   1.9334746e-01
   9.8734288e-02
  -2.6231283e-02
  -9.9070456e-02
  -4.1644202e-02
   1.2360480e-01
   2.5212308e-01
   1.9060093e-01
  -6.5066267e-02
  -3.3581971e-01
  -4.0871250e-01
  -2.3222990e-01
   4.0796545e-02
   2.0553146e-01
   1.9047036e-01
   8.7982654e-02
   2.1078714e-02
   1.1947834e-02
  -7.4158796e-03
  -8.0649898e-02
  -1.5932177e-01
  -1.5963498e-01
  -6.7654645e-02
   3.3754864e-02
   4.5488264e-02
  -5.1656648e-02
  -1.8439778e-01
  -2.5821552e-01
  -2.3168258e-01
  -1.3075945e-01
  -1.4319768e-02
   6.0276859e-02
   5.2808278e-02
  -4.2009846e-02
  -1.6857834e-01
  -2.1862301e-01
  -1.0815610e-01
   1.2758494e-01
   3.3007803e-01
   3.4236071e-01
   1.5606744e-01
  -7.3906241e-02
  -1.7487103e-01
  -1.1779263e-01
  -2.8797157e-02
  -4.2649366e-02
  -1.5603253e-01
  -2.3465677e-01
  -1.6213440e-01
   3.1155521e-02
   1.9455902e-01
   2.0308035e-01
   6.4105637e-02
  -1.1373221e-01
  -2.2912186e-01
  -2.4930244e-01
  -1.8794162e-01
  -6.9023299e-02
   6.6894859e-02
   1.4860950e-01
   1.1319286e-01
  -2.1622177e-02
  -1.4430675e-01
  -1.4139382e-01
  -1.4679189e-02
   1.0606471e-01
   8.3987908e-02
  -8.6549724e-02
  -2.6473902e-01
  -2.8787546e-01
  -1.1665499e-01
   1.3032718e-01
   2.7649250e-01
   2.2886289e-01
   4.1972959e-02
  -1.4166947e-01
  -2.1351821e-01
  -1.7294568e-01
  -9.5242426e-02
  -3.9988034e-02
   6.0215518e-04
   6.4278100e-02
   1.4411085e-01
   1.7008073e-01
   7.6346726e-02
  -1.1397897e-01
  -2.7942868e-01
  -2.8837790e-01
  -1.1356283e-01
   1.2995490e-01
   2.6791352e-01
   2.1050936e-01
   3.2758432e-02
  -8.8492035e-02
  -3.6187051e-02
   1.3102808e-01
   2.2789768e-01
   1.2664599e-01
  -9.9240525e-02
  -2.3008477e-01
  -1.1958430e-01
   1.3943384e-01
   2.8863442e-01
   1.6130336e-01
  -1.3747854e-01
  -3.2522857e-01
  -2.2524885e-01
   5.3864511e-02
   2.3305883e-01
   1.5177574e-01
  -7.4373920e-02
  -1.8870441e-01
  -6.7093573e-02
   1.6495747e-01
   2.8369836e-01
   2.0511206e-01
   5.1011236e-02
  -6.5929875e-03
   6.8964562e-02
   1.6340844e-01
   1.5740112e-01
   5.4023734e-02
  -4.3471011e-02
  -5.1346211e-02
   2.3145779e-02
   1.1745308e-01
   1.8212689e-01
   1.9584070e-01
   1.4022670e-01
   5.9022790e-03
  -1.6079919e-01
  -2.4935419e-01
  -1.7100378e-01
   3.1256057e-02
   1.8605482e-01
   1.4297623e-01
  -7.3243962e-02
  -2.7593402e-01
  -2.9797544e-01
  -1.5307840e-01
  -4.0914832e-03
   2.1269662e-02
  -4.1497170e-02
  -5.9046655e-02
   2.7976789e-02
   1.2846949e-01
   1.0303296e-01
  -7.5938937e-02
  -2.8392411e-01
  -3.6123552e-01
  -2.5664252e-01
  -5.3262494e-02
   1.2879625e-01
   2.3255706e-01
   2.6842403e-01
   2.5122050e-01
   1.7087253e-01
   3.4014290e-02
  -9.3227815e-02
  -1.2001867e-01
  -2.1139059e-02
   1.2023890e-01
   1.7758447e-01
   9.6606085e-02
  -5.2792108e-02
  -1.3892628e-01
  -8.4350032e-02
   7.1620365e-02
   2.1524576e-01
   2.5910116e-01
   2.0627091e-01
   1.2532985e-01
   7.1727643e-02
   3.8319163e-02
  -1.9240088e-02
  -1.1662856e-01
  -2.1107703e-01
  -2.4258539e-01
  -1.9809090e-01
  -1.2271124e-01
  -6.5266079e-02
  -2.6001544e-02
   2.6587042e-02
   8.9979857e-02
   1.0112134e-01
  -1.6495775e-03
  -1.8712095e-01
  -3.2285436e-01
  -2.8769737e-01
  -1.0373843e-01
   6.3283390e-02
   6.4192144e-02
  -6.9141383e-02
  -1.4546154e-01
  -2.2743165e-02
   2.1671482e-01
   3.3495240e-01
   1.9730942e-01
  -6.4245098e-02
  -1.8430371e-01
  -5.9313975e-02
   1.3285821e-01
   1.3988590e-01
  -6.3313853e-02
  -2.3781208e-01
  -1.6565753e-01
   7.8634007e-02
   2.0643470e-01
   6.3051903e-02
  -1.7337120e-01
  -1.9553447e-01
   5.8877424e-02
   3.1320739e-01
   2.6455767e-01
  -5.6738794e-02
  -3.0614673e-01
  -2.0738949e-01
   1.4261991e-01
   3.9321755e-01
   3.3131011e-01
   8.6485026e-02
  -6.3943179e-02
  -2.3354764e-02
   5.9552949e-02
   3.1845636e-02
  -5.2189216e-02
  -1.8514555e-02
   1.7050716e-01
   3.3649462e-01
   2.9310084e-01
   7.8582244e-02
  -8.5200138e-02
  -5.9242022e-02
   5.3629257e-02
   5.3919799e-02
  -9.1290610e-02
  -1.9983794e-01
  -1.0236954e-01
   1.3831631e-01
   2.9035137e-01
  -1.7703630e-01
  -1.1470789e-01
  -1.7257803e-02
   7.3360924e-02
   1.2806267e-01
   1.3650217e-01
   1.0539571e-01
   5.4901306e-02
   1.0347593e-02
  -1.4210364e-02
  -2.9316079e-02
  -5.9818410e-02
  -1.1287079e-01
  -1.5651256e-01
  -1.3759239e-01
  -3.1325918e-02
   1.2118952e-01
   2.2925439e-01
   2.1688928e-01
   8.3280850e-02
  -9.0968958e-02
  -1.9863421e-01
  -1.7919413e-01
  -5.4874063e-02
   9.1323774e-02
   1.7241745e-01
   1.4973591e-01
   5.1202694e-02
  -5.0722214e-02
  -8.6474562e-02
  -3.6675604e-02
   5.0794719e-02
   9.2852996e-02
   3.5475423e-02
  -9.8019853e-02
  -2.1560266e-01
  -2.2054921e-01
  -8.4207430e-02
   1.2773783e-01
   2.9411889e-01
   3.1432928e-01
   1.7183620e-01
  -5.3673166e-02
  -2.3087548e-01
  -2.5206313e-01
  -9.9556443e-02
   1.3579254e-01
   3.0302360e-01
   2.8345210e-01
   6.9698019e-02
  -2.2311064e-01
  -4.2606792e-01
  -4.1979542e-01
  -2.0235411e-01
   1.1680679e-01
   3.8269042e-01
   4.7499251e-01
   3.6130151e-01
   1.0698485e-01
  -1.5666457e-01
  -2.9684785e-01
  -2.5130444e-01
  -6.7456399e-02
   1.2329504e-01
   1.8968350e-01
   8.9456729e-02
  -1.0185072e-01
  -2.4339863e-01
  -2.2562726e-01
  -4.5215735e-02
   1.9190737e-01
   3.3930982e-01
   3.0360010e-01
   1.0486525e-01
  -1.3364785e-01
  -2.6276635e-01
  -2.0355127e-01
  -1.0514338e-03
   2.0109829e-01
   2.5410141e-01
   1.0538640e-01
  -1.6182684e-01
  -3.7724711e-01
  -3.8906986e-01
  -1.6075631e-01
   2.0065197e-01
   5.0030087e-01
   5.6260189e-01
   3.3306758e-01
  -8.1981699e-02
  -4.6637054e-01
  -6.1157444e-01
  -4.3578631e-01
  -3.4787751e-02
   3.6943357e-01
   5.5331393e-01
   4.1651911e-01
   3.8203811e-02
  -3.6624642e-01
  -5.6531588e-01
  -4.4111547e-01
  -5.7977077e-02
   3.6800859e-01
   5.8749279e-01
   4.6334166e-01
   5.9154789e-02
  -3.8817476e-01
  -6.0585734e-01
  -4.5438072e-01
  -2.1770889e-02
   4.2269933e-01
   5.9388393e-01
   3.7277877e-01
  -1.1367643e-01
  -5.6785416e-01
  -7.0538273e-01
  -4.3261293e-01
   9.5667577e-02
   5.7311674e-01
   7.2849359e-01
   4.8697304e-01
   9.0040534e-03
  -4.1643634e-01
  -5.5375692e-01
  -3.6053568e-01
   1.0675442e-03
   2.8391467e-01
   3.2050851e-01
   1.2014875e-01
  -1.5499683e-01
  -3.0636590e-01
  -2.2845450e-01
   3.0168597e-02
   3.0447079e-01
   4.1814633e-01
   2.9408146e-01
   3.3795396e-03
  -2.8043536e-01
  -3.9163122e-01
  -2.7524621e-01
  -1.6330862e-02
   2.2338646e-01
   3.1163298e-01
   2.1884631e-01
   2.0034460e-02
  -1.6244160e-01
  -2.3122765e-01
  -1.5928083e-01
   4.5460308e-03
   1.6378113e-01
   2.2566835e-01
   1.5187573e-01
  -1.8633628e-02
  -1.8835877e-01
  -2.5597784e-01
  -1.7568160e-01
   1.6144538e-02
   2.1796548e-01
   3.1334397e-01
   2.3350541e-01
   9.9054075e-04
  -2.7139443e-01
  -4.3349329e-01
  -3.8409180e-01
  -1.3941008e-01
   1.6850242e-01
   3.6865127e-01
   3.5669633e-01
   1.5962938e-01
  -8.6421861e-02
  -2.2603591e-01
  -1.7879992e-01
   1.5608870e-02
   2.2316774e-01
   2.9540664e-01
   1.5777130e-01
  -1.3932674e-01
  -4.3707134e-01
  -5.5308393e-01
  -3.9056636e-01
  -6.9866596e-03
   4.0342788e-01
   6.1470960e-01
   5.0478901e-01
   1.3556472e-01
  -2.7661265e-01
  -4.8754120e-01
  -3.7410263e-01
  -1.0933935e-02
   3.7332700e-01
   5.3265415e-01
   3.5296792e-01
  -7.5112937e-02
  -5.0630963e-01
  -6.8543131e-01
  -5.0254861e-01
  -6.3204556e-02
   3.7616490e-01
   5.6861420e-01
   4.2839911e-01
   7.7256895e-02
  -2.4286013e-01
  -3.2974149e-01
  -1.4621212e-01
   1.6396591e-01
   3.7227253e-01
   3.1398669e-01
  -1.5203951e-03
  -3.8826155e-01
  -5.9422715e-01
  -4.6290884e-01
  -4.4082503e-02
   4.2614489e-01
   6.6944646e-01
   5.4057059e-01
   1.1914310e-01
  -3.4186097e-01
  -5.7361170e-01
  -4.5144665e-01
  -6.3037624e-02
   3.5015696e-01
   5.3940241e-01
   3.9354970e-01
   6.6063109e-05
  -4.0735798e-01
  -5.8396114e-01
  -4.1610263e-01
   1.0313382e-02
   4.5449701e-01
   6.5638620e-01
   4.8903578e-01
   3.8482894e-02
  -4.3952337e-01
  -6.6436421e-01
  -4.9492372e-01
  -1.7915270e-02
   4.9445240e-01
   7.3828446e-01
   5.5772875e-01
   4.3827397e-02
  -5.1216643e-01
  -7.8827423e-01
  -6.2373284e-01
  -1.1577453e-01
   4.4053448e-01
   7.3121649e-01
   6.0691719e-01
   1.6037942e-01
  -3.4101558e-01
  -6.1837622e-01
  -5.3898039e-01
  -1.7955555e-01
   2.3296574e-01
   4.6098842e-01
   3.9204767e-01
   9.4586522e-02
  -2.3425494e-01
  -3.9383077e-01
  -2.9901136e-01
  -2.1727093e-02
   2.6290754e-01
   3.8667642e-01
   2.8641038e-01
   3.4299620e-02
  -2.1199530e-01
  -3.0703990e-01
  -2.0539827e-01
   1.3733625e-02
   1.9989717e-01
   2.2856610e-01
   8.0442398e-02
  -1.4924794e-01
  -3.1635143e-01
  -3.2043874e-01
  -1.6226330e-01
   6.7449386e-02
   2.5253008e-01
   3.1855044e-01
   2.6051993e-01
   1.2699840e-01
  -1.6342455e-02
  -1.1750854e-01
  -1.5094063e-01
  -1.1699324e-01
  -3.6407066e-02
   5.7070826e-02
   1.2470744e-01
   1.3295525e-01
   6.7237676e-02
  -5.6199791e-02
  -1.8928499e-01
  -2.6860491e-01
  -2.4751370e-01
  -1.2546869e-01
   4.7269068e-02
   1.9379936e-01
   2.5012057e-01
   1.9757699e-01
   6.9603172e-02
  -6.6884197e-02
  -1.4260360e-01
  -1.1800895e-01
  -4.5690911e-03
   1.3505757e-01
   2.1176910e-01
   1.5667518e-01
  -2.9715225e-02
  -2.6058872e-01
  -4.0072162e-01
  -3.4636170e-01
  -1.0002597e-01
   2.1522385e-01
   4.2116592e-01
   3.9178740e-01
   1.3552073e-01
  -2.0194672e-01
  -4.2193015e-01
  -3.9351670e-01
  -1.3365470e-01
   2.0423921e-01
   4.2544835e-01
   4.1162219e-01
   1.8730580e-01
  -1.0283670e-01
  -2.8986993e-01
  -2.8756628e-01
  -1.3866788e-01
   2.8290398e-02
   9.5513335e-02
   3.5118646e-02
  -8.2724881e-02
  -1.5147446e-01
  -1.0799938e-01
   2.6949604e-02
   1.6959254e-01
   2.3358015e-01
   1.8482066e-01
   5.6424609e-02
  -7.8806247e-02
  -1.5583364e-01
  -1.5299245e-01
  -9.3729273e-02
  -1.9708548e-02
   3.8600307e-02
   7.1469845e-02
   7.8472613e-02
   5.5625386e-02
  -1.0621857e-03
  -8.0782039e-02
  -1.5057837e-01
  -1.6705428e-01
  -1.0304932e-01
   2.9389143e-02
   1.7801990e-01
   2.7318425e-01
   2.6234323e-01
   1.3834554e-01
  -5.4215912e-02
  -2.3593270e-01
  -3.2392000e-01
  -2.6898405e-01
  -8.5844039e-02
   1.4215609e-01
   2.9652172e-01
   2.8801270e-01
   1.1683545e-01
  -1.1688760e-01
  -2.6947626e-01
  -2.4573958e-01
  -6.4329645e-02
   1.5353975e-01
   2.6653313e-01
   2.0755588e-01
   2.4602079e-02
  -1.5772495e-01
  -2.2567844e-01
  -1.4875573e-01
   9.9414396e-03
   1.4397851e-01
   1.7486115e-01
   9.6314112e-02
  -3.2169687e-02
  -1.2887854e-01
  -1.3861783e-01
  -5.9693947e-02
   6.1826068e-02
   1.6117670e-01
   1.8758542e-01
   1.2643056e-01
   4.7038639e-03
  -1.2089033e-01
  -1.8936563e-01
  -1.6676448e-01
  -6.8240952e-02
   4.6702545e-02
   1.0911959e-01
   8.7135042e-02
   1.1538006e-02
  -4.4789930e-02
  -2.4262269e-02
   6.5437901e-02
   1.5116338e-01
   1.4886934e-01
   3.3820535e-02
  -1.3097789e-01
  -2.3522600e-01
  -2.0099760e-01
  -4.2018915e-02
   1.4060900e-01
   2.2430878e-01
   1.4698003e-01
  -4.9334401e-02
  -2.4015379e-01
  -2.9449301e-01
  -1.5978257e-01
   9.9469238e-02
   3.3553927e-01
   4.0432846e-01
   2.5275189e-01
  -4.8157255e-02
  -3.4363559e-01
  -4.8101858e-01
  -3.9093124e-01
  -1.2065446e-01
   1.9561509e-01
   4.0816957e-01
   4.2449571e-01
   2.4947873e-01
  -2.2290220e-02
  -2.5535821e-01
  -3.3965313e-01
  -2.4442241e-01
  -3.2717407e-02
   1.7386538e-01
   2.6131002e-01
   1.8344736e-01
  -1.4617105e-02
  -2.2004617e-01
  -3.0989410e-01
  -2.1648361e-01
   2.9614296e-02
   3.0600899e-01
   4.6010027e-01
   3.9585763e-01
   1.3407054e-01
  -1.9445050e-01
  -4.2254041e-01
  -4.4190341e-01
  -2.6148822e-01
   2.4561144e-03
   1.9639531e-01
   2.2058130e-01
   8.8618067e-02
  -8.2771773e-02
  -1.5145974e-01
  -4.8116921e-02
   1.7081593e-01
   3.5448643e-01
   3.5655964e-01
   1.3834184e-01
  -1.9528570e-01
  -4.5613811e-01
  -4.9089820e-01
  -2.7873232e-01
   5.5837539e-02
   3.2156811e-01
   3.7683870e-01
   2.1007687e-01
  -6.1195486e-02
  -2.6670692e-01
  -2.8529736e-01
  -1.1252984e-01
   1.4069959e-01
   3.1548805e-01
   3.0070613e-01
   1.0177110e-01
  -1.6096596e-01
  -3.2711612e-01
  -2.9842835e-01
  -9.9492033e-02
   1.4305421e-01
   2.8418081e-01
   2.4879424e-01
   7.0440776e-02
  -1.3708347e-01
  -2.5105923e-01
  -2.1001593e-01
  -4.5285982e-02
   1.4155737e-01
   2.4209754e-01
   2.0725941e-01
   7.3959838e-02
  -6.6466455e-02
  -1.3533231e-01
  -1.1722667e-01
  -5.6247689e-02
  -8.2151160e-03
   4.6646596e-03
  -5.3013327e-05
   6.4836935e-03
   3.4885521e-02
   7.2093769e-02
   9.6085499e-02
   9.0621414e-02
   5.0063443e-02
  -1.9216694e-02
  -9.5194586e-02
  -1.4177512e-01
  -1.2554939e-01
  -4.1561203e-02
   7.4612994e-02
   1.6458119e-01
   1.8370169e-01
   1.2694288e-01
   2.5574339e-02
  -7.6209464e-02
  -1.4292208e-01
  -1.5717793e-01
  -1.2150507e-01
  -5.7465582e-02
   3.0433319e-03
   3.8135050e-02
   5.3444515e-02
   7.4126764e-02
   1.1232692e-01
   1.4266966e-01
   1.1713381e-01
   1.2919877e-02
  -1.3094351e-01
  -2.2903887e-01
  -2.1083457e-01
  -7.7741149e-02
   9.2251468e-02
   1.9732652e-01
   1.8027267e-01
   6.1530912e-02
  -8.1015797e-02
  -1.6435623e-01
  -1.4922825e-01
  -5.8874212e-02
   3.9408110e-02
   7.8379546e-02
   3.6886774e-02
  -4.2241134e-02
  -8.1505612e-02
  -2.9557008e-02
   9.2798034e-02
   2.0055247e-01
   2.0414883e-01
   7.6944227e-02
  -1.2029199e-01
  -2.7519345e-01
  -2.9408814e-01
  -1.6081545e-01
   5.1070794e-02
   2.1840144e-01
   2.3874816e-01
   9.4335060e-02
  -1.2904879e-01
  -2.8774773e-01
  -2.6899028e-01
  -6.6408095e-02
   2.1071698e-01
   4.0356249e-01
   3.9994180e-01
   1.9633323e-01
  -1.0730235e-01
  -3.6601054e-01
  -4.6248715e-01
  -3.5922221e-01
  -1.1354600e-01
   1.4870456e-01
   2.9521055e-01
   2.5966678e-01
   8.3040302e-02
  -1.0914113e-01
  -1.8742442e-01
  -1.0478464e-01
   7.3317409e-02
   2.1546569e-01
   2.1382067e-01
   5.6531581e-02
  -1.6427012e-01
  -3.1183656e-01
  -2.9186150e-01
  -1.1383004e-01
   1.1231696e-01
   2.4506533e-01
   2.0292544e-01
   1.9811075e-02
  -1.7391062e-01
  -2.3677906e-01
  -1.1242105e-01
   1.2953875e-01
   3.3467916e-01
   3.5946938e-01
   1.6169418e-01
  -1.6880410e-01
  -4.5538345e-01
  -5.3000472e-01
  -3.2991559e-01
   5.7588162e-02
   4.3386984e-01
   5.9508457e-01
   4.4813661e-01
   6.8860243e-02
  -3.3635714e-01
  -5.4527976e-01
  -4.4370745e-01
  -8.9647493e-02
   3.1753702e-01
   5.4673805e-01
   4.6318145e-01
   1.0733728e-01
  -3.1949400e-01
  -5.6446899e-01
  -4.7269412e-01
  -8.8269356e-02
   3.6150197e-01
   5.9965309e-01
   4.7275161e-01
   5.2712510e-02
  -4.0097128e-01
  -6.0010920e-01
  -4.1032807e-01
   6.1089052e-02
   5.2877389e-01
   7.0388838e-01
   4.7272792e-01
  -3.2841140e-02
  -5.1806125e-01
  -7.0615746e-01
  -5.0443062e-01
  -5.3964611e-02
   3.6781621e-01
   5.2531916e-01
   3.6514315e-01
   3.1895267e-02
  -2.4276338e-01
  -2.9561167e-01
  -1.2568333e-01
   1.2380832e-01
   2.6979551e-01
   2.0920891e-01
  -2.0179145e-02
  -2.6980104e-01
  -3.7620139e-01
  -2.6519009e-01
  -1.4966321e-04
   2.5905182e-01
   3.5875119e-01
   2.4783584e-01
   5.4317821e-03
  -2.1770753e-01
  -2.9814845e-01
  -2.0810260e-01
  -1.7395596e-02
   1.5890290e-01
   2.2758901e-01
   1.6085463e-01
   3.3576307e-03
  -1.5297196e-01
  -2.1737064e-01
  -1.5023570e-01
   1.2479222e-02
   1.7606639e-01
   2.4089523e-01
   1.6216345e-01
  -2.3230254e-02
  -2.1504218e-01
  -3.0098784e-01
  -2.1779026e-01
   8.8067567e-03
   2.6812984e-01
   4.1695437e-01
   3.6159556e-01
   1.2203070e-01
  -1.7147580e-01
  -3.5437470e-01
  -3.3058973e-01
  -1.3341351e-01
   9.9954914e-02
   2.1969740e-01
   1.5589313e-01
  -4.1996520e-02
  -2.3771826e-01
  -2.9083527e-01
  -1.4002506e-01
   1.5548285e-01
   4.3862419e-01
   5.3769302e-01
   3.6811228e-01
  -6.9569482e-03
  -3.9769165e-01
  -5.8956799e-01
  -4.7193386e-01
  -1.1138894e-01
   2.8025332e-01
   4.6943948e-01
   3.4372376e-01
  -1.6555081e-02
  -3.8429530e-01
  -5.2185674e-01
  -3.2705351e-01
   1.0055685e-01
   5.1629500e-01
   6.7570174e-01
   4.8204840e-01
   4.6679399e-02
  -3.7892485e-01
  -5.5799051e-01
  -4.1189337e-01
  -6.3130989e-02
   2.4927425e-01
   3.2624429e-01
   1.3391859e-01
  -1.7899014e-01
  -3.7999275e-01
  -3.0718591e-01
   1.9919795e-02
   4.0587411e-01
   5.9872071e-01
   4.5200311e-01
   2.6827172e-02
  -4.3774484e-01
  -6.7014857e-01
  -5.3423365e-01
  -1.1312830e-01
   3.4367827e-01
   5.7281717e-01
   4.5156693e-01
   6.5481027e-02
  -3.4683106e-01
  -5.3783781e-01
  -3.9562633e-01
  -5.2304328e-03
   4.0256826e-01
   5.8408144e-01
   4.2300297e-01
  -1.8218267e-04
  -4.4833216e-01
  -6.5943295e-01
  -5.0033881e-01
  -5.1578103e-02
   4.3192551e-01
   6.6545648e-01
   5.0237264e-01
   2.6477477e-02
  -4.8897549e-01
  -7.3697545e-01
  -5.5960739e-01
  -4.7597748e-02
   5.0867228e-01
   7.8911527e-01
   6.3269313e-01
   1.3197226e-01
  -4.2464681e-01
  -7.2603682e-01
  -6.1784801e-01
  -1.8264666e-01
   3.2014735e-01
   6.1135123e-01
   5.4895999e-01
   1.9768580e-01
  -2.2062099e-01
  -4.6220719e-01
  -4.0211731e-01
  -9.9950534e-02
   2.4465654e-01
   4.1872319e-01
   3.2500596e-01
   3.2810917e-02
  -2.7440750e-01
  -4.1536442e-01
  -3.1832701e-01
  -5.5989066e-02
   2.0726049e-01
   3.1798239e-01
   2.2484797e-01
   5.1703651e-03
  -1.8889751e-01
  -2.2927380e-01
  -9.1914974e-02
   1.3314428e-01
   3.0513495e-01
   3.2224987e-01
   1.7778028e-01
  -4.7100451e-02
  -2.4007922e-01
  -3.2145867e-01
  -2.7615883e-01
  -1.4545755e-01
   4.2822900e-03
   1.1399372e-01
   1.5138712e-01
   1.1530153e-01
   3.0234280e-02
  -6.4234624e-02
  -1.2615802e-01
  -1.2407054e-01
  -4.9317670e-02
   7.5619816e-02
   2.0015044e-01
   2.6472178e-01
   2.3118708e-01
   1.0699863e-01
  -5.5412012e-02
  -1.8550876e-01
  -2.3096135e-01
  -1.8218227e-01
  -7.2615500e-02
   4.0881922e-02
   1.0372451e-01
   8.6362391e-02
  -1.1351454e-03
  -1.0889033e-01
  -1.6548976e-01
  -1.1405709e-01
   4.6560657e-02
   2.4386985e-01
   3.6111476e-01
   3.0662373e-01
   8.1468123e-02
  -2.0497551e-01
  -3.9165036e-01
  -3.6309524e-01
  -1.2535574e-01
   1.8954273e-01
   3.9793935e-01
   3.7486538e-01
   1.3124068e-01
  -1.9174474e-01
  -4.0848802e-01
  -4.0149539e-01
  -1.8960477e-01
   9.0301438e-02
   2.7507284e-01
   2.7972729e-01
   1.4341274e-01
  -1.2566755e-02
  -7.8032703e-02
  -2.7425697e-02
   7.5351759e-02
   1.3487633e-01
   9.5488652e-02
  -2.4590018e-02
  -1.5233210e-01
  -2.1189289e-01
  -1.7248897e-01
  -6.2455423e-02
   5.4933614e-02
   1.2398028e-01
   1.2778044e-01
   8.7386392e-02
   3.4966577e-02
  -1.0850501e-02
  -4.6716543e-02
  -6.9020828e-02
  -6.3681635e-02
  -1.6203206e-02
   6.7394491e-02
   1.5127737e-01
   1.8399090e-01
   1.2920707e-01
  -7.0434827e-03
  -1.7216342e-01
  -2.8937677e-01
  -2.9509198e-01
  -1.7314710e-01
   3.2745183e-02
   2.3542177e-01
   3.4097958e-01
   2.9247721e-01
   1.0411948e-01
  -1.3495077e-01
  -2.9868629e-01
  -2.9240849e-01
  -1.1517683e-01
   1.2871323e-01
   2.8803761e-01
   2.6146766e-01
   6.7234759e-02
  -1.6729947e-01
  -2.9180077e-01
  -2.3297675e-01
  -3.8493954e-02
   1.6188055e-01
   2.4607750e-01
   1.7580193e-01
   1.0770499e-02
  -1.3917580e-01
  -1.8630712e-01
  -1.1496682e-01
   1.8120146e-02
   1.2605380e-01
   1.4532251e-01
   6.9056099e-02
  -5.5814690e-02
  -1.6001831e-01
  -1.8912751e-01
  -1.2778372e-01
  -4.4698128e-03
   1.2208903e-01
   1.8963074e-01
   1.6384408e-01
   6.0799128e-02
  -5.7339158e-02
  -1.1860919e-01
  -9.0086196e-02
  -4.5798607e-03
   6.0280807e-02
   4.1676388e-02
  -5.5180320e-02
  -1.5518201e-01
  -1.6828578e-01
  -6.2049884e-02
   1.0561621e-01
   2.2337555e-01
   2.0643187e-01
   5.9839911e-02
  -1.2043322e-01
  -2.1083864e-01
  -1.4415945e-01
   4.3538937e-02
   2.3203364e-01
   2.9044234e-01
   1.6171416e-01
  -9.5674666e-02
  -3.3749265e-01
  -4.1795872e-01
  -2.7746809e-01
   2.0648626e-02
   3.2603206e-01
   4.8410918e-01
   4.1672303e-01
   1.5905611e-01
  -1.6318595e-01
  -3.9931562e-01
  -4.4568803e-01
  -2.9169291e-01
  -2.0960934e-02
   2.3175866e-01
   3.4693819e-01
   2.7877641e-01
   7.7125945e-02
  -1.4069530e-01
  -2.5367798e-01
  -2.0150506e-01
  -1.6778161e-02
   1.9116819e-01
   2.9409556e-01
   2.1593628e-01
  -1.9610708e-02
  -2.9401135e-01
  -4.5512990e-01
  -4.0311941e-01
  -1.5075705e-01
   1.7921653e-01
   4.2153577e-01
   4.6143206e-01
   2.9688389e-01
   3.5275834e-02
  -1.7206796e-01
  -2.2040717e-01
  -1.1280250e-01
   4.6014479e-02
   1.2005000e-01
   3.5297082e-02
  -1.6459920e-01
  -3.4121448e-01
  -3.5130088e-01
  -1.4787707e-01
   1.7615712e-01
   4.3972643e-01
   4.8949447e-01
   2.9899548e-01
  -1.6059656e-02
  -2.7414987e-01
  -3.4124596e-01
  -2.0476598e-01
   3.1287353e-02
   2.1535118e-01
   2.3693813e-01
   8.7039128e-02
  -1.3914592e-01
  -2.9731202e-01
  -2.8057123e-01
  -8.9244625e-02
   1.6445576e-01
   3.2621002e-01
   2.9949560e-01
   1.0678193e-01
  -1.3016725e-01
  -2.7225661e-01
  -2.4687907e-01
  -8.3173776e-02
   1.1381888e-01
   2.2819642e-01
   1.9830143e-01
   4.8505476e-02
  -1.2763594e-01
  -2.2560309e-01
  -1.9560311e-01
  -7.1212054e-02
   6.0380807e-02
   1.2445307e-01
   1.0835168e-01
   5.5609724e-02
   1.7269294e-02
   9.3997346e-03
   1.1223045e-02
  -4.3543819e-03
  -4.2668837e-02
  -8.5657964e-02
  -1.0909342e-01
  -9.7154374e-02
  -4.6781850e-02
   3.1101930e-02
   1.0973840e-01
   1.5122945e-01
   1.2531404e-01
   3.3620966e-02
  -8.3194568e-02
  -1.6716420e-01
 1998.   1999.   2000.   2001.
Program Results 
 IB03AD EXAMPLE PROGRAM RESULTS


 Final 2-norm of the residuals =   0.2970365D+00

 Number of iterations                     =      87
 Number of conjugate gradients iterations =       0
 Number of function evaluations           =    1322
 Number of Jacobian evaluations           =     105

 Final approximate solution is 
  -0.9728   0.6465  -1.2888  -0.4296  -0.8530   0.3181   0.9778   0.4570  -0.1420   0.8984
  -0.6031   0.0697  -1.0822   0.4465   0.6036   0.3792   0.2532  -0.0285   0.4129   0.4833
   0.1746   0.5626   0.2150  -0.3343   0.4013  -0.3679   0.5653   0.8092  -0.2363  -0.6361
  -0.6818   0.6110  -0.5506   0.9914   0.0352   0.1968  -0.2502   7.0067 -10.7378   2.6900
 -59.8756  -0.9898  -0.8296   2.3429   1.3456  -0.2531  -1.1265   0.0326   0.5617   0.1045

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/IB03BD.html000077500000000000000000002045071201767322700160570ustar00rootroot00000000000000 IB03BD - SLICOT Library Routine Documentation

IB03BD

Wiener system identification using a MINPACK-like Levenberg-Marquardt algorithm

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a set of parameters for approximating a Wiener system
  in a least-squares sense, using a neural network approach and a
  MINPACK-like Levenberg-Marquardt algorithm. The Wiener system
  consists of a linear part and a static nonlinearity, and it is
  represented as

     x(t+1) = A*x(t) + B*u(t)
     z(t)   = C*x(t) + D*u(t),

     y(t)   = f(z(t),wb(1:L)),

  where t = 1, 2, ..., NSMP, and f is a nonlinear function,
  evaluated by the SLICOT Library routine NF01AY. The parameter
  vector X is partitioned as X = ( wb(1), ..., wb(L), theta ),
  where theta corresponds to the linear part, and wb(i), i = 1 : L,
  correspond to the nonlinear part. See SLICOT Library routine
  NF01AD for further details.

  The sum of squares of the error functions, defined by

     e(t) = y(t) - Y(t),  t = 1, 2, ..., NSMP,

  is minimized, where Y(t) is the measured output vector. The
  functions and their Jacobian matrices are evaluated by SLICOT
  Library routine NF01BF (the FCN routine in the call of MD03BD).
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  INIT    CHARACTER*1
          Specifies which parts have to be initialized, as follows:
          = 'L' : initialize the linear part only, X already
                  contains an initial approximation of the
                  nonlinearity;
          = 'S' : initialize the static nonlinearity only, X
                  already contains an initial approximation of the
                  linear part;
          = 'B' : initialize both linear and nonlinear parts;
          = 'N' : do not initialize anything, X already contains
                  an initial approximation.
          If INIT = 'S' or 'B', the error functions for the
          nonlinear part, and their Jacobian matrices, are evaluated
          by SLICOT Library routine NF01BE (used as a second FCN
          routine in the MD03BD call for the initialization step,
          see METHOD).
Input/Output Parameters 
  NOBR    (input) INTEGER
          If INIT = 'L' or 'B', NOBR is the number of block rows, s,
          in the input and output block Hankel matrices to be
          processed for estimating the linear part.  NOBR > 0.
          (In the MOESP theory,  NOBR  should be larger than  n,
          the estimated dimension of state vector.)
          This parameter is ignored if INIT is 'S' or 'N'.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L >= 0, and L > 0, if
          INIT = 'L' or 'B'.

  NSMP    (input) INTEGER
          The number of input and output samples, t.  NSMP >= 0, and
          NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'.

  N       (input/output) INTEGER
          The order of the linear part.
          If INIT = 'L' or 'B', and N < 0 on entry, the order is
          assumed unknown and it will be found by the routine.
          Otherwise, the input value will be used. If INIT = 'S'
          or 'N', N must be non-negative. The values N >= NOBR,
          or N = 0, are not acceptable if INIT = 'L' or 'B'.

  NN      (input) INTEGER
          The number of neurons which shall be used to approximate
          the nonlinear part.  NN >= 0.

  ITMAX1  (input) INTEGER
          The maximum number of iterations for the initialization of
          the static nonlinearity.
          This parameter is ignored if INIT is 'N' or 'L'.
          Otherwise, ITMAX1 >= 0.

  ITMAX2  (input) INTEGER
          The maximum number of iterations.  ITMAX2 >= 0.

  NPRINT  (input) INTEGER
          This parameter enables controlled printing of iterates if
          it is positive. In this case, FCN is called with IFLAG = 0
          at the beginning of the first iteration and every NPRINT
          iterations thereafter and immediately prior to return,
          and the current error norm is printed. Other intermediate
          results could be printed by modifying the corresponding
          FCN routine (NF01BE and/or NF01BF). If NPRINT <= 0, no
          special calls of FCN with IFLAG = 0 are made.

  U       (input) DOUBLE PRECISION array, dimension (LDU, M)
          The leading NSMP-by-M part of this array must contain the
          set of input samples,
          U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ).

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,NSMP).

  Y       (input) DOUBLE PRECISION array, dimension (LDY, L)
          The leading NSMP-by-L part of this array must contain the
          set of output samples,
          Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ).

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= MAX(1,NSMP).

  X       (input/output) DOUBLE PRECISION array dimension (LX)
          On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part
          of this array must contain the initial parameters for
          the nonlinear part of the system.
          On entry, if INIT = 'S', the elements lin1 : lin2 of this
          array must contain the initial parameters for the linear
          part of the system, corresponding to the output normal
          form, computed by SLICOT Library routine TB01VD, where
             lin1 = (NN*(L+2) + 1)*L + 1;
             lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M.
          On entry, if INIT = 'N', the elements 1 : lin2 of this
          array must contain the initial parameters for the
          nonlinear part followed by the initial parameters for the
          linear part of the system, as specified above.
          This array need not be set on entry if INIT = 'B'.
          On exit, the elements 1 : lin2 of this array contain the
          optimal parameters for the nonlinear part followed by the
          optimal parameters for the linear part of the system, as
          specified above.

  LX      (input/output) INTEGER
          On entry, this parameter must contain the intended length
          of X. If N >= 0, then LX >= NX := lin2 (see parameter X).
          If N is unknown (N < 0 on entry), a large enough estimate
          of N should be used in the formula of lin2.
          On exit, if N < 0 on entry, but LX is not large enough,
          then this parameter contains the actual length of X,
          corresponding to the computed N. Otherwise, its value
          is unchanged.
Tolerances 
  TOL1    DOUBLE PRECISION
          If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance
          which measures the relative error desired in the sum of
          squares, as well as the relative error desired in the
          approximate solution, for the initialization step of
          nonlinear part. Termination occurs when either both the
          actual and predicted relative reductions in the sum of
          squares, or the relative error between two consecutive
          iterates are at most TOL1. If the user sets  TOL1 < 0,
          then  SQRT(EPS)  is used instead TOL1, where EPS is the
          machine precision (see LAPACK Library routine DLAMCH).
          This parameter is ignored if INIT is 'N' or 'L'.

  TOL2    DOUBLE PRECISION
          If TOL2 >= 0, TOL2 is the tolerance which measures the
          relative error desired in the sum of squares, as well as
          the relative error desired in the approximate solution,
          for the whole optimization process. Termination occurs
          when either both the actual and predicted relative
          reductions in the sum of squares, or the relative error
          between two consecutive iterates are at most TOL2. If the
          user sets TOL2 < 0, then  SQRT(EPS)  is used instead TOL2.
          This default value could require many iterations,
          especially if TOL1 is larger. If INIT = 'S' or 'B', it is
          advisable that TOL2 be larger than TOL1, and spend more
          time with cheaper iterations.
Workspace 
  IWORK   INTEGER array, dimension (MAX( LIW1, LIW2, LIW3 )), where
          LIW1 = LIW2 = 0,  if INIT = 'S' or 'N'; otherwise,
          LIW1 = M+L;
          LIW2 = MAX(M*NOBR+N,M*(N+L));
          LIW3 = 3+MAX(NN*(L+2)+2,NX+L), if INIT = 'S' or 'B';
          LIW3 = 3+NX+L,                 if INIT = 'L' or 'N'.
          On output, if INFO = 0, IWORK(1) and IWORK(2) return the
          (total) number of function and Jacobian evaluations,
          respectively (including the initialization step, if it was
          performed), and if INIT = 'L' or INIT = 'B', IWORK(3)
          specifies how many locations of DWORK contain reciprocal
          condition number estimates (see below); otherwise,
          IWORK(3) = 0. If INFO = 0, the entries 4 to 3+NX of IWORK
          define a permutation matrix P such that J*P = Q*R, where
          J is the final calculated Jacobian, Q is an orthogonal
          matrix (not stored), and R is upper triangular with
          diagonal elements of nonincreasing magnitude (possibly
          for each block column of J). Column j of P is column
          IWORK(3+j) of the identity matrix. Moreover, the entries
          4+NX:3+NX+L of this array contain the ranks of the final
          submatrices S_k (see description of LMPARM in MD03BD).

  DWORK   DOUBLE PRECISION array dimesion (LDWORK)
          On entry, if desired, and if INIT = 'S' or 'B', the
          entries DWORK(1:4) are set to initialize the random
          numbers generator for the nonlinear part parameters (see
          the description of the argument XINIT of SLICOT Library
          routine MD03BD); this enables to obtain reproducible
          results. The same seed is used for all outputs.
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, DWORK(2) returns the residual error norm (the
          sum of squares), DWORK(3) returns the number of iterations
          performed, and DWORK(4) returns the final Levenberg
          factor, for optimizing the parameters of both the linear
          part and the static nonlinearity part. If INIT = 'S' or
          INIT = 'B' and INFO = 0, then the elements DWORK(5) to
          DWORK(8) contain the corresponding four values for the
          initialization step (see METHOD). (If L > 1, DWORK(8)
          contains the maximum of the Levenberg factors for all
          outputs.) If INIT = 'L' or INIT = 'B', and INFO = 0,
          DWORK(9) to DWORK(8+IWORK(3)) contain reciprocal condition
          number estimates set by SLICOT Library routines IB01AD,
          IB01BD, and IB01CD.
          On exit, if  INFO = -21,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          In the formulas below, N should be taken not larger than
          NOBR - 1, if N < 0 on entry.
          LDWORK = MAX( LW1, LW2, LW3, LW4 ), where
          LW1 = 0, if INIT = 'S' or 'N'; otherwise,
          LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR,
                     4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) +
                     MAX( LDW1, LDW2 ),
                     (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) +
                     MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ),
              where,
              LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N,
                           L*NOBR*N +
                           MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L,
                                2*(L*NOBR-L)*N+N*N+8*N,
                                N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) )
              LDW2 >= 0,                                  if M = 0;
              LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) +
                      MAX( (N+L)**2, 4*M*(N+L)+1 ),       if M > 0;
              LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ),
              LDW4 = N*(N+1) + 2*N +
                     MAX( N*L*(N+1) + 2*N*N + L*N, 4*N );
              LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L;
              LDW6 = NSMP*L + (N+L)*(N+M) + N +
                     MAX(1, N*N*L + N*L + N, N*N +
                         MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L),
                             N*M));
          LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise,
          LW2 = NSMP*L + BSN +
                MAX( 4, NSMP +
                        MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ),
                             BSN**2 + BSN +
                             MAX( NSMP + 2*NN, 5*BSN ) ) );
          LW3 = MAX( LDW7, NSMP*L + (N+L)*(2*N+M) + 2*N );
              LDW7 = NSMP*L + (N+L)*(N+M) + 3*N+M+L,  if M > 0;
              LDW7 = NSMP*L + (N+L)*N + 2*N+L,        if M = 0;
          LW4 = NSMP*L + NX +
                MAX( 4, NSMP*L +
                        MAX( NSMP*L*( BSN + LTHS ) +
                             MAX( NSMP*L + L1, L2 + NX ),
                                  NX*( BSN + LTHS ) + NX +
                                  MAX( NSMP*L + L1, NX + L3 ) ) ),
               L0 = MAX( N*(N+L), N+M+L ),    if M > 0;
               L0 = MAX( N*(N+L), L ),        if M = 0;
               L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0);
               L2 = 4*NX + 1,  if L <= 1 or BSN = 0; otherwise,
               L2 = BSN + MAX(3*BSN+1,LTHS);
               L2 = MAX(L2,4*LTHS+1),         if NSMP > BSN;
               L2 = MAX(L2,(NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN;
               L3 = 4*NX,                     if L <= 1 or BSN = 0;
               L3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS),
                                              if L > 1 and BSN > 0,
               with BSN  = NN*( L + 2 ) + 1,
                    LTHS = N*( L + M + 1 ) + L*M.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          < 0:  the user set IFLAG = IWARN in (one of) the
                subroutine(s) FCN, i.e., NF01BE, if INIT = 'S'
                or 'B', and/or NF01BF; this value cannot be returned
                without changing the FCN routine(s);
                otherwise, IWARN has the value k*100 + j*10 + i,
                where k is defined below, i refers to the whole
                optimization process, and j refers to the
                initialization step (j = 0, if INIT = 'L' or 'N'),
                and the possible values for i and j have the
                following meaning (where TOL* denotes TOL1 or TOL2,
                and similarly for ITMAX*):
          = 1:  both actual and predicted relative reductions in
                the sum of squares are at most TOL*;
          = 2:  relative error between two consecutive iterates is
                at most TOL*;
          = 3:  conditions for i or j = 1 and i or j = 2 both hold;
          = 4:  the cosine of the angle between the vector of error
                function values and any column of the Jacobian is at
                most EPS in absolute value;
          = 5:  the number of iterations has reached ITMAX* without
                satisfying any convergence condition;
          = 6:  TOL* is too small: no further reduction in the sum
                of squares is possible;
          = 7:  TOL* is too small: no further improvement in the
                approximate solution X is possible;
          = 8:  the vector of function values e is orthogonal to the
                columns of the Jacobian to machine precision.
          The digit k is normally 0, but if INIT = 'L' or 'B', it
          can have a value in the range 1 to 6 (see IB01AD, IB01BD
          and IB01CD). In all these cases, the entries DWORK(1:4),
          DWORK(5:8) (if INIT = 'S' or 'B'), and DWORK(9:8+IWORK(3))
          (if INIT = 'L' or 'B'), are set as described above.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
                otherwise, INFO has the value k*100 + j*10 + i,
                where k is defined below, i refers to the whole
                optimization process, and j refers to the
                initialization step (j = 0, if INIT = 'L' or 'N'),
                and the possible values for i and j have the
                following meaning:
          = 1:  the routine FCN returned with INFO <> 0 for
                IFLAG = 1;
          = 2:  the routine FCN returned with INFO <> 0 for
                IFLAG = 2;
          = 3:  the routine QRFACT returned with INFO <> 0;
          = 4:  the routine LMPARM returned with INFO <> 0.
          In addition, if INIT = 'L' or 'B', i could also be
          = 5:  if a Lyapunov equation could not be solved;
          = 6:  if the identified linear system is unstable;
          = 7:  if the QR algorithm failed on the state matrix
                of the identified linear system.
          QRFACT and LMPARM are generic names for SLICOT Library
          routines NF01BS and NF01BP, respectively, for the whole
          optimization process, and MD03BA and MD03BB, respectively,
          for the initialization step (if INIT = 'S' or 'B').
          The digit k is normally 0, but if INIT = 'L' or 'B', it
          can have a value in the range 1 to 10 (see IB01AD/IB01BD).
Method 
  If INIT = 'L' or 'B', the linear part of the system is
  approximated using the combined MOESP and N4SID algorithm. If
  necessary, this algorithm can also choose the order, but it is
  advantageous if the order is already known.

  If INIT = 'S' or 'B', the output of the approximated linear part
  is computed and used to calculate an approximation of the static
  nonlinearity using the Levenberg-Marquardt algorithm [1,3].
  This step is referred to as the (nonlinear) initialization step.

  As last step, the Levenberg-Marquardt algorithm is used again to
  optimize the parameters of the linear part and the static
  nonlinearity as a whole. Therefore, it is necessary to parametrise
  the matrices of the linear part. The output normal form [2]
  parameterisation is used.

  The Jacobian is computed analytically, for the nonlinear part, and
  numerically, for the linear part.
References 
  [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
      User's Guide for MINPACK-1.
      Applied Math. Division, Argonne National Laboratory, Argonne,
      Illinois, Report ANL-80-74, 1980.

  [2] Peeters, R.L.M., Hanzon, B., and Olivi, M.
      Balanced realizations of discrete-time stable all-pass
      systems and the tangential Schur algorithm.
      Proceedings of the European Control Conference,
      31 August - 3 September 1999, Karlsruhe, Germany.
      Session CP-6, Discrete-time Systems, 1999.

  [3] More, J.J.
      The Levenberg-Marquardt algorithm: implementation and theory.
      In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in
      Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg
      and New York, pp. 105-116, 1978.
Numerical Aspects 
  The Levenberg-Marquardt algorithm described in [3] is scaling
  invariant and globally convergent to (maybe local) minima.
  The convergence rate near a local minimum is quadratic, if the
  Jacobian is computed analytically, and linear, if the Jacobian
  is computed numerically.
Further Comments 
  None
Example

Program Text 

*     IB03BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           BSNM, LDU, LDY, LIWORK, LMAX, LTHS, LXM, MMAX,
     $                  NMAX, NNMAX, NOBRMX, NSMPMX
      PARAMETER         ( LMAX = 2, MMAX = 3, NOBRMX = 10, NNMAX = 12,
     $                    NMAX = 4, NSMPMX = 1024,
     $                    BSNM = NNMAX*( LMAX + 2 ) + 1,
     $                    LTHS = NMAX*( LMAX + MMAX + 1 ) + LMAX*MMAX,
     $                    LDU  = NSMPMX, LDY = NSMPMX,
     $                    LXM  = BSNM*LMAX + LTHS,
     $                    LIWORK = MAX( MMAX + LMAX, MMAX*NOBRMX + NMAX,
     $                                  MMAX*( NMAX + LMAX ), 3 +
     $                                  MAX( BSNM + 1, LXM + LMAX ) ) )
      INTEGER           L0, L1M, L2M, L3M, LDW1, LDW2, LDW3, LDW4, LDW5,
     $                  LDW6, LDW7, LDWORK, LW1, LW2, LW3, LW4
      PARAMETER         ( L0   = MAX( NMAX*( NMAX + LMAX ),
     $                                NMAX + MMAX + LMAX ),
     $                    L1M  = NSMPMX*LMAX +
     $                           MAX( 2*NNMAX,
     $                                ( NMAX + LMAX )*( NMAX + MMAX ) +
     $                                2*NMAX + L0 ),
     $                    L2M  = MAX( 4*LXM + 1, BSNM +
     $                                MAX( 3*BSNM + 1, LTHS ),
     $                                     NSMPMX*( LMAX - 1 ) ),
     $                    L3M  = MAX( 4*LXM, LTHS*BSNM + 2*LXM +
     $                                2*MAX( BSNM, LTHS ) ),
     $                    LDW1 = MAX( 2*( LMAX*NOBRMX - LMAX )*NMAX +
     $                                2*NMAX,
     $                                ( LMAX*NOBRMX - LMAX )*NMAX +
     $                                NMAX*NMAX + 7*NMAX,
     $                                LMAX*NOBRMX*NMAX +
     $                                MAX( ( LMAX*NOBRMX - LMAX )*NMAX +
     $                                     2*NMAX + LMAX +
     $                                     ( 2*MMAX + LMAX )*NOBRMX,
     $                                     2*( LMAX*NOBRMX - LMAX )*NMAX
     $                                   + NMAX*NMAX + 8*NMAX,
     $                                     NMAX + 4*( MMAX*NOBRMX +
     $                                                NMAX ) + 1,
     $                                     MMAX*NOBRMX + 3*NMAX + LMAX )
     $                              ),
     $                    LDW2 = LMAX*NOBRMX*NMAX +
     $                           MMAX*NOBRMX*( NMAX + LMAX )*
     $                           ( MMAX*( NMAX + LMAX ) + 1 ) +
     $                           MAX( ( NMAX + LMAX )**2,
     $                           4*MMAX*( NMAX + LMAX ) + 1 ),
     $                    LDW3 = NSMPMX*LMAX*( NMAX + 1 ) + 2*NMAX +
     $                           MAX( 2*NMAX*NMAX, 4*NMAX ),
     $                    LDW4 = NMAX*( NMAX + 1 ) + 2*NMAX +
     $                           MAX( NMAX*LMAX*( NMAX + 1 ) +
     $                           2*NMAX*NMAX + LMAX*NMAX, 4*NMAX ),
     $                    LDW5 = NSMPMX*LMAX + ( NMAX + LMAX )*
     $                           ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX,
     $                    LDW6 = NSMPMX*LMAX + ( NMAX + LMAX )*
     $                           ( NMAX + MMAX ) + NMAX +
     $                           MAX( 1, NMAX*NMAX*LMAX + NMAX*LMAX +
     $                                NMAX, NMAX*NMAX +
     $                                MAX( NMAX*NMAX +
     $                                     NMAX*MAX( NMAX, LMAX ) +
     $                                     6*NMAX + MIN( NMAX, LMAX ),
     $                                     NMAX*MMAX ) ),
     $                    LDW7 = NSMPMX*LMAX + ( NMAX + LMAX )*
     $                           ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX,
     $                    LW1  = MAX( 2*( MMAX + LMAX )*NOBRMX*
     $                                ( 2*( MMAX + LMAX )*( NOBRMX + 1 )
     $                                  + 3 ) + LMAX*NOBRMX,
     $                                4*( MMAX + LMAX )*NOBRMX*
     $                                ( MMAX + LMAX )*NOBRMX +
     $                                ( NMAX + LMAX )*( NMAX + MMAX ) +
     $                                MAX( LDW1, LDW2 ),
     $                                ( NMAX + LMAX )*( NMAX + MMAX ) +
     $                                NMAX + NMAX*NMAX + 2 +
     $                                NMAX*( NMAX + MMAX + LMAX ) +
     $                                MAX( 5*NMAX, 2, MIN( LDW3, LDW4 ),
     $                                     LDW5, LDW6 ) ),
     $                    LW2  = NSMPMX*LMAX + BSNM +
     $                           MAX( 4, NSMPMX +
     $                                MAX( NSMPMX*BSNM +
     $                                     MAX( 2*NNMAX, 5*BSNM + 1 ),
     $                                     BSNM**2 + BSNM +
     $                                     MAX( NSMPMX + 2*NNMAX,
     $                                          5*BSNM ) ) ),
     $                    LW3  = MAX( LDW7, NSMPMX*LMAX +
     $                                ( NMAX + LMAX )*( 2*NMAX + MMAX )+
     $                                2*NMAX ),
     $                    LW4  = NSMPMX*LMAX + LXM +
     $                           MAX( 4, NSMPMX*LMAX +
     $                                MAX( NSMPMX*LMAX*( BSNM + LTHS ) +
     $                                     MAX( NSMPMX*LMAX + L1M,
     $                                          L2M + LXM ),
     $                                          LXM*( BSNM + LTHS ) +
     $                                          LXM +
     $                                          MAX( NSMPMX*LMAX + L1M,
     $                                               LXM + L3M ) ) ),
     $                    LDWORK = MAX( LW1, LW2, LW3, LW4 ) )
*     .. Local Scalars ..
      LOGICAL           INIT1, INITB, INITL, INITN, INITS
      CHARACTER*1       INIT
      INTEGER           BSN, I, INFO, INI, ITER, ITMAX1, ITMAX2, IWARN,
     $                  J, L, L1, L2, LPAR, LX, M, N, NN, NOBR, NPRINT,
     $                  NS, NSMP
      DOUBLE PRECISION  TOL1, TOL2
*     .. Array Arguments ..
      INTEGER           IWORK(LIWORK)
      DOUBLE PRECISION  DWORK(LDWORK), U(LDU,MMAX), X(LXM), Y(LDY,LMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          IB03BD
*     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2,
     $                      NPRINT, TOL1, TOL2, INIT
      INITL = LSAME( INIT, 'L' )
      INITS = LSAME( INIT, 'S' )
      INITB = LSAME( INIT, 'B' )
      INITN = LSAME( INIT, 'N' )
      INIT1 = INITL .OR. INITB
      IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE
         IF( L.LE.0 .OR. L.GT.LMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) L
         ELSE
            NS = N
            IF( INIT1 ) THEN
               IF( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN
                  WRITE ( NOUT, FMT = 99991 ) NOBR
                  STOP
               ELSEIF( NSMP.LT.2*( M + L + 1 )*NOBR - 1 ) THEN
                  WRITE ( NOUT, FMT = 99990 ) NSMP
                  STOP
               ELSEIF( N.EQ.0 .OR. N.GE.NOBR ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N
                  STOP
               END IF
               IF ( N.LT.0 )
     $            N = NOBR - 1
            ELSE
               IF( NSMP.LT.0 ) THEN
                  WRITE ( NOUT, FMT = 99990 ) NSMP
                  STOP
               ELSEIF( N.LT.0 .OR. N.GT.NMAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N
                  STOP
               END IF
            END IF
            IF( NN.LT.0 .OR. NN.GT.NNMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) NN
            ELSE
               BSN = NN*( L + 2 ) + 1
               L1  = BSN*L
               L2  = N*( L + M + 1 ) + L*M
               LX  = L1 + L2
               INI = 1
               IF ( INITL ) THEN
                  LPAR = L1
               ELSEIF ( INITS ) THEN
                  INI  = L1 + 1
                  LPAR = L2
               ELSEIF ( INITN ) THEN
                  LPAR = LX
               END IF
               IF( INIT1 )
     $            N = NS
*              Read the input-output data, initial parameters, and seed.
               READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,NSMP )
               READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1,L ), I = 1,NSMP )
               IF ( .NOT.INITB )
     $            READ ( NIN, FMT = * ) ( X(I), I = INI,INI+LPAR-1 )
               IF ( INITS .OR. INITB )
     $            READ ( NIN, FMT = * ) ( DWORK(I), I = 1,4 )
*              Solve a Wiener system identification problem.
               CALL IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1,
     $                      ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, TOL1,
     $                      TOL2, IWORK, DWORK, LDWORK, IWARN, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99987 ) IWARN
                  ITER = DWORK(3)
                  WRITE ( NOUT, FMT = 99997 ) DWORK(2)
                  WRITE ( NOUT, FMT = 99996 ) ITER, IWORK(1), IWORK(2)
*                 Recompute LX is necessary.
                  IF ( INIT1 .AND. NS.LT.0 )
     $               LX = L1 + N*( L + M + 1 ) + L*M
                  WRITE ( NOUT, FMT = 99994 )
                  WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, LX )
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' IB03BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from IB03BD = ',I4)
99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7)
99996 FORMAT (/' Number of iterations                     = ', I7,
     $        /' Number of function evaluations           = ', I7,
     $        /' Number of Jacobian evaluations           = ', I7)
99995 FORMAT (10(1X,F9.4))
99994 FORMAT (/' Final approximate solution is ' )
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' L is out of range.',/' L = ',I5)
99991 FORMAT (/' NOBR is out of range.',/' NOBR = ',I5)
99990 FORMAT (/' NSMP is out of range.',/' NSMP = ',I5)
99989 FORMAT (/' N is out of range.',/' N = ',I5)
99988 FORMAT (/' NN is out of range.',/' NN = ',I5)
99987 FORMAT (' IWARN on exit from IB03BD = ',I4)
      END
Program Data 
 IB03BD EXAMPLE PROGRAM DATA
 10     1     1  1024    4   12   500  1000     0  .00001  .00001   B
   2.2183165e-01
   3.9027807e-02
  -5.0295887e-02
   8.5386224e-03
   7.2431159e-02
  -1.7082198e-03
  -1.7176287e-01
  -2.6198104e-01
  -1.7194108e-01
   1.8566868e-02
   1.5625362e-01
   1.7463811e-01
   1.1564450e-01
   2.8779248e-02
  -8.4265993e-02
  -2.0978501e-01
  -2.6591828e-01
  -1.7268680e-01
   2.1525013e-02
   1.4363602e-01
   7.3101431e-02
  -1.0259212e-01
  -1.6380473e-01
  -1.0021167e-02
   2.0263451e-01
   2.1983417e-01
  -2.1636523e-02
  -3.0986057e-01
  -3.8521982e-01
  -2.1785179e-01
  -1.4761096e-02
   3.7005180e-02
  -2.8119028e-02
  -4.2167901e-02
   5.2117694e-02
   1.2023747e-01
   1.8863385e-02
  -1.9506434e-01
  -3.0192175e-01
  -1.7000747e-01
   8.0740471e-02
   2.0188076e-01
   8.5108288e-02
  -1.3270970e-01
  -2.3646822e-01
  -1.6505385e-01
  -4.7448014e-02
  -2.7886815e-02
  -1.0152026e-01
  -1.4155374e-01
  -6.1650823e-02
   8.3519614e-02
   1.5926650e-01
   8.6142760e-02
  -9.4385381e-02
  -2.6609066e-01
  -3.2883874e-01
  -2.5908050e-01
  -1.1648940e-01
  -3.0653766e-03
   1.0326675e-02
  -5.3445909e-02
  -9.2412724e-02
  -3.0279541e-02
   8.4846832e-02
   1.1133075e-01
  -3.2135250e-02
  -2.5308181e-01
  -3.5670882e-01
  -2.4458860e-01
  -2.5254261e-02
   9.3714332e-02
   1.8643667e-02
  -1.4592119e-01
  -2.2730880e-01
  -1.7140060e-01
  -7.4131665e-02
  -3.9669515e-02
  -5.1266129e-02
  -1.1752833e-02
   1.0785565e-01
   2.0665525e-01
   1.6117322e-01
  -2.6938653e-02
  -2.1941152e-01
  -2.7753567e-01
  -1.8805912e-01
  -4.6845025e-02
   5.8585698e-02
   1.2218407e-01
   1.7838638e-01
   2.2169815e-01
   1.9825589e-01
   8.0215288e-02
  -7.2135308e-02
  -1.4381520e-01
  -6.8724371e-02
   1.0191205e-01
   2.3766633e-01
   2.3876101e-01
   1.1678077e-01
  -2.0428168e-02
  -5.8973233e-02
   3.1326900e-02
   1.7391495e-01
   2.4558570e-01
   1.7650262e-01
   1.2444292e-02
  -1.1538234e-01
  -9.5917970e-02
   6.4762165e-02
   2.4258524e-01
   3.0102251e-01
   2.1222960e-01
   7.8706189e-02
   3.1500466e-02
   1.0297577e-01
   1.9875173e-01
   1.9434906e-01
   5.8146667e-02
  -1.1941921e-01
  -2.1038478e-01
  -1.5594967e-01
   1.8552198e-03
   1.6878529e-01
   2.5937416e-01
   2.2516346e-01
   6.6144472e-02
  -1.5623019e-01
  -3.3161105e-01
  -3.6695732e-01
  -2.6565333e-01
  -1.3254832e-01
  -8.0101064e-02
  -1.2531889e-01
  -1.8843171e-01
  -1.9038956e-01
  -1.3230055e-01
  -7.0889306e-02
  -3.9679280e-02
  -2.6286077e-02
  -2.3630770e-02
  -6.0652834e-02
  -1.4929250e-01
  -2.2155095e-01
  -1.7331044e-01
   5.2693564e-03
   1.7683919e-01
   1.8244690e-01
   2.5118458e-02
  -1.1051051e-01
  -5.1764984e-02
   1.6342054e-01
   3.1563281e-01
   2.3808751e-01
  -4.4871135e-03
  -1.8778679e-01
  -1.6017584e-01
   2.3481991e-02
   1.9209185e-01
   2.4281065e-01
   2.1224192e-01
   1.8825017e-01
   1.9811718e-01
   2.0202486e-01
   1.6812825e-01
   1.1444796e-01
   7.2452475e-02
   4.0090973e-02
  -6.7139529e-03
  -6.8721730e-02
  -1.1460099e-01
  -1.1914168e-01
  -8.9852521e-02
  -4.5942222e-02
   1.0932686e-02
   8.1900393e-02
   1.3092374e-01
   9.0790221e-02
  -6.3538148e-02
  -2.5119963e-01
  -3.2585173e-01
  -2.0850925e-01
   1.7922009e-02
   1.6783753e-01
   1.2518317e-01
  -4.3517162e-02
  -1.5783138e-01
  -1.0686847e-01
   4.4782565e-02
   1.3893172e-01
   9.8691579e-02
   2.6311282e-03
  -1.6073049e-02
   7.8512306e-02
   1.9453537e-01
   2.2504627e-01
   1.6121235e-01
   7.8124056e-02
   2.9774586e-02
  -5.3899280e-03
  -6.5745322e-02
  -1.2329059e-01
  -9.5096521e-02
   5.5471394e-02
   2.5017082e-01
   3.4773286e-01
   2.6656242e-01
   5.3705965e-02
  -1.6135006e-01
  -2.7310977e-01
  -2.6814818e-01
  -2.1074926e-01
  -1.7743213e-01
  -1.9796482e-01
  -2.4059041e-01
  -2.4663820e-01
  -1.8780129e-01
  -9.8317382e-02
  -4.7848155e-02
  -7.3425069e-02
  -1.3529842e-01
  -1.4739094e-01
  -6.2482366e-02
   6.8729554e-02
   1.3251322e-01
   6.1482940e-02
  -8.5065014e-02
  -1.6074078e-01
  -6.7974104e-02
   1.3976672e-01
   2.9838081e-01
   2.8233998e-01
   1.1391411e-01
  -7.1966946e-02
  -1.5876983e-01
  -1.3805556e-01
  -8.2998592e-02
  -5.7864811e-02
  -6.5300733e-02
  -7.0590592e-02
  -5.5847027e-02
  -4.1219301e-02
  -6.1578267e-02
  -1.3176243e-01
  -2.2968907e-01
  -3.0193311e-01
  -2.8770451e-01
  -1.5729276e-01
   5.4414593e-02
   2.5362617e-01
   3.4482230e-01
   3.0119122e-01
   1.8534835e-01
   9.6712488e-02
   9.3385279e-02
   1.6057572e-01
   2.4424680e-01
   3.0164891e-01
   3.1693510e-01
   2.8441517e-01
   1.9948758e-01
   7.3600888e-02
  -5.4291337e-02
  -1.3721320e-01
  -1.5626045e-01
  -1.3464149e-01
  -1.1510541e-01
  -1.2587072e-01
  -1.6605420e-01
  -2.1242088e-01
  -2.3059410e-01
  -1.8785957e-01
  -7.8188380e-02
   5.0484398e-02
   1.0697957e-01
   2.7421051e-02
  -1.4419852e-01
  -2.5888039e-01
  -1.8018121e-01
   7.8519535e-02
   3.4009981e-01
   4.0793257e-01
   2.3842529e-01
  -2.7029751e-02
  -1.9919385e-01
  -2.0420528e-01
  -1.1389043e-01
  -3.5602606e-02
   5.7385906e-04
   3.8759790e-02
   1.0691941e-01
   1.6303496e-01
   1.4314046e-01
   4.7786789e-02
  -4.1030659e-02
  -3.5960232e-02
   7.0498851e-02
   2.0120383e-01
   2.6638170e-01
   2.3249669e-01
   1.2937468e-01
   1.3309043e-02
  -6.2770099e-02
  -5.8936178e-02
   3.4143049e-02
   1.6425689e-01
   2.2228910e-01
   1.2062705e-01
  -1.0832755e-01
  -3.0711352e-01
  -3.2002334e-01
  -1.4072879e-01
   7.6263091e-02
   1.6385270e-01
   1.0093887e-01
   1.7269577e-02
   4.3458474e-02
   1.6769625e-01
   2.4967945e-01
   1.7314220e-01
  -2.7519776e-02
  -1.9806822e-01
  -2.1140982e-01
  -7.2758850e-02
   1.1057470e-01
   2.3440218e-01
   2.5956640e-01
   1.9629970e-01
   7.2200120e-02
  -6.6390448e-02
  -1.4805958e-01
  -1.1487691e-01
   1.3561014e-02
   1.3146288e-01
   1.3205007e-01
   1.5159726e-02
  -9.9141126e-02
  -7.9831031e-02
   8.4487631e-02
   2.6348526e-01
   2.9617209e-01
   1.3322758e-01
  -1.1642178e-01
  -2.7289866e-01
  -2.2996687e-01
  -3.5143323e-02
   1.5983180e-01
   2.3035457e-01
   1.7179773e-01
   7.3333592e-02
   1.1653452e-02
  -1.8499701e-02
  -6.7962911e-02
  -1.4361094e-01
  -1.7665147e-01
  -9.1259528e-02
   9.8323111e-02
   2.6912800e-01
   2.8047779e-01
   9.9377687e-02
  -1.5436535e-01
  -2.9569363e-01
  -2.3017874e-01
  -4.1007324e-02
   8.2484352e-02
   2.1760384e-02
  -1.5212456e-01
  -2.4257965e-01
  -1.2641528e-01
   1.0676585e-01
   2.2865135e-01
   1.0211687e-01
  -1.6408728e-01
  -3.0761461e-01
  -1.7309336e-01
   1.2302931e-01
   3.0157576e-01
   1.9992664e-01
  -6.5766948e-02
  -2.2490680e-01
  -1.3209725e-01
   9.1452627e-02
   1.9707770e-01
   7.0972862e-02
  -1.6016460e-01
  -2.7859962e-01
  -2.0288880e-01
  -4.9817844e-02
   1.3587087e-02
  -5.2447125e-02
  -1.4164147e-01
  -1.3776729e-01
  -3.9470574e-02
   5.4688171e-02
   5.9780155e-02
  -2.0666265e-02
  -1.2306679e-01
  -1.9150051e-01
  -1.9953793e-01
  -1.3072099e-01
   1.7129752e-02
   1.9139299e-01
   2.8015628e-01
   1.9737258e-01
  -1.0273734e-02
  -1.6921879e-01
  -1.2914132e-01
   8.3866166e-02
   2.8290870e-01
   3.0288568e-01
   1.5939055e-01
   1.4121758e-02
  -8.0309556e-03
   5.7046152e-02
   7.8808779e-02
  -4.0300321e-04
  -9.3021531e-02
  -6.6955916e-02
   1.0073094e-01
   2.8905786e-01
   3.4946321e-01
   2.4220689e-01
   5.3331283e-02
  -1.0609621e-01
  -1.9358889e-01
  -2.2728166e-01
  -2.1680862e-01
  -1.4144032e-01
  -5.2173696e-03
   1.1701944e-01
   1.2668247e-01
   4.8375112e-03
  -1.4889224e-01
  -1.9905951e-01
  -9.9563224e-02
   6.4580042e-02
   1.5505008e-01
   9.7617503e-02
  -6.4905019e-02
  -2.1769152e-01
  -2.6787937e-01
  -2.0919394e-01
  -1.1033568e-01
  -4.3266567e-02
  -1.8066266e-02
   1.3641281e-02
   9.0806946e-02
   1.8645977e-01
   2.3150216e-01
   1.9334856e-01
   1.1238648e-01
   4.9498545e-02
   1.3155560e-02
  -3.5876844e-02
  -1.0537074e-01
  -1.2612890e-01
  -1.8934023e-02
   1.8850628e-01
   3.4290627e-01
   3.0108912e-01
   9.0554124e-02
  -9.4812468e-02
  -8.8842381e-02
   6.3160674e-02
   1.4646977e-01
   1.7441277e-02
  -2.2104173e-01
  -3.1862778e-01
  -1.5530235e-01
   1.1291463e-01
   2.1663682e-01
   7.1521680e-02
  -1.2722266e-01
  -1.3147084e-01
   6.8036453e-02
   2.2914846e-01
   1.4875917e-01
  -8.5725554e-02
  -1.9280127e-01
  -3.7053987e-02
   1.9484616e-01
   2.0627194e-01
  -5.0290692e-02
  -2.9703694e-01
  -2.4262627e-01
   7.3980280e-02
   3.1209111e-01
   2.0500085e-01
  -1.4678863e-01
  -3.9620361e-01
  -3.3299784e-01
  -8.5315346e-02
   7.0026906e-02
   3.1783466e-02
  -5.6224174e-02
  -3.8238612e-02
   4.1162402e-02
   1.4020902e-02
  -1.6267337e-01
  -3.2229719e-01
  -2.8405914e-01
  -8.0208074e-02
   7.7279407e-02
   5.2461001e-02
  -5.6931255e-02
  -5.7081867e-02
   8.4722273e-02
   1.8989091e-01
   9.1251490e-02
  -1.4913841e-01
  -3.0047660e-01
  -2.2924644e-01
  -4.5027749e-02
   4.5847665e-02
  -1.0582268e-02
  -7.0165157e-02
   8.8253349e-03
   1.7968871e-01
   2.6336655e-01
   1.6274839e-01
  -3.4038513e-02
  -1.6866975e-01
  -1.7822821e-01
  -1.1212378e-01
  -2.2511191e-02
   9.2633595e-02
   2.2273027e-01
   2.8312792e-01
   1.8855450e-01
  -1.3339719e-02
  -1.4451328e-01
  -7.9411873e-02
   9.5243626e-02
   1.5825934e-01
   8.6924573e-03
  -1.9762612e-01
  -2.0963986e-01
   3.0881541e-02
   3.1088543e-01
   3.7605990e-01
   2.0371110e-01
   3.1659734e-03
  -4.2255731e-02
   2.7937777e-02
   4.3768827e-02
  -5.0975761e-02
  -1.2013869e-01
  -1.9514056e-02
   1.9409077e-01
   3.0061057e-01
   1.6772761e-01
  -8.4377993e-02
  -2.0596833e-01
  -8.8137439e-02
   1.3053768e-01
   2.3231724e-01
   1.5592782e-01
   3.3546556e-02
   1.2609146e-02
   8.8143918e-02
   1.3076425e-01
   5.2445727e-02
  -9.1540218e-02
  -1.6532665e-01
  -8.9700956e-02
   9.2256458e-02
   2.6287064e-01
   3.2206114e-01
   2.4782579e-01
   1.0180547e-01
  -1.2653507e-02
  -2.4053903e-02
   4.5165362e-02
   9.2697417e-02
   3.9645255e-02
  -7.0244568e-02
  -9.7812594e-02
   4.0489353e-02
   2.5706426e-01
   3.5970764e-01
   2.4838839e-01
   2.8758245e-02
  -9.2051146e-02
  -1.8531616e-02
   1.4540527e-01
   2.2483594e-01
   1.6366159e-01
   6.0613849e-02
   2.6700790e-02
   4.8805007e-02
   2.4088984e-02
  -8.7776563e-02
  -1.9182802e-01
  -1.5875230e-01
   2.1332672e-02
   2.1574747e-01
   2.8121193e-01
   1.9605244e-01
   5.2140821e-02
  -6.0594054e-02
  -1.3111027e-01
  -1.9003660e-01
  -2.3031943e-01
  -1.9896872e-01
  -7.1576527e-02
   8.7126470e-02
   1.5966083e-01
   8.0700885e-02
  -9.6050487e-02
  -2.3768453e-01
  -2.4174619e-01
  -1.1781079e-01
   2.4058534e-02
   6.3114157e-02
  -3.4924911e-02
  -1.8708629e-01
  -2.5777811e-01
  -1.7457598e-01
   2.3256558e-03
   1.2615984e-01
   9.1298660e-02
  -7.2869748e-02
  -2.3064584e-01
  -2.6487668e-01
  -1.7896622e-01
  -8.1019614e-02
  -7.2160218e-02
  -1.5109102e-01
  -2.2270453e-01
  -1.9311631e-01
  -5.5949947e-02
   1.0558527e-01
   1.9015867e-01
   1.5010510e-01
   9.3491571e-03
  -1.6206410e-01
  -2.7872156e-01
  -2.6789883e-01
  -1.0908763e-01
   1.3219241e-01
   3.2581004e-01
   3.6597785e-01
   2.5860903e-01
   1.1593033e-01
   5.3232658e-02
   8.9253999e-02
   1.5038178e-01
   1.6325136e-01
   1.2516262e-01
   8.1000365e-02
   5.6249003e-02
   4.1260796e-02
   3.6021307e-02
   7.0909773e-02
   1.5431016e-01
   2.1909293e-01
   1.6946538e-01
   1.3913978e-03
  -1.5472276e-01
  -1.5445369e-01
  -6.5114694e-03
   1.1511921e-01
   5.3537688e-02
  -1.4926948e-01
  -2.8563000e-01
  -2.0489020e-01
   2.2256191e-02
   1.8089745e-01
   1.3686717e-01
  -4.3194077e-02
  -1.9185844e-01
  -2.2260927e-01
  -1.8688905e-01
  -1.7299493e-01
  -1.9552456e-01
  -2.0311384e-01
  -1.6521655e-01
  -1.1035364e-01
  -7.5596967e-02
  -5.2167223e-02
  -5.0648414e-03
   6.7754101e-02
   1.2412118e-01
   1.2838133e-01
   9.0308482e-02
   4.0708671e-02
  -1.2463102e-02
  -7.6325303e-02
  -1.2432208e-01
  -9.0380523e-02
   5.7426602e-02
   2.4318485e-01
   3.1839858e-01
   2.0029814e-01
  -2.6893656e-02
  -1.7351791e-01
  -1.2458940e-01
   4.6580380e-02
   1.5624992e-01
   9.9382689e-02
  -5.1882624e-02
  -1.4100610e-01
  -1.0040874e-01
  -1.2845131e-02
  -3.6737447e-03
  -9.7637188e-02
  -2.0172142e-01
  -2.1938378e-01
  -1.5223806e-01
  -7.5818447e-02
  -3.6932476e-02
  -8.3361793e-03
   4.9321106e-02
   1.0828653e-01
   8.6261922e-02
  -5.6487106e-02
  -2.4839500e-01
  -3.5078033e-01
  -2.7598256e-01
  -6.2963150e-02
   1.5901166e-01
   2.7685307e-01
   2.7164897e-01
   2.1079033e-01
   1.7714997e-01
   2.0086813e-01
   2.4438441e-01
   2.4570310e-01
   1.8078261e-01
   9.0365447e-02
   4.4844498e-02
   7.6311118e-02
   1.4103984e-01
   1.5313326e-01
   6.6678933e-02
  -6.7720328e-02
  -1.3565971e-01
  -6.6316159e-02
   8.3832277e-02
   1.6588475e-01
   7.6147385e-02
  -1.3444251e-01
  -2.9759248e-01
  -2.8274479e-01
  -1.1318459e-01
   7.1421886e-02
   1.5414324e-01
   1.3182338e-01
   8.0829372e-02
   6.0814130e-02
   6.6565578e-02
   6.1490382e-02
   3.4525574e-02
   1.4709018e-02
   3.9340413e-02
   1.1733787e-01
   2.1846966e-01
   2.8684125e-01
   2.6688313e-01
   1.3632576e-01
  -6.7370697e-02
  -2.5502586e-01
  -3.3949317e-01
  -3.0013913e-01
  -1.9871892e-01
  -1.2610649e-01
  -1.2941580e-01
  -1.8923457e-01
  -2.5813995e-01
  -3.0533743e-01
  -3.1970649e-01
  -2.8788006e-01
  -1.9500297e-01
  -5.4155345e-02
   8.1116905e-02
   1.5269009e-01
   1.4976106e-01
   1.1681611e-01
   1.0728712e-01
   1.3670700e-01
   1.8344060e-01
   2.2041268e-01
   2.2972773e-01
   1.9334746e-01
   9.8734288e-02
  -2.6231283e-02
  -9.9070456e-02
  -4.1644202e-02
   1.2360480e-01
   2.5212308e-01
   1.9060093e-01
  -6.5066267e-02
  -3.3581971e-01
  -4.0871250e-01
  -2.3222990e-01
   4.0796545e-02
   2.0553146e-01
   1.9047036e-01
   8.7982654e-02
   2.1078714e-02
   1.1947834e-02
  -7.4158796e-03
  -8.0649898e-02
  -1.5932177e-01
  -1.5963498e-01
  -6.7654645e-02
   3.3754864e-02
   4.5488264e-02
  -5.1656648e-02
  -1.8439778e-01
  -2.5821552e-01
  -2.3168258e-01
  -1.3075945e-01
  -1.4319768e-02
   6.0276859e-02
   5.2808278e-02
  -4.2009846e-02
  -1.6857834e-01
  -2.1862301e-01
  -1.0815610e-01
   1.2758494e-01
   3.3007803e-01
   3.4236071e-01
   1.5606744e-01
  -7.3906241e-02
  -1.7487103e-01
  -1.1779263e-01
  -2.8797157e-02
  -4.2649366e-02
  -1.5603253e-01
  -2.3465677e-01
  -1.6213440e-01
   3.1155521e-02
   1.9455902e-01
   2.0308035e-01
   6.4105637e-02
  -1.1373221e-01
  -2.2912186e-01
  -2.4930244e-01
  -1.8794162e-01
  -6.9023299e-02
   6.6894859e-02
   1.4860950e-01
   1.1319286e-01
  -2.1622177e-02
  -1.4430675e-01
  -1.4139382e-01
  -1.4679189e-02
   1.0606471e-01
   8.3987908e-02
  -8.6549724e-02
  -2.6473902e-01
  -2.8787546e-01
  -1.1665499e-01
   1.3032718e-01
   2.7649250e-01
   2.2886289e-01
   4.1972959e-02
  -1.4166947e-01
  -2.1351821e-01
  -1.7294568e-01
  -9.5242426e-02
  -3.9988034e-02
   6.0215518e-04
   6.4278100e-02
   1.4411085e-01
   1.7008073e-01
   7.6346726e-02
  -1.1397897e-01
  -2.7942868e-01
  -2.8837790e-01
  -1.1356283e-01
   1.2995490e-01
   2.6791352e-01
   2.1050936e-01
   3.2758432e-02
  -8.8492035e-02
  -3.6187051e-02
   1.3102808e-01
   2.2789768e-01
   1.2664599e-01
  -9.9240525e-02
  -2.3008477e-01
  -1.1958430e-01
   1.3943384e-01
   2.8863442e-01
   1.6130336e-01
  -1.3747854e-01
  -3.2522857e-01
  -2.2524885e-01
   5.3864511e-02
   2.3305883e-01
   1.5177574e-01
  -7.4373920e-02
  -1.8870441e-01
  -6.7093573e-02
   1.6495747e-01
   2.8369836e-01
   2.0511206e-01
   5.1011236e-02
  -6.5929875e-03
   6.8964562e-02
   1.6340844e-01
   1.5740112e-01
   5.4023734e-02
  -4.3471011e-02
  -5.1346211e-02
   2.3145779e-02
   1.1745308e-01
   1.8212689e-01
   1.9584070e-01
   1.4022670e-01
   5.9022790e-03
  -1.6079919e-01
  -2.4935419e-01
  -1.7100378e-01
   3.1256057e-02
   1.8605482e-01
   1.4297623e-01
  -7.3243962e-02
  -2.7593402e-01
  -2.9797544e-01
  -1.5307840e-01
  -4.0914832e-03
   2.1269662e-02
  -4.1497170e-02
  -5.9046655e-02
   2.7976789e-02
   1.2846949e-01
   1.0303296e-01
  -7.5938937e-02
  -2.8392411e-01
  -3.6123552e-01
  -2.5664252e-01
  -5.3262494e-02
   1.2879625e-01
   2.3255706e-01
   2.6842403e-01
   2.5122050e-01
   1.7087253e-01
   3.4014290e-02
  -9.3227815e-02
  -1.2001867e-01
  -2.1139059e-02
   1.2023890e-01
   1.7758447e-01
   9.6606085e-02
  -5.2792108e-02
  -1.3892628e-01
  -8.4350032e-02
   7.1620365e-02
   2.1524576e-01
   2.5910116e-01
   2.0627091e-01
   1.2532985e-01
   7.1727643e-02
   3.8319163e-02
  -1.9240088e-02
  -1.1662856e-01
  -2.1107703e-01
  -2.4258539e-01
  -1.9809090e-01
  -1.2271124e-01
  -6.5266079e-02
  -2.6001544e-02
   2.6587042e-02
   8.9979857e-02
   1.0112134e-01
  -1.6495775e-03
  -1.8712095e-01
  -3.2285436e-01
  -2.8769737e-01
  -1.0373843e-01
   6.3283390e-02
   6.4192144e-02
  -6.9141383e-02
  -1.4546154e-01
  -2.2743165e-02
   2.1671482e-01
   3.3495240e-01
   1.9730942e-01
  -6.4245098e-02
  -1.8430371e-01
  -5.9313975e-02
   1.3285821e-01
   1.3988590e-01
  -6.3313853e-02
  -2.3781208e-01
  -1.6565753e-01
   7.8634007e-02
   2.0643470e-01
   6.3051903e-02
  -1.7337120e-01
  -1.9553447e-01
   5.8877424e-02
   3.1320739e-01
   2.6455767e-01
  -5.6738794e-02
  -3.0614673e-01
  -2.0738949e-01
   1.4261991e-01
   3.9321755e-01
   3.3131011e-01
   8.6485026e-02
  -6.3943179e-02
  -2.3354764e-02
   5.9552949e-02
   3.1845636e-02
  -5.2189216e-02
  -1.8514555e-02
   1.7050716e-01
   3.3649462e-01
   2.9310084e-01
   7.8582244e-02
  -8.5200138e-02
  -5.9242022e-02
   5.3629257e-02
   5.3919799e-02
  -9.1290610e-02
  -1.9983794e-01
  -1.0236954e-01
   1.3831631e-01
   2.9035137e-01
  -1.7703630e-01
  -1.1470789e-01
  -1.7257803e-02
   7.3360924e-02
   1.2806267e-01
   1.3650217e-01
   1.0539571e-01
   5.4901306e-02
   1.0347593e-02
  -1.4210364e-02
  -2.9316079e-02
  -5.9818410e-02
  -1.1287079e-01
  -1.5651256e-01
  -1.3759239e-01
  -3.1325918e-02
   1.2118952e-01
   2.2925439e-01
   2.1688928e-01
   8.3280850e-02
  -9.0968958e-02
  -1.9863421e-01
  -1.7919413e-01
  -5.4874063e-02
   9.1323774e-02
   1.7241745e-01
   1.4973591e-01
   5.1202694e-02
  -5.0722214e-02
  -8.6474562e-02
  -3.6675604e-02
   5.0794719e-02
   9.2852996e-02
   3.5475423e-02
  -9.8019853e-02
  -2.1560266e-01
  -2.2054921e-01
  -8.4207430e-02
   1.2773783e-01
   2.9411889e-01
   3.1432928e-01
   1.7183620e-01
  -5.3673166e-02
  -2.3087548e-01
  -2.5206313e-01
  -9.9556443e-02
   1.3579254e-01
   3.0302360e-01
   2.8345210e-01
   6.9698019e-02
  -2.2311064e-01
  -4.2606792e-01
  -4.1979542e-01
  -2.0235411e-01
   1.1680679e-01
   3.8269042e-01
   4.7499251e-01
   3.6130151e-01
   1.0698485e-01
  -1.5666457e-01
  -2.9684785e-01
  -2.5130444e-01
  -6.7456399e-02
   1.2329504e-01
   1.8968350e-01
   8.9456729e-02
  -1.0185072e-01
  -2.4339863e-01
  -2.2562726e-01
  -4.5215735e-02
   1.9190737e-01
   3.3930982e-01
   3.0360010e-01
   1.0486525e-01
  -1.3364785e-01
  -2.6276635e-01
  -2.0355127e-01
  -1.0514338e-03
   2.0109829e-01
   2.5410141e-01
   1.0538640e-01
  -1.6182684e-01
  -3.7724711e-01
  -3.8906986e-01
  -1.6075631e-01
   2.0065197e-01
   5.0030087e-01
   5.6260189e-01
   3.3306758e-01
  -8.1981699e-02
  -4.6637054e-01
  -6.1157444e-01
  -4.3578631e-01
  -3.4787751e-02
   3.6943357e-01
   5.5331393e-01
   4.1651911e-01
   3.8203811e-02
  -3.6624642e-01
  -5.6531588e-01
  -4.4111547e-01
  -5.7977077e-02
   3.6800859e-01
   5.8749279e-01
   4.6334166e-01
   5.9154789e-02
  -3.8817476e-01
  -6.0585734e-01
  -4.5438072e-01
  -2.1770889e-02
   4.2269933e-01
   5.9388393e-01
   3.7277877e-01
  -1.1367643e-01
  -5.6785416e-01
  -7.0538273e-01
  -4.3261293e-01
   9.5667577e-02
   5.7311674e-01
   7.2849359e-01
   4.8697304e-01
   9.0040534e-03
  -4.1643634e-01
  -5.5375692e-01
  -3.6053568e-01
   1.0675442e-03
   2.8391467e-01
   3.2050851e-01
   1.2014875e-01
  -1.5499683e-01
  -3.0636590e-01
  -2.2845450e-01
   3.0168597e-02
   3.0447079e-01
   4.1814633e-01
   2.9408146e-01
   3.3795396e-03
  -2.8043536e-01
  -3.9163122e-01
  -2.7524621e-01
  -1.6330862e-02
   2.2338646e-01
   3.1163298e-01
   2.1884631e-01
   2.0034460e-02
  -1.6244160e-01
  -2.3122765e-01
  -1.5928083e-01
   4.5460308e-03
   1.6378113e-01
   2.2566835e-01
   1.5187573e-01
  -1.8633628e-02
  -1.8835877e-01
  -2.5597784e-01
  -1.7568160e-01
   1.6144538e-02
   2.1796548e-01
   3.1334397e-01
   2.3350541e-01
   9.9054075e-04
  -2.7139443e-01
  -4.3349329e-01
  -3.8409180e-01
  -1.3941008e-01
   1.6850242e-01
   3.6865127e-01
   3.5669633e-01
   1.5962938e-01
  -8.6421861e-02
  -2.2603591e-01
  -1.7879992e-01
   1.5608870e-02
   2.2316774e-01
   2.9540664e-01
   1.5777130e-01
  -1.3932674e-01
  -4.3707134e-01
  -5.5308393e-01
  -3.9056636e-01
  -6.9866596e-03
   4.0342788e-01
   6.1470960e-01
   5.0478901e-01
   1.3556472e-01
  -2.7661265e-01
  -4.8754120e-01
  -3.7410263e-01
  -1.0933935e-02
   3.7332700e-01
   5.3265415e-01
   3.5296792e-01
  -7.5112937e-02
  -5.0630963e-01
  -6.8543131e-01
  -5.0254861e-01
  -6.3204556e-02
   3.7616490e-01
   5.6861420e-01
   4.2839911e-01
   7.7256895e-02
  -2.4286013e-01
  -3.2974149e-01
  -1.4621212e-01
   1.6396591e-01
   3.7227253e-01
   3.1398669e-01
  -1.5203951e-03
  -3.8826155e-01
  -5.9422715e-01
  -4.6290884e-01
  -4.4082503e-02
   4.2614489e-01
   6.6944646e-01
   5.4057059e-01
   1.1914310e-01
  -3.4186097e-01
  -5.7361170e-01
  -4.5144665e-01
  -6.3037624e-02
   3.5015696e-01
   5.3940241e-01
   3.9354970e-01
   6.6063109e-05
  -4.0735798e-01
  -5.8396114e-01
  -4.1610263e-01
   1.0313382e-02
   4.5449701e-01
   6.5638620e-01
   4.8903578e-01
   3.8482894e-02
  -4.3952337e-01
  -6.6436421e-01
  -4.9492372e-01
  -1.7915270e-02
   4.9445240e-01
   7.3828446e-01
   5.5772875e-01
   4.3827397e-02
  -5.1216643e-01
  -7.8827423e-01
  -6.2373284e-01
  -1.1577453e-01
   4.4053448e-01
   7.3121649e-01
   6.0691719e-01
   1.6037942e-01
  -3.4101558e-01
  -6.1837622e-01
  -5.3898039e-01
  -1.7955555e-01
   2.3296574e-01
   4.6098842e-01
   3.9204767e-01
   9.4586522e-02
  -2.3425494e-01
  -3.9383077e-01
  -2.9901136e-01
  -2.1727093e-02
   2.6290754e-01
   3.8667642e-01
   2.8641038e-01
   3.4299620e-02
  -2.1199530e-01
  -3.0703990e-01
  -2.0539827e-01
   1.3733625e-02
   1.9989717e-01
   2.2856610e-01
   8.0442398e-02
  -1.4924794e-01
  -3.1635143e-01
  -3.2043874e-01
  -1.6226330e-01
   6.7449386e-02
   2.5253008e-01
   3.1855044e-01
   2.6051993e-01
   1.2699840e-01
  -1.6342455e-02
  -1.1750854e-01
  -1.5094063e-01
  -1.1699324e-01
  -3.6407066e-02
   5.7070826e-02
   1.2470744e-01
   1.3295525e-01
   6.7237676e-02
  -5.6199791e-02
  -1.8928499e-01
  -2.6860491e-01
  -2.4751370e-01
  -1.2546869e-01
   4.7269068e-02
   1.9379936e-01
   2.5012057e-01
   1.9757699e-01
   6.9603172e-02
  -6.6884197e-02
  -1.4260360e-01
  -1.1800895e-01
  -4.5690911e-03
   1.3505757e-01
   2.1176910e-01
   1.5667518e-01
  -2.9715225e-02
  -2.6058872e-01
  -4.0072162e-01
  -3.4636170e-01
  -1.0002597e-01
   2.1522385e-01
   4.2116592e-01
   3.9178740e-01
   1.3552073e-01
  -2.0194672e-01
  -4.2193015e-01
  -3.9351670e-01
  -1.3365470e-01
   2.0423921e-01
   4.2544835e-01
   4.1162219e-01
   1.8730580e-01
  -1.0283670e-01
  -2.8986993e-01
  -2.8756628e-01
  -1.3866788e-01
   2.8290398e-02
   9.5513335e-02
   3.5118646e-02
  -8.2724881e-02
  -1.5147446e-01
  -1.0799938e-01
   2.6949604e-02
   1.6959254e-01
   2.3358015e-01
   1.8482066e-01
   5.6424609e-02
  -7.8806247e-02
  -1.5583364e-01
  -1.5299245e-01
  -9.3729273e-02
  -1.9708548e-02
   3.8600307e-02
   7.1469845e-02
   7.8472613e-02
   5.5625386e-02
  -1.0621857e-03
  -8.0782039e-02
  -1.5057837e-01
  -1.6705428e-01
  -1.0304932e-01
   2.9389143e-02
   1.7801990e-01
   2.7318425e-01
   2.6234323e-01
   1.3834554e-01
  -5.4215912e-02
  -2.3593270e-01
  -3.2392000e-01
  -2.6898405e-01
  -8.5844039e-02
   1.4215609e-01
   2.9652172e-01
   2.8801270e-01
   1.1683545e-01
  -1.1688760e-01
  -2.6947626e-01
  -2.4573958e-01
  -6.4329645e-02
   1.5353975e-01
   2.6653313e-01
   2.0755588e-01
   2.4602079e-02
  -1.5772495e-01
  -2.2567844e-01
  -1.4875573e-01
   9.9414396e-03
   1.4397851e-01
   1.7486115e-01
   9.6314112e-02
  -3.2169687e-02
  -1.2887854e-01
  -1.3861783e-01
  -5.9693947e-02
   6.1826068e-02
   1.6117670e-01
   1.8758542e-01
   1.2643056e-01
   4.7038639e-03
  -1.2089033e-01
  -1.8936563e-01
  -1.6676448e-01
  -6.8240952e-02
   4.6702545e-02
   1.0911959e-01
   8.7135042e-02
   1.1538006e-02
  -4.4789930e-02
  -2.4262269e-02
   6.5437901e-02
   1.5116338e-01
   1.4886934e-01
   3.3820535e-02
  -1.3097789e-01
  -2.3522600e-01
  -2.0099760e-01
  -4.2018915e-02
   1.4060900e-01
   2.2430878e-01
   1.4698003e-01
  -4.9334401e-02
  -2.4015379e-01
  -2.9449301e-01
  -1.5978257e-01
   9.9469238e-02
   3.3553927e-01
   4.0432846e-01
   2.5275189e-01
  -4.8157255e-02
  -3.4363559e-01
  -4.8101858e-01
  -3.9093124e-01
  -1.2065446e-01
   1.9561509e-01
   4.0816957e-01
   4.2449571e-01
   2.4947873e-01
  -2.2290220e-02
  -2.5535821e-01
  -3.3965313e-01
  -2.4442241e-01
  -3.2717407e-02
   1.7386538e-01
   2.6131002e-01
   1.8344736e-01
  -1.4617105e-02
  -2.2004617e-01
  -3.0989410e-01
  -2.1648361e-01
   2.9614296e-02
   3.0600899e-01
   4.6010027e-01
   3.9585763e-01
   1.3407054e-01
  -1.9445050e-01
  -4.2254041e-01
  -4.4190341e-01
  -2.6148822e-01
   2.4561144e-03
   1.9639531e-01
   2.2058130e-01
   8.8618067e-02
  -8.2771773e-02
  -1.5145974e-01
  -4.8116921e-02
   1.7081593e-01
   3.5448643e-01
   3.5655964e-01
   1.3834184e-01
  -1.9528570e-01
  -4.5613811e-01
  -4.9089820e-01
  -2.7873232e-01
   5.5837539e-02
   3.2156811e-01
   3.7683870e-01
   2.1007687e-01
  -6.1195486e-02
  -2.6670692e-01
  -2.8529736e-01
  -1.1252984e-01
   1.4069959e-01
   3.1548805e-01
   3.0070613e-01
   1.0177110e-01
  -1.6096596e-01
  -3.2711612e-01
  -2.9842835e-01
  -9.9492033e-02
   1.4305421e-01
   2.8418081e-01
   2.4879424e-01
   7.0440776e-02
  -1.3708347e-01
  -2.5105923e-01
  -2.1001593e-01
  -4.5285982e-02
   1.4155737e-01
   2.4209754e-01
   2.0725941e-01
   7.3959838e-02
  -6.6466455e-02
  -1.3533231e-01
  -1.1722667e-01
  -5.6247689e-02
  -8.2151160e-03
   4.6646596e-03
  -5.3013327e-05
   6.4836935e-03
   3.4885521e-02
   7.2093769e-02
   9.6085499e-02
   9.0621414e-02
   5.0063443e-02
  -1.9216694e-02
  -9.5194586e-02
  -1.4177512e-01
  -1.2554939e-01
  -4.1561203e-02
   7.4612994e-02
   1.6458119e-01
   1.8370169e-01
   1.2694288e-01
   2.5574339e-02
  -7.6209464e-02
  -1.4292208e-01
  -1.5717793e-01
  -1.2150507e-01
  -5.7465582e-02
   3.0433319e-03
   3.8135050e-02
   5.3444515e-02
   7.4126764e-02
   1.1232692e-01
   1.4266966e-01
   1.1713381e-01
   1.2919877e-02
  -1.3094351e-01
  -2.2903887e-01
  -2.1083457e-01
  -7.7741149e-02
   9.2251468e-02
   1.9732652e-01
   1.8027267e-01
   6.1530912e-02
  -8.1015797e-02
  -1.6435623e-01
  -1.4922825e-01
  -5.8874212e-02
   3.9408110e-02
   7.8379546e-02
   3.6886774e-02
  -4.2241134e-02
  -8.1505612e-02
  -2.9557008e-02
   9.2798034e-02
   2.0055247e-01
   2.0414883e-01
   7.6944227e-02
  -1.2029199e-01
  -2.7519345e-01
  -2.9408814e-01
  -1.6081545e-01
   5.1070794e-02
   2.1840144e-01
   2.3874816e-01
   9.4335060e-02
  -1.2904879e-01
  -2.8774773e-01
  -2.6899028e-01
  -6.6408095e-02
   2.1071698e-01
   4.0356249e-01
   3.9994180e-01
   1.9633323e-01
  -1.0730235e-01
  -3.6601054e-01
  -4.6248715e-01
  -3.5922221e-01
  -1.1354600e-01
   1.4870456e-01
   2.9521055e-01
   2.5966678e-01
   8.3040302e-02
  -1.0914113e-01
  -1.8742442e-01
  -1.0478464e-01
   7.3317409e-02
   2.1546569e-01
   2.1382067e-01
   5.6531581e-02
  -1.6427012e-01
  -3.1183656e-01
  -2.9186150e-01
  -1.1383004e-01
   1.1231696e-01
   2.4506533e-01
   2.0292544e-01
   1.9811075e-02
  -1.7391062e-01
  -2.3677906e-01
  -1.1242105e-01
   1.2953875e-01
   3.3467916e-01
   3.5946938e-01
   1.6169418e-01
  -1.6880410e-01
  -4.5538345e-01
  -5.3000472e-01
  -3.2991559e-01
   5.7588162e-02
   4.3386984e-01
   5.9508457e-01
   4.4813661e-01
   6.8860243e-02
  -3.3635714e-01
  -5.4527976e-01
  -4.4370745e-01
  -8.9647493e-02
   3.1753702e-01
   5.4673805e-01
   4.6318145e-01
   1.0733728e-01
  -3.1949400e-01
  -5.6446899e-01
  -4.7269412e-01
  -8.8269356e-02
   3.6150197e-01
   5.9965309e-01
   4.7275161e-01
   5.2712510e-02
  -4.0097128e-01
  -6.0010920e-01
  -4.1032807e-01
   6.1089052e-02
   5.2877389e-01
   7.0388838e-01
   4.7272792e-01
  -3.2841140e-02
  -5.1806125e-01
  -7.0615746e-01
  -5.0443062e-01
  -5.3964611e-02
   3.6781621e-01
   5.2531916e-01
   3.6514315e-01
   3.1895267e-02
  -2.4276338e-01
  -2.9561167e-01
  -1.2568333e-01
   1.2380832e-01
   2.6979551e-01
   2.0920891e-01
  -2.0179145e-02
  -2.6980104e-01
  -3.7620139e-01
  -2.6519009e-01
  -1.4966321e-04
   2.5905182e-01
   3.5875119e-01
   2.4783584e-01
   5.4317821e-03
  -2.1770753e-01
  -2.9814845e-01
  -2.0810260e-01
  -1.7395596e-02
   1.5890290e-01
   2.2758901e-01
   1.6085463e-01
   3.3576307e-03
  -1.5297196e-01
  -2.1737064e-01
  -1.5023570e-01
   1.2479222e-02
   1.7606639e-01
   2.4089523e-01
   1.6216345e-01
  -2.3230254e-02
  -2.1504218e-01
  -3.0098784e-01
  -2.1779026e-01
   8.8067567e-03
   2.6812984e-01
   4.1695437e-01
   3.6159556e-01
   1.2203070e-01
  -1.7147580e-01
  -3.5437470e-01
  -3.3058973e-01
  -1.3341351e-01
   9.9954914e-02
   2.1969740e-01
   1.5589313e-01
  -4.1996520e-02
  -2.3771826e-01
  -2.9083527e-01
  -1.4002506e-01
   1.5548285e-01
   4.3862419e-01
   5.3769302e-01
   3.6811228e-01
  -6.9569482e-03
  -3.9769165e-01
  -5.8956799e-01
  -4.7193386e-01
  -1.1138894e-01
   2.8025332e-01
   4.6943948e-01
   3.4372376e-01
  -1.6555081e-02
  -3.8429530e-01
  -5.2185674e-01
  -3.2705351e-01
   1.0055685e-01
   5.1629500e-01
   6.7570174e-01
   4.8204840e-01
   4.6679399e-02
  -3.7892485e-01
  -5.5799051e-01
  -4.1189337e-01
  -6.3130989e-02
   2.4927425e-01
   3.2624429e-01
   1.3391859e-01
  -1.7899014e-01
  -3.7999275e-01
  -3.0718591e-01
   1.9919795e-02
   4.0587411e-01
   5.9872071e-01
   4.5200311e-01
   2.6827172e-02
  -4.3774484e-01
  -6.7014857e-01
  -5.3423365e-01
  -1.1312830e-01
   3.4367827e-01
   5.7281717e-01
   4.5156693e-01
   6.5481027e-02
  -3.4683106e-01
  -5.3783781e-01
  -3.9562633e-01
  -5.2304328e-03
   4.0256826e-01
   5.8408144e-01
   4.2300297e-01
  -1.8218267e-04
  -4.4833216e-01
  -6.5943295e-01
  -5.0033881e-01
  -5.1578103e-02
   4.3192551e-01
   6.6545648e-01
   5.0237264e-01
   2.6477477e-02
  -4.8897549e-01
  -7.3697545e-01
  -5.5960739e-01
  -4.7597748e-02
   5.0867228e-01
   7.8911527e-01
   6.3269313e-01
   1.3197226e-01
  -4.2464681e-01
  -7.2603682e-01
  -6.1784801e-01
  -1.8264666e-01
   3.2014735e-01
   6.1135123e-01
   5.4895999e-01
   1.9768580e-01
  -2.2062099e-01
  -4.6220719e-01
  -4.0211731e-01
  -9.9950534e-02
   2.4465654e-01
   4.1872319e-01
   3.2500596e-01
   3.2810917e-02
  -2.7440750e-01
  -4.1536442e-01
  -3.1832701e-01
  -5.5989066e-02
   2.0726049e-01
   3.1798239e-01
   2.2484797e-01
   5.1703651e-03
  -1.8889751e-01
  -2.2927380e-01
  -9.1914974e-02
   1.3314428e-01
   3.0513495e-01
   3.2224987e-01
   1.7778028e-01
  -4.7100451e-02
  -2.4007922e-01
  -3.2145867e-01
  -2.7615883e-01
  -1.4545755e-01
   4.2822900e-03
   1.1399372e-01
   1.5138712e-01
   1.1530153e-01
   3.0234280e-02
  -6.4234624e-02
  -1.2615802e-01
  -1.2407054e-01
  -4.9317670e-02
   7.5619816e-02
   2.0015044e-01
   2.6472178e-01
   2.3118708e-01
   1.0699863e-01
  -5.5412012e-02
  -1.8550876e-01
  -2.3096135e-01
  -1.8218227e-01
  -7.2615500e-02
   4.0881922e-02
   1.0372451e-01
   8.6362391e-02
  -1.1351454e-03
  -1.0889033e-01
  -1.6548976e-01
  -1.1405709e-01
   4.6560657e-02
   2.4386985e-01
   3.6111476e-01
   3.0662373e-01
   8.1468123e-02
  -2.0497551e-01
  -3.9165036e-01
  -3.6309524e-01
  -1.2535574e-01
   1.8954273e-01
   3.9793935e-01
   3.7486538e-01
   1.3124068e-01
  -1.9174474e-01
  -4.0848802e-01
  -4.0149539e-01
  -1.8960477e-01
   9.0301438e-02
   2.7507284e-01
   2.7972729e-01
   1.4341274e-01
  -1.2566755e-02
  -7.8032703e-02
  -2.7425697e-02
   7.5351759e-02
   1.3487633e-01
   9.5488652e-02
  -2.4590018e-02
  -1.5233210e-01
  -2.1189289e-01
  -1.7248897e-01
  -6.2455423e-02
   5.4933614e-02
   1.2398028e-01
   1.2778044e-01
   8.7386392e-02
   3.4966577e-02
  -1.0850501e-02
  -4.6716543e-02
  -6.9020828e-02
  -6.3681635e-02
  -1.6203206e-02
   6.7394491e-02
   1.5127737e-01
   1.8399090e-01
   1.2920707e-01
  -7.0434827e-03
  -1.7216342e-01
  -2.8937677e-01
  -2.9509198e-01
  -1.7314710e-01
   3.2745183e-02
   2.3542177e-01
   3.4097958e-01
   2.9247721e-01
   1.0411948e-01
  -1.3495077e-01
  -2.9868629e-01
  -2.9240849e-01
  -1.1517683e-01
   1.2871323e-01
   2.8803761e-01
   2.6146766e-01
   6.7234759e-02
  -1.6729947e-01
  -2.9180077e-01
  -2.3297675e-01
  -3.8493954e-02
   1.6188055e-01
   2.4607750e-01
   1.7580193e-01
   1.0770499e-02
  -1.3917580e-01
  -1.8630712e-01
  -1.1496682e-01
   1.8120146e-02
   1.2605380e-01
   1.4532251e-01
   6.9056099e-02
  -5.5814690e-02
  -1.6001831e-01
  -1.8912751e-01
  -1.2778372e-01
  -4.4698128e-03
   1.2208903e-01
   1.8963074e-01
   1.6384408e-01
   6.0799128e-02
  -5.7339158e-02
  -1.1860919e-01
  -9.0086196e-02
  -4.5798607e-03
   6.0280807e-02
   4.1676388e-02
  -5.5180320e-02
  -1.5518201e-01
  -1.6828578e-01
  -6.2049884e-02
   1.0561621e-01
   2.2337555e-01
   2.0643187e-01
   5.9839911e-02
  -1.2043322e-01
  -2.1083864e-01
  -1.4415945e-01
   4.3538937e-02
   2.3203364e-01
   2.9044234e-01
   1.6171416e-01
  -9.5674666e-02
  -3.3749265e-01
  -4.1795872e-01
  -2.7746809e-01
   2.0648626e-02
   3.2603206e-01
   4.8410918e-01
   4.1672303e-01
   1.5905611e-01
  -1.6318595e-01
  -3.9931562e-01
  -4.4568803e-01
  -2.9169291e-01
  -2.0960934e-02
   2.3175866e-01
   3.4693819e-01
   2.7877641e-01
   7.7125945e-02
  -1.4069530e-01
  -2.5367798e-01
  -2.0150506e-01
  -1.6778161e-02
   1.9116819e-01
   2.9409556e-01
   2.1593628e-01
  -1.9610708e-02
  -2.9401135e-01
  -4.5512990e-01
  -4.0311941e-01
  -1.5075705e-01
   1.7921653e-01
   4.2153577e-01
   4.6143206e-01
   2.9688389e-01
   3.5275834e-02
  -1.7206796e-01
  -2.2040717e-01
  -1.1280250e-01
   4.6014479e-02
   1.2005000e-01
   3.5297082e-02
  -1.6459920e-01
  -3.4121448e-01
  -3.5130088e-01
  -1.4787707e-01
   1.7615712e-01
   4.3972643e-01
   4.8949447e-01
   2.9899548e-01
  -1.6059656e-02
  -2.7414987e-01
  -3.4124596e-01
  -2.0476598e-01
   3.1287353e-02
   2.1535118e-01
   2.3693813e-01
   8.7039128e-02
  -1.3914592e-01
  -2.9731202e-01
  -2.8057123e-01
  -8.9244625e-02
   1.6445576e-01
   3.2621002e-01
   2.9949560e-01
   1.0678193e-01
  -1.3016725e-01
  -2.7225661e-01
  -2.4687907e-01
  -8.3173776e-02
   1.1381888e-01
   2.2819642e-01
   1.9830143e-01
   4.8505476e-02
  -1.2763594e-01
  -2.2560309e-01
  -1.9560311e-01
  -7.1212054e-02
   6.0380807e-02
   1.2445307e-01
   1.0835168e-01
   5.5609724e-02
   1.7269294e-02
   9.3997346e-03
   1.1223045e-02
  -4.3543819e-03
  -4.2668837e-02
  -8.5657964e-02
  -1.0909342e-01
  -9.7154374e-02
  -4.6781850e-02
   3.1101930e-02
   1.0973840e-01
   1.5122945e-01
   1.2531404e-01
   3.3620966e-02
  -8.3194568e-02
  -1.6716420e-01
 1998.   1999.   2000.   2001.
Program Results 
 IB03BD EXAMPLE PROGRAM RESULTS

 IWARN on exit from IB03BD =   12

 Final 2-norm of the residuals =   0.2995840D+00

 Number of iterations                     =      42
 Number of function evaluations           =     898
 Number of Jacobian evaluations           =     295

 Final approximate solution is 
   14.1294    1.1232    6.4322  -11.2418    7.6380  -33.4730  -64.7203  747.1515   -0.4623  -92.6092
    6.1682   -0.7672    0.1194    0.3558    0.9091    0.2948    1.3465    0.0093    0.0560   -0.0035
   -0.4179   -0.0455   -2.0871   -0.9196    1.0777    0.9213    0.5373    1.0412   -0.3978    7.6832
   -6.8614  -31.6119   -0.1092   -9.8984    0.1257    0.4056    0.0472    7.5819  -13.3969    2.4869
  -66.0727   -0.8411   -0.7040    1.9641    1.3059   -0.2046   -0.9326    0.0040    0.4032    0.1479

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/KINSOL.html000077500000000000000000000705621201767322700162150ustar00rootroot00000000000000 KINSOL - SLICOT Library Routine Documentation

KINSOL

Solving a nonlinear system of equations using Krylov Inexact Newton techniques

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a nonlinear system of equations F(u)=0, where F(u) is
                             n    n
  a nonlinear function from R to R , using Krylov Inexact Newton
  techniques.
Specification 
      SUBROUTINE KINSOL (GSTRAT, LINSU, NEQ, OPTIN, MAXL, MAXLRST,
     &                   MSBPRE, UU, USCALE, FSCALE, CONSTR,
     &                   IOPT, ROPT, TOL1, TOL2, INFO)
Arguments

Input/Output Parameters 

  GSTRAT  (input) INTEGER
          Indicates the global strategy to apply the computed
          increment delta in the solution UU.  Choices are:
          0 - Inexact Newton.
          1 - Linesearch.

  LINSU   SUBROUTINE
          Linear Solver Set-up Routine. This is the KINSOL routine
          to be called to set-up the linear solver. The user should
          specify here one of the 6 different Fortran-callable
          routines provided by KINSOL for this purpose. The choice
          to be used depends on which of the optional user-defined
          routines are provided by the user (see User-defined
          routines below).
          LINSU can be one of the following routines: FKINSPGMR00,
          FKINSPGMR01, FKINSPGMR10, FKINSPGMR11, FKINSPGMR20, and
          FKINSPGMR21, where the first digit in the name of the
          function is: 0 if neither KPSOL nor KPRECO routines are
          provided; 1 if only the preconditioner solve routine
          (KPSOL) is provided; and 2 if both the preconditioner
          solve (KPSOL) and setup (KPRECO) routines are provided.
          The second digit is: 0 if a function FATIMES is not
          provided; and 1 if a function FATIMES is provided.

  NEQ     (input) INTEGER
          Number of equations (and unknowns) in the algebraic
          system.

  OPTIN   (input) LOGICAL
          Flag indicating whether optional inputs from the user in
          the arrays IOPT and ROPT are to be used.
          Pass FALSE to ignore all optional inputs and TRUE to use
          all optional inputs that are present. Either choice does
          NOT affect outputs in other positions of IOPT or ROPT.

  MAXL    (input) INTEGER
          Maximum Krylov dimension for the Linear Solver. Pass 0
          to use the default value MIN(Neq, 10). 

  MAXLRST (input) INTEGER
          Maximum number of linear solver restarts allowed. Values
          outside the range 0 to 2*NEQ/MAXL will be restricted to
          that range. 0, meaning no restarts, is a safe starting
          value.

  MSBPRE  (input) INTEGER
          Maximum number of steps calling the solver KPSOL
          without calling the preconditioner KPRECO. (The default is
          10).

  UU      (input/output) DOUBLE PRECISION array, dimension (NEQ)
          On entry, UU is the initial guess.
          On exit, if no errors ocurr, UU is the solution of
          the system KFUN(UU) = 0.

  USCALE  (input) DOUBLE PRECISION array, dimension (NEQ)
          Array of diagonal elements of the scaling matrix for UU.
          The elements of USCALE must be positive values. The
          scaling matrix USCALE should be chosen so that 
          USCALE * UU (as a matrix multiplication) should have all
          its components with roughly the same magnitude when UU is
          close to a root of KFUN.

  FSCALE  (input) DOUBLE PRECISION array, dimension (NEQ)
          Array of diagonal elements of the scaling matrix for
          KFUN. The elements of FSCALE must be positive values.
          The scaling matrix FSCALE should be chosen so that
          FSCALE * KFUN(UU) (as a matrix multiplication) should
          have all its components with roughly the same magnitude
          when UU is NOT too near a root of KFUN.

  CONSTR  (input) DOUBLE PRECISION array, dimension (NEQ)
          Constraints on UU.
          A positive value in CONSTR(I) implies that the Ith
          component of UU is to be constrained > 0.
          A negative value in CONSTR(I) implies that the Ith
          component of UU is to be constrained < 0.
          A zero value in CONSTR(I) implies there is no constraint
          on UU(I). 

  IOPT    (input/output) INTEGER array, dimension (40)
          Array of optional integer inputs and outputs.
          If OPTIN is TRUE, the user should preset to 0 those
          locations for which default values are to be used.
          See Optional Inputs and Outputs, below. 

  ROPT    (input/output) DOUBLE PRECISION array, dimension (40)
          Array of optional double precision inputs and outputs.
          If OPTIN is TRUE, the user should preset to 0 those
          locations for which default values are to be used.
          See Optional Inputs and Outputs, below.
Tolerances 
  TOL1    DOUBLE PRECISION
          Stopping tolerance on maxnorm( FSCALE * KFUN(UU) ).
          If TOL1 is input as 0., then a default value of
          (uround) to the 1/3 power will be used. uround is the
          unit roundoff for the machine in use for the calculation.

  TOL2    DOUBLE PRECISION
          Stopping tolerance on the maximum scaled step 
          UU(K) - UU(K-1). 
          If TOL2 is input as 0., then a default value of (uround)
          to the 2/3 power will be used. uround is the unit 
          roundoff for the machine in use for the calculation.
Error Indicator 
  INFO    (output) INTEGER
          See Termination Codes below.

  ---------------------------------------------------------------

  Termination Codes

  (Note: in this documentation we use named constants for 
  certain integer constant values. To see the values of these
  symbols see Named constants below.)

  The termination values KINS_***** are now given. These are the
  values of the INFO argument.

  SUCCESS :    means maxnorm(FSCALE*KFUN(UU) <= TOL1, where
               maxnorm() is the maximum norm function N_VMaxNorm.
               Therefore, UU is probably an approximate root of
               KFUN.

  INITIAL_GUESS_OK: means the initial guess UU has been found
               to already satisfy the system to the desired
               accuracy. No calculation was performed other
               than testing UU.

  STEP_LT_STPTOL:  means the scaled distance between the last
               two steps is less than TOL2.  UU may be an
               approximate root of KFUN, but it is also possible
               that the algorithm is making very slow progress
               and is not near a root or that TOL2 is too
               large

  LNSRCH_NONCONV: means the LineSearch module failed to reduce
               norm(KFUN) sufficiently on the last global step.
               Either UU is close to a root of F and no more
               accuracy is possible, or the finite-difference
               approximation to J*v is inaccurate, or TOL2
               is too large. Check the outputs NCFL and NNI: if
               NCFL is close to NNI, it may be the case that the
               Krylov iteration is converging very slowly. In
               this case, the user may want to use precondition-
               ing and/or increase the MAXL argument (that is,
               increase the max dimension of the Krylov subspace)
               by setting MAXL to nonzero (thus not using the
               default value of KINSPGMR_MAXL) or if MAXL is being
               set, increase its value.

  MAXITER_REACHED: means that the maximum allowable number of
               nonlinear iterations has been reached. This is by
               default 200, but may be changed through optional
               input IOPT(MXITER).

  MXNEWT_5X_EXCEEDED: means 5 consecutive steps of length mxnewt
               (maximum Newton stepsize limit) have been taken.
               Either norm(F) asymptotes from above to a finite
               value in some direction, or mxnewt is too small.
               Mxnewt is computed internally (by default) as
               mxnewt = 1000*max(norm(USCALE*UU0),1), where
               UU0 is the initial guess for UU, and norm() is
               the Euclidean norm. Mxnewt can be  set by the
               user through optional input ROPT(MXNEWTSTEP).

  LINESEARCH_BCFAIL: means that more than the allowed maximum
               number of failures (MXNBCF) occurred when trying
               to satisfy the beta condition in the linesearch
               algorithm. It is likely that the iteration is
               making poor progress.

  KRYLOV_FAILURE: means there was a failure of the Krylov
               iteration process to converge.

  PRECONDSET_FAILURE: means there was a nonrecoverable
               error in PrecondSet causing the iteration to halt.

  PRECONDSOLVE_FAILURE: means there was a nonrecoverable
            error in PrecondSolve causing the iteration to halt.

  NO_MEM:    the KINSol memory pointer received was NULL.

  INPUT_ERROR: one or more input parameters or arrays was in
               error. See the program output for further info.

  LSOLV_NO_MEM: The linear solver memory pointer (lmem) was
             received as NULL. The return value from the linear
             solver needs to be checked and the cause found.

  ---------------------------------------------------------------
Optional inputs and outputs 
  (Note: in this documentation we use named constants for 
  certain integer constant values. To see the values of these
  symbols see Named constants below.)

  The user should declare two arrays for optional input and
  output, an IOPT array for optional integer input and output
  and an ROPT array for optional real input and output. These
  arrays should both be of size OPT_SIZE.
  So the user's declaration should look like:

  INTEGER          IOPT(OPT_SIZE)
  DOUBLE PRECISION ROPT(OPT_SIZE)

  The following definitions are indices into the IOPT and ROPT
  arrays. A brief description of the contents of these positions
  follows.

  IOPT(PRINTFL)  (input)  Allows user to select from 4 levels
                 of output.
                 =0 no statistics printed   (DEFAULT)
                 =1 output the nonlinear iteration count, the
                    scaled norm of KFUN(UU), and number of
                    KFUN calls.
                 =2 same as 1 with the addition of global
                    strategy statistics:
                    f1 = 0.5*norm(FSCALE*KFUN(UU))**2   and
                    f1new = 0.5*norm(FSCALE*KFUN(unew))**2 .
                 =3 same as 2 with the addition of further
                    Krylov iteration statistics.

  IOPT(MXITER)   (input) Maximum allowable number of nonlinear
                  iterations. The default is MXITER_DEFAULT.

  IOPT(PRECOND_NO_INIT) (input) Set to 1 to prevent the initial
                   call to the routine KPRECO upon a given
                   call to KINSol. Set to 0 or leave unset to
                   force the initial call to KPRECO.
                   Use the choice of 1 only after beginning the
                   first of a series of calls with a 0 value.
                   If a value other than 0 or 1 is encountered,
                   the default, 0, is set in this element of
                   IOPT and thus the routine KPRECO will
                   be called upon every call to KINSol, unless
                   IOPT(PRECOND_NO_INIT) is changed by the user.

  IOPT(ETACHOICE) (input) A flag indicating which of three
                   methods to use for computing eta, the
                   coefficient in the linear solver
                   convergence tolerance eps, given by
                     eps = (eta+u_round)*norm(KFUN(UU)).
                   Here, all norms are  the scaled L2 norm.
                   The linear solver attempts to produce a step
                   p such that norm(KFUN(UU)+J(UU)*p) <= eps.
                   Two of the methods for computing eta
                   calculate a value based on the convergence
                   process in the routine KINForcingTerm.
                   The third method does not require
                   calculation; a constant eta is selected.

                   The default if IOPT(ETACHOICE) is  not
                   specified is ETACHOICE1, (see below).

                   The allowed values (methods)  are:
              ETACONSTANT  constant eta, default of 0.1 or user
                 supplied choice, for which see ROPT(ETACONST),

              ETACHOICE1 (default) which uses choice 1 of
                 Eisenstat and Walker's paper of SIAM J. Sci.
                 Comput.,17 (1996), pp 16-32 wherein eta is:
                         eta(k) =
  ABS( norm(KFUN(UU(k))) - norm(KFUN(UU(k-1))+J(UU(k-1))*p) )
                      / norm(KFUN(UU(k-1))),

              ETACHOICE2   which uses choice 2 of
                 Eisenstat and Walker wherein eta is:
                 eta(k) = egamma *
             ( norm(KFUN(UU(k))) / norm(KFUN(u(k-1))) )^ealpha

                 egamma and ealpha for choice 2, both required,
                 are from either defaults (egamma = 0.9 ,
                 ealpha = 2)  or from  user input,
                 see ROPT(ETAALPHA) and ROPT(ETAGAMMA), below.

                 For eta(k) determined by either Choice 1 or
                 Choice 2, a value eta_safe is determined, and
                 the safeguard   eta(k) <- max(eta_safe,eta(k))
                 is applied to prevent eta(k) from becoming too
                 small too quickly.
                  For Choice 1,
                    eta_safe = eta(k-1)^((1.+sqrt(5.))/2.)
           and    for Choice 2,
                    eta_safe = egamma*eta(k-1)^ealpha.
                 (These safeguards are turned off if they drop
                 below 0.1 . Also, eta is never allowed to be
                 less than eta_min = 1.e-4).

  IOPT(NO_MIN_EPS) (input) Set to 1 or greater to remove
                 protection agains eps becoming too small.
                 This option is useful for debugging linear
                 and nonlinear solver interactions. Set to 0
                 for standard eps minimum value testing.

  IOPT(NNI)      (output) Total number of nonlinear iterations.

  IOPT(NFE)      (output) Total number of calls to the user-
                  supplied system function KFUN.

  IOPT(NBCF)     (output) Total number of times the beta
                  condition could not be met in the linesearch
                  algorithm. The nonlinear iteration is halted
                  if this value ever exceeds MXNBCF (10).

  IOPT(NBKTRK)   (output) Total number of backtracks in the
                  linesearch algorithm.

  IOPT(SPGMR_NLI) (output) Number of linear iterations.

  IOPT(SPGMR_NPE) (output) Number of preconditioner evaluations.

  IOPT(SPGMR_NPS) (output) Number of calls made to user's psolve
                  function.

  IOPT(SPGMR_NCFL) (output) Number of linear convergence failures.

  ROPT(MXNEWTSTEP) (input) Maximum allowable length of a Newton
                  step. The default value is calculated from
                  1000*max(norm(USCALE*UU(0),norm(USCALE)).

  ROPT(RELFUNC)  (input) Relative error in computing KFUN(UU)
                  if known. Default is the machine epsilon.

  ROPT(RELU)     (input) A scalar constraint which restricts
                  the update of UU to  del(UU)/UU < ROPT(RELU)
                  The default is no constraint on the relative
                  step in UU.

  ROPT(ETAGAMMA) (input) The coefficient egamma in the eta
                  computation. See routine KINForcingTerm
           (SEE IOPT(ETACHOICE) above for additional info).

  ROPT(ETAALPHA) (input) The coefficient ealpha in the eta
                  computation. See routine KINForcingTerm
           (SEE IOPT(ETACHOICE) above for additional info).

  ROPT(ETACONST) (input) A user specified constant value for
                   eta, used in lieu of that computed by
                       routine KINForcingTerm
           (SEE IOPT(ETACHOICE) above for additional info).

  ROPT(FNORM)    (output) The scaled norm at a given iteration:
                  norm(FSCALE(KFUN(UU)).

  ROPT(STEPL)    (output) Last step length in the global
                  strategy routine:
                  KINLineSearch or KINInexactNewton.

  ---------------------------------------------------------------
User-defined routines 
  In order to use this routine, some user-defined routines have to
  be provided. One of them is required, while the others are
  optional. These routines are described next.

  KFUN    Required

          SUBROUTINE KFUN (NEQ, UU, FVAL)
          INTEGER           NEQ
          DOUBLE PRECISION  UU(NEQ), FVAL(NEQ)

          PURPOSE

          Evaluates the KFUN function which defines the system
          to be solved:
                            KFUN(UU)=0

          ARGUMENTS

          NEQ
          (input) INTEGER
          Number of equations (and unknowns) in the algebraic
          system

          UU
          (input) DOUBLE PRECISION array, dimension (NEQ)
          independent variable vector

          FVAL
          (output) DOUBLE PRECISION array, dimension (NEQ)
          Result of KFUN(UU)

  KPRECO  Optional

          SUBROUTINE KPRECO (NEQ, UU, USCALE, FVAL, FSCALE,
                             VTEMP1, VTEMP2, UROUND, NFE, IER)
          INTEGER           NEQ, NFE, IER
          DOUBLE PRECISION  UROUND
          DOUBLE PRECISION  UU(NEQ), USCALE(NEQ), FVAL(NEQ),
                            FSCALE(NEQ), VTEMP1(NEQ), VTEMP2(NEQ)

          PURPOSE

          The user-supplied preconditioner setup function KPRECO and
          the user-supplied preconditioner solve function KPSOL
          together must define the right preconditoner matrix P
          chosen so as to provide an easier system for the Krylov
          solver to solve. KPRECO is called to provide any matrix
          data required by the subsequent call(s) to KPSOL. The
          data is expected to be stored in variables within a
          COMMON block and the definition of those variables is up
          to the user. More specifically, the user-supplied
          preconditioner setup function KPRECO is to evaluate and
          preprocess any Jacobian-related data needed by the
          preconditioner solve function KPSOL. This might include
          forming a crude approximate Jacobian, and performing an
          LU factorization on the resulting approximation to J.
          This function will not be called in advance of every call
          to KPSOL, but instead will be called only as often as
          necessary to achieve convergence within the Newton
          iteration in KINSol.  If the KPSOL function needs no
          preparation, the KPRECO function need not be provided.

          KPRECO should not modify the contents of the arrays
          UU or FVAL as those arrays are used elsewhere in the
          iteration process.

          Each call to the KPRECO function is preceded by a call to
          the system function KFUN. Thus the KPRECO function can use
          any auxiliary data that is computed by the KFUN function
          and saved in a way accessible to KPRECO.

          The two scaling arrays, FSCALE and USCALE, and unit
          roundoff UROUND are provided to the KPRECO function for
          possible use in approximating Jacobian data, e.g. by
          difference quotients. These arrays should also not be
          altered

          ARGUMENTS

          NEQ
          (input) INTEGER
          Number of equations (and unknowns) in the algebraic
          system.

          UU
          (input) DOUBLE PRECISION array, dimension (NEQ)
          Independent variable vector.

          USCALE
          (input) DOUBLE PRECISION array, dimension (NEQ)
          See USCALE above.

          FVAL
          (input) DOUBLE PRECISION array, dimension (NEQ)
          Current value of KFUN(UU).

          FSCALE
          (input) DOUBLE PRECISION array, dimension (NEQ)
          See FSCALE above.

          VTEMP1
          DOUBLE PRECISION array, dimension (NEQ)
          Temporary work array.

          VTEMP2
          DOUBLE PRECISION array, dimension (NEQ)
          Temporary work array.

          UROUND
          (input) DOUBLE PRECISION
          Machine unit roundoff.

          NFE
          (input/output) INTEGER
          Number of calls to KFUN made by the package. The KPRECO
          routine should update this counter by adding on the
          number of KFUN calls made in order to approximate the
          Jacobian, if any.  For example, if the routine calls
          KFUN a total of W times, then the update is 
          NFE = NFE + W.

          IER
          (output) INTEGER
          Error indicator. 
          0 if successful,
          1 if failure, in which case KINSOL stops.

  KPSOL   Optional

          SUBROUTINE KPSOL (NEQ, UU, USCALE, FVAL, FSCALE, VTEM,
                            FTEM, UROUND, NFE, IER)
          INTEGER           NEQ, NFE, IER
          DOUBLE PRECISION  UU(NEQ), USCALE(NEQ), FVAL(NEQ),
                            FSCALE(NEQ), VTEM(NEQ), FTEM(NEQ)

          PURPOSE

          The user-supplied preconditioner solve function KPSOL
          is to solve a linear system P x = r in which the matrix
          P is the (right) preconditioner matrix P.

          KPSOL should not modify the contents of the iterate
          array UU  or the current function value array  FVAL as
          those are used elsewhere in the iteration process.

          ARGUMENTS

          NEQ
          (input) INTEGER
          Number of equations (and unknowns) in the algebraic
          system.

          UU
          (input) DOUBLE PRECISION array, dimension (NEQ)
          Independent variable vector.

          USCALE
          (input) DOUBLE PRECISION array, dimension (NEQ)
          See USCALE above.

          FVAL
          (input) DOUBLE PRECISION array, dimension (NEQ)
          Current value of KFUN(UU).

          FSCALE
          (input) DOUBLE PRECISION array, dimension (NEQ)
          See FSCALE above.

          VTEM
          (input/output) DOUBLE PRECISION array, dimension (NEQ)
          On entry, holds the RHS vector r.
          On exit, holds the result x.

          FTEM
          DOUBLE PRECISION array, dimension (NEQ)
          Temporary work array.

          UROUND
          (input) DOUBLE PRECISION
          Machine unit roundoff.

          NFE
          (input/output) INTEGER
          Number of calls to KFUN made by the package. The KPRECO
          routine should update this counter by adding on the
          number of KFUN calls made in order to carry out the
          solution, if any.  For example, if the routine calls
          KFUN a total of W times, then the update is 
          NFE = NFE + W.

          IER
          (output) INTEGER
          Error indicator. 
          0 if successful,
          1 if failure, in which case KINSOL stops.

  FATIMES Optional

          SUBROUTINE FATIMES(V, Z, NEWU, UU, IER)
          INTEGER           NEWU, IER
          DOUBLE PRECISION  V(:), Z(:), UU(:)

          PURPOSE

          The user-supplied A times V routine (optional) where
          A is the Jacobian matrix dF/du, or an approximation to
          it, and V is a given  vector.  This routine computes the
          product Z = J V.

          ARGUMENTS

          V
          (input) DOUBLE PRECISION array, dimension (NEQ)
          Vector to be multiplied by J
          (preconditioned and unscaled as received).

          Z
          (output) DOUBLE PRECISION array, dimension (NEQ)
          Vector resulting from the application of J to V.

          NEW_UU
          (input) INTEGER
          Flag indicating whether or not the UU vector has been
          changed since the last call to this function (0 means
          FALSE, 1 TRUE).
          If this function computes and saves Jacobian data, then
          this computation can be skipped if NEW_UU = FALSE.

          UU
          (input) DOUBLE PRECISION array, dimension (NEQ)
          Current iterate u.

          IER
          (output) INTEGER
          Error indicator. 
          0 if successful,
          1 if failure, in which case KINSOL stops.

  ---------------------------------------------------------------
Named constants 
  Here we specify the value of the named integer constants used
  in this documentation. We use Fortran code for the specification,
  so that the user can copy and paste these lines in order to
  use the named constants in his/her programs.

   KINSOL return values
   Note that the value of these constants differ from those of
   the KINSOL package. This is due to the adaptation to the 
   SLICOT standards.
   INTEGER KINS_NO_MEM, KINS_INPUT_ERROR, KINS_LSOLV_NO_MEM, 
  &        KINS_SUCCESS, KINS_INITIAL_GUESS_OK,KINS_STEP_LT_STPTOL,
  &        KINS_LNSRCH_NONCONV, KINS_MAXITER_REACHED, 
  &        KINS_MXNEWT_5X_EXCEEDED, KINS_LINESEARCH_BCFAIL,
  &        KINS_KRYLOV_FAILURE, KINS_PRECONDSET_FAILURE, 
  &        KINS_PRECONDSOLVE_FAILURE}

   PARAMETER(KINS_NO_MEM=101)
   PARAMETER(KINS_INPUT_ERROR=102)
   PARAMETER(KINS_LSOLV_NO_MEM=103)
   PARAMETER(KINS_SUCCESS=0)
   PARAMETER(KINS_INITIAL_GUESS_OK=2)
   PARAMETER(KINS_STEP_LT_STPTOL=3)
   PARAMETER(KINS_LNSRCH_NONCONV=4)
   PARAMETER(KINS_MAXITER_REACHED=5)
   PARAMETER(KINS_MXNEWT_5X_EXCEEDED=6)
   PARAMETER(KINS_LINESEARCH_BCFAIL=7)
   PARAMETER(KINS_KRYLOV_FAILURE = 8)
   PARAMETER(KINS_PRECONDSET_FAILURE=9)
   PARAMETER(KINS_PRECONDSOLVE_FAILURE=10)

   Size of IOPT, ROPT
   INTEGER OPT_SIZE
   PARAMETER(OPT_SIZE=40)

   IOPT indices
   INTEGER PRINTFL, MXITER, PRECOND_NO_INIT, NNI ,NFE ,NBCF, NBKTRK,
  &        ETACHOICE, NO_MIN_EPS
   INTEGER SPGMR_NLI, SPGMR_NPE, SPGMR_NPS, SPGMR_NCFL

   PARAMETER(PRINTFL=1)
   PARAMETER(MXITER=2)
   PARAMETER(PRECOND_NO_INIT=3)
   PARAMETER(NNI=4)
   PARAMETER(NFE=5)
   PARAMETER(NBCF=6)
   PARAMETER(NBKTRK=7)
   PARAMETER(ETACHOICE=8)
   PARAMETER(NO_MIN_EPS=9)
   PARAMETER(SPGMR_NLI=11)
   PARAMETER(SPGMR_NPE=12)
   PARAMETER(SPGMR_NPS=13)
   PARAMETER(SPGMR_NCFL=14)

   ROPT indices
   INTEGER MXNEWTSTEP , RELFUNC , RELU , FNORM , STEPL,
  &        ETACONST, ETAGAMMA, ETAALPHA

   PARAMETER(MXNEWTSTEP=1)
   PARAMETER(RELFUNC=2)
   PARAMETER(RELU=3)
   PARAMETER(FNORM=4)
   PARAMETER(STEPL=5)
   PARAMETER(ETACONST=6)
   PARAMETER(ETAGAMMA=7)
   PARAMETER(ETAALPHA=8)

   Values for IOPT(ETACHOICE)
   INTEGER ETACHOICE1, ETACHOICE2, ETACONSTANT

   PARAMETER(ETACHOICE1=0)
   PARAMETER(ETACHOICE2=1)
   PARAMETER(ETACONSTANT=2)
   
  ---------------------------------------------------------------
Method 
  KINSOL (Krylov Inexact Newton SOLver) is a general purpose
  solver for nonlinear systems of equations. Its most notable
  feature is that it uses Krylov Inexact Newton techniques in the
  system's approximate solution. 
  The Newton method used results in the solution of linear systems
  of the form
                          J(u)*x = b
  where J(u) is the Jacobian of F at u. The solution of these
  systems by a Krylov method requires products of the form J(u)*v,
  which are approximated by a difference quotient of the form
                       F(u+sigma*v)-F(u)
                       -----------------
                            sigma
  Thus, the Jacobian need not be formed explicitly.
References 
  [1] Allan G. Taylor and Alan C. Hindmarsh, "User Documentation
      for KINSOL, a Nonlinear Solver for Sequential and Parallel
      Computers", Center for Applied Scientific Computing, L-561,
      LLNL, Livermore, CA 94551.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine and related files.

Return to index slicot-5.0+20101122/doc/MA01AD.html000077500000000000000000000040331201767322700160470ustar00rootroot00000000000000 MA01AD - SLICOT Library Routine Documentation

MA01AD

Complex square root of a complex number in real arithmetic

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the complex square root YR + i*YI of a complex number
  XR + i*XI  in real arithmetic.  The returned result is so that
  YR >= 0.0  and  SIGN(YI) = SIGN(XI).
Specification 
      SUBROUTINE MA01AD( XR, XI, YR, YI )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XR, XI, YR, YI
Arguments

Input/Output Parameters 

  XR      (input) DOUBLE PRECISION
  XI      (input) DOUBLE PRECISION
          These scalars define the real and imaginary part of the
          complex number of which the square root is sought.

  YR      (output) DOUBLE PRECISION
  YI      (output) DOUBLE PRECISION
          These scalars define the real and imaginary part of the
          complex square root.
Method 
  The complex square root YR + i*YI of the complex number XR + i*XI
  is computed in real arithmetic, taking care to avoid overflow.
References 
  Adapted from EISPACK subroutine CSROOT.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA01BD.html000077500000000000000000000044161201767322700160550ustar00rootroot00000000000000 MA01BD - SLICOT Library Routine Documentation

MA01BD

Safely computing the general product of K real scalars

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the general product of K real scalars without over-
  or underflow.
Specification 
      SUBROUTINE MA01BD( BASE, LGBAS, K, S, A, INCA, ALPHA, BETA, SCAL )
C     .. Scalar Arguments ..
      INTEGER           INCA, K, SCAL
      DOUBLE PRECISION  ALPHA, BASE, BETA, LGBAS
C     .. Array Arguments ..
      INTEGER           S(*)
      DOUBLE PRECISION  A(*)
Arguments

Input/Output Parameters 

  BASE    (input)  DOUBLE PRECISION
          Machine base.

  LGBAS   (input)  DOUBLE PRECISION
          Logarithm of BASE.

  K       (input)  INTEGER
          The number of scalars.  K >= 1.

  S       (input)  INTEGER array, dimension (K)
          The signature array. Each entry of S must be 1 or -1.

  A       (input)  DOUBLE PRECISION array, dimension (K)
          Vector of real scalars.

  INCA    (input)  INTEGER
          Increment for the array A. INCA <> 0.

  ALPHA   (output)  DOUBLE PRECISION
          ALPHA is a real scalar such that

             ALPHA / BETA * BASE**(SCAL)

          is the general product of the scalars in the array A.

  BETA    (output)  DOUBLE PRECISION
          BETA is either 0.0 or 1.0.
          See also the description of ALPHA.

  SCAL    (output)  INTEGER
          Scaling factor exponent, see ALPHA.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA01CD.html000077500000000000000000000044441201767322700160570ustar00rootroot00000000000000 MA01CD - SLICOT Library Routine Documentation

MA01CD

Safely computing the sign of a sum of two real numbers represented using integer powers of a base

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, without over- or underflow, the sign of the sum of two
  real numbers represented using integer powers of a base (usually,
  the machine base). Any base can be used, but it should the same
  for both numbers. The result is an integer with value 1, 0, or -1,
  depending on the sum being found as positive, zero, or negative,
  respectively.
Specification 
      INTEGER FUNCTION MA01CD( A, IA, B, IB )
C     .. Scalar Arguments ..
      INTEGER           IA, IB
      DOUBLE PRECISION  A, B
Function Value 
  MA01CD  INTEGER
          The sign of the sum of the two numbers, which is usually
          either 1, or -1. If both numbers are 0, or if they have
          the same exponent and their sum is 0, the returned value
          is 0.
Arguments

Input/Output Parameters 

  A       (input)  DOUBLE PRECISION
          The first real scalar.

  IA      (input)  INTEGER
          Exponent of the base for the first real scalar. The scalar
          is represented as A * BASE**(IA).

  B       (input)  DOUBLE PRECISION
          The first real scalar.

  IB      (input)  INTEGER
          Exponent of the base for the first real scalar. The scalar
          is represented as B * BASE**(IB).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02AD.html000077500000000000000000000044171201767322700160560ustar00rootroot00000000000000 MA02AD - SLICOT Library Routine Documentation

MA02AD

Matrix transposition

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To transpose all or part of a two-dimensional matrix A into
  another matrix B.
Specification 
      SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            LDA, LDB, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), B(LDB,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the part of the matrix A to be transposed into B
          as follows:
          = 'U': Upper triangular part;
          = 'L': Lower triangular part;
          Otherwise:  All of the matrix A.
Input/Output Parameters 
  M      (input) INTEGER
         The number of rows of the matrix A.  M >= 0.

  N      (input) INTEGER
         The number of columns of the matrix A.  N >= 0.

  A      (input) DOUBLE PRECISION array, dimension (LDA,N)
         The m-by-n matrix A.  If JOB = 'U', only the upper
         triangle or trapezoid is accessed; if JOB = 'L', only the
         lower triangle or trapezoid is accessed.

  LDA    INTEGER
         The leading dimension of the array A.  LDA >= max(1,M).

  B      (output) DOUBLE PRECISION array, dimension (LDB,M)
         B = A' in the locations specified by JOB.

  LDB    INTEGER
         The leading dimension of the array B.  LDB >= max(1,N).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02BD.html000077500000000000000000000052001201767322700160460ustar00rootroot00000000000000 MA02BD - SLICOT Library Routine Documentation

MA02BD

Reversing the order of rows and/or columns of a matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reverse the order of rows and/or columns of a given matrix A
  by pre-multiplying and/or post-multiplying it, respectively, with
  a permutation matrix P, where P is a square matrix of appropriate
  order, with ones down the secondary diagonal.
Specification 
      SUBROUTINE MA02BD( SIDE, M, N, A, LDA )
C     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            LDA, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies the operation to be performed, as follows:
          = 'L': the order of rows of A is to be reversed by
                 pre-multiplying A with P;
          = 'R': the order of columns of A is to be reversed by
                 post-multiplying A with P;
          = 'B': both the order of rows and the order of columns
                 of A is to be reversed by pre-multiplying and
                 post-multiplying A with P.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the given matrix whose rows and/or columns are to
          be permuted.
          On exit, the leading M-by-N part of this array contains
          the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or
          P*A*P if SIDE = 'B'.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02BZ.html000077500000000000000000000052111201767322700160760ustar00rootroot00000000000000 MA02BZ - SLICOT Library Routine Documentation

MA02BZ

Reversing the order of rows and/or columns of a matrix (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reverse the order of rows and/or columns of a given matrix A
  by pre-multiplying and/or post-multiplying it, respectively, with
  a permutation matrix P, where P is a square matrix of appropriate
  order, with ones down the secondary diagonal.
Specification 
      SUBROUTINE MA02BZ( SIDE, M, N, A, LDA )
C     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            LDA, M, N
C     .. Array Arguments ..
      COMPLEX*16         A(LDA,*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies the operation to be performed, as follows:
          = 'L': the order of rows of A is to be reversed by
                 pre-multiplying A with P;
          = 'R': the order of columns of A is to be reversed by
                 post-multiplying A with P;
          = 'B': both the order of rows and the order of columns
                 of A is to be reversed by pre-multiplying and
                 post-multiplying A with P.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the given matrix whose rows and/or columns are to
          be permuted.
          On exit, the leading M-by-N part of this array contains
          the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or
          P*A*P if SIDE = 'B'.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02CD.html000077500000000000000000000047461201767322700160650ustar00rootroot00000000000000 MA02CD - SLICOT Library Routine Documentation

MA02CD

Pertransposing the central band of a square matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the pertranspose of a central band of a square matrix.
Specification 
      SUBROUTINE MA02CD( N, KL, KU, A, LDA )
C     .. Scalar Arguments ..
      INTEGER          KL, KU, LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the square matrix A.  N >= 0.

  KL      (input) INTEGER
          The number of subdiagonals of A to be pertransposed.
          0 <= KL <= N-1.

  KU      (input) INTEGER
          The number of superdiagonals of A to be pertransposed.
          0 <= KU <= N-1.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain a square matrix whose central band formed from
          the KL subdiagonals, the main diagonal and the KU
          superdiagonals will be pertransposed.
          On exit, the leading N-by-N part of this array contains
          the matrix A with its central band (the KL subdiagonals,
          the main diagonal and the KU superdiagonals) pertransposed
          (that is the elements of each antidiagonal appear in
          reversed order). This is equivalent to forming P*B'*P,
          where B is the matrix formed from the central band of A
          and P is a permutation matrix with ones down the secondary
          diagonal.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02CZ.html000077500000000000000000000047571201767322700161150ustar00rootroot00000000000000 MA02CZ - SLICOT Library Routine Documentation

MA02CZ

Pertransposing the central band of a square matrix (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the pertranspose of a central band of a square matrix.
Specification 
      SUBROUTINE MA02CZ( N, KL, KU, A, LDA )
C     .. Scalar Arguments ..
      INTEGER          KL, KU, LDA, N
C     .. Array Arguments ..
      COMPLEX*16       A(LDA,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the square matrix A.  N >= 0.

  KL      (input) INTEGER
          The number of subdiagonals of A to be pertransposed.
          0 <= KL <= N-1.

  KU      (input) INTEGER
          The number of superdiagonals of A to be pertransposed.
          0 <= KU <= N-1.

  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain a square matrix whose central band formed from
          the KL subdiagonals, the main diagonal and the KU
          superdiagonals will be pertransposed.
          On exit, the leading N-by-N part of this array contains
          the matrix A with its central band (the KL subdiagonals,
          the main diagonal and the KU superdiagonals) pertransposed
          (that is the elements of each antidiagonal appear in
          reversed order). This is equivalent to forming P*B'*P,
          where B is the matrix formed from the central band of A
          and P is a permutation matrix with ones down the secondary
          diagonal.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02DD.html000077500000000000000000000072401201767322700160560ustar00rootroot00000000000000 MA02DD - SLICOT Library Routine Documentation

MA02DD

Pack/unpack the upper or lower triangle of a symmetric matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To pack/unpack the upper or lower triangle of a symmetric matrix.
  The packed matrix is stored column-wise in the one-dimensional
  array AP.
Specification 
      SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP )
C     .. Scalar Arguments ..
      CHARACTER          JOB, UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), AP(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies whether the matrix should be packed or unpacked,
          as follows:
          = 'P':  The matrix should be packed;
          = 'U':  The matrix should be unpacked.

  UPLO    CHARACTER*1
          Specifies the part of the matrix to be packed/unpacked,
          as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input or output) DOUBLE PRECISION array, dimension
          (LDA,N)
          This array is an input parameter if JOB = 'P', and an
          output parameter if JOB = 'U'.
          On entry, if JOB = 'P', the leading N-by-N upper
          triangular part (if UPLO = 'U'), or lower triangular part
          (if UPLO = 'L'), of this array must contain the
          corresponding upper or lower triangle of the symmetric
          matrix A, and the other strictly triangular part is not
          referenced.
          On exit, if JOB = 'U', the leading N-by-N upper triangular
          part (if UPLO = 'U'), or lower triangular part (if
          UPLO = 'L'), of this array contains the corresponding
          upper or lower triangle of the symmetric matrix A; the
          other strictly triangular part is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  AP      (output or input) DOUBLE PRECISION array, dimension
          (N*(N+1)/2)
          This array is an output parameter if JOB = 'P', and an
          input parameter if JOB = 'U'.
          On entry, if JOB = 'U', the leading N*(N+1)/2 elements of
          this array must contain the upper (if UPLO = 'U') or lower
          (if UPLO = 'L') triangle of the symmetric matrix A, packed
          column-wise. That is, the elements are stored in the order
          11, 12, 22, ..., 1n, 2n, 3n, ..., nn,      if UPLO = 'U';
          11, 21, 31, ..., n1, 22, 32, ..., n2, ..., if UPLO = 'L'.
          On exit, if JOB = 'P', the leading N*(N+1)/2 elements of
          this array contain the upper (if UPLO = 'U') or lower
          (if UPLO = 'L') triangle of the symmetric matrix A, packed
          column-wise, as described above.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02ED.html000077500000000000000000000043671201767322700160660ustar00rootroot00000000000000 MA02ED - SLICOT Library Routine Documentation

MA02ED

Store by symmetry the upper or lower triangle of a symmetric matrix, given the other triangle

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To store by symmetry the upper or lower triangle of a symmetric
  matrix, given the other triangle.
Specification 
      SUBROUTINE MA02ED( UPLO, N, A, LDA )
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies which part of the matrix is given as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.
          For all other values, the array A is not referenced.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N upper triangular part
          (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'),
          of this array must contain the corresponding upper or
          lower triangle of the symmetric matrix A.
          On exit, the leading N-by-N part of this array contains
          the symmetric matrix A with all elements stored.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02FD.html000077500000000000000000000041651201767322700160630ustar00rootroot00000000000000 MA02FD - SLICOT Library Routine Documentation

MA02FD

Hyperbolic plane rotation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the coefficients c and s (c^2 + s^2 = 1) for a modified
  hyperbolic plane rotation, such that,

      y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2),
      y2 :=  -s * y1 +  c  * x2 = 0,

  given two real numbers x1 and x2, satisfying either x1 = x2 = 0,
  or abs(x2) < abs(x1).
Specification 
      SUBROUTINE MA02FD( X1, X2, C, S, INFO )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X1, X2, C, S
      INTEGER           INFO
Arguments

Input/Output Parameters 

  X1      (input/output) DOUBLE PRECISION
          On entry, the real number x1.
          On exit, the real number y1.

  X2      (input) DOUBLE PRECISION
          The real number x2.
          The values x1 and x2 should satisfy either x1 = x2 = 0, or
          abs(x2) < abs(x1).

  C       (output) DOUBLE PRECISION
          The cosines c of the modified hyperbolic plane rotation.

  S       (output) DOUBLE PRECISION
          The sines s of the modified hyperbolic plane rotation.
Error Indicator 
  INFO    INTEGER
          = 0:  succesful exit;
          = 1:  if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02GD.html000077500000000000000000000066741201767322700160730ustar00rootroot00000000000000 MA02GD - SLICOT Library Routine Documentation

MA02GD

Column interchanges in a matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform a series of column interchanges on the matrix A.
  One column interchange is initiated for each of columns K1 through
  K2 of A. This is useful for solving linear systems X*A = B, when
  the matrix A has already been factored by LAPACK Library routine
  DGETRF.
Specification 
      SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX )
C     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of rows of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,*)
          On entry, the leading N-by-M part of this array must
          contain the matrix A to which the column interchanges will
          be applied, where M is the largest element of IPIV(K), for
          K = K1, ..., K2.
          On exit, the leading N-by-M part of this array contains
          the permuted matrix.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  K1      (input) INTEGER
          The first element of IPIV for which a column interchange
          will be done.

  K2      (input) INTEGER
          The last element of IPIV for which a column interchange
          will be done.

  IPIV    (input) INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
          The vector of interchanging (pivot) indices.  Only the
          elements in positions K1 through K2 of IPIV are accessed.
          IPIV(K) = L implies columns K and L are to be
          interchanged.

  INCX    (input) INTEGER
          The increment between successive values of IPIV.
          If INCX is negative, the interchanges are applied in
          reverse order.
Method 
  The columns IPIV(K) and K are swapped for K = K1, ..., K2, for
  INCX = 1 (and similarly, for INCX <> 1).
Further Comments 
  This routine is the column-oriented counterpart of the LAPACK
  Library routine DLASWP. The LAPACK Library routine DLAPMT cannot
  be used in this context. To solve the system X*A = B, where A and
  B are N-by-N and M-by-N, respectively, the following statements
  can be used:

      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
      CALL DTRSM( 'R', 'U', 'N', 'N', M, N, ONE, A, LDA, B, LDB )
      CALL DTRSM( 'R', 'L', 'N', 'U', M, N, ONE, A, LDA, B, LDB )
      CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 )
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02HD.html000077500000000000000000000052711201767322700160640ustar00rootroot00000000000000 MA02HD - SLICOT Library Routine Documentation

MA02HD

Check if a matrix is a scalar multiple of an identity-like matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To check if A = DIAG*I, where I is an M-by-N matrix with ones on
  the diagonal and zeros elsewhere.
Specification 
      LOGICAL FUNCTION MA02HD( JOB, M, N, DIAG, A, LDA )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            LDA, M, N
      DOUBLE PRECISION   DIAG
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*)
Function Value 
  MA02HD  LOGICAL
          The function value is set to .TRUE. if A = DIAG*I, and to
          .FALSE., otherwise.
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the part of the matrix A to be checked out,
          as follows:
          = 'U': Upper triangular/trapezoidal part;
          = 'L': Lower triangular/trapezoidal part.
          Otherwise:  All of the matrix A.
Input/Output Parameters 
  M      (input) INTEGER
         The number of rows of the matrix A.  M >= 0.

  N      (input) INTEGER
         The number of columns of the matrix A.  N >= 0.

  DIAG   (input) DOUBLE PRECISION
         The scalar DIAG.

  A      (input) DOUBLE PRECISION array, dimension (LDA,N)
         The leading M-by-N part of this array must contain the
         matrix A.  If JOB = 'U', only the upper triangle or
         trapezoid is accessed; if JOB = 'L', only the lower
         triangle or trapezoid is accessed.

  LDA    INTEGER
         The leading dimension of the array A.  LDA >= max(1,M).
Method 
  The routine returns immediately after detecting a diagonal element
  which differs from DIAG, or a nonzero off-diagonal element in the
  searched part of A.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02ID.html000077500000000000000000000070061201767322700160630ustar00rootroot00000000000000 MA02ID - SLICOT Library Routine Documentation

MA02ID

Matrix 1-, Frobenius, or infinity norms of a skew-Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the value of the one norm, or the Frobenius norm, or
  the infinity norm, or the element of largest absolute value
  of a real skew-Hamiltonian matrix

                [  A   G  ]          T         T
          X  =  [       T ],   G = -G,   Q = -Q,
                [  Q   A  ]

  or of a real Hamiltonian matrix

                [  A   G  ]          T         T
          X  =  [       T ],   G =  G,   Q =  Q,
                [  Q  -A  ]

  where A, G and Q are real n-by-n matrices.

  Note that for this kind of matrices the infinity norm is equal
  to the one norm.
Specification 
      DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG,
     $                                  LDQG, DWORK )
C     .. Scalar Arguments ..
      CHARACTER          NORM, TYP
      INTEGER            LDA, LDQG, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), DWORK(*), QG(LDQG,*)
Function Value 
  MA02ID  DOUBLE PRECISION
          The computed norm.
Arguments

Mode Parameters 

  TYP     CHARACTER*1
          Specifies the type of the input matrix X:
          = 'S':         X is skew-Hamiltonian;
          = 'H':         X is Hamiltonian.

  NORM    CHARACTER*1
          Specifies the value to be returned in MA02ID:
          = '1' or 'O':  one norm of X;
          = 'F' or 'E':  Frobenius norm of X;
          = 'I':         infinity norm of X;
          = 'M':         max(abs(X(i,j)).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  QG      (input) DOUBLE PRECISION array, dimension (LDQG,N+1)
          On entry, the leading N-by-N+1 part of this array must
          contain in columns 1:N the lower triangular part of the
          matrix Q and in columns 2:N+1 the upper triangular part
          of the matrix G. If TYP = 'S', the parts containing the
          diagonal and the first supdiagonal of this array are not
          referenced.

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= MAX(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          where LDWORK >= 2*N when NORM = '1', NORM = 'I' or
          NORM = 'O'; otherwise, DWORK is not referenced.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MA02JD.html000077500000000000000000000060341201767322700160640ustar00rootroot00000000000000 MA02JD - SLICOT Library Routine Documentation

MA02JD

Test if a matrix is an orthogonal symplectic matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute || Q^T Q - I ||_F for a matrix of the form

                    [  op( Q1 )  op( Q2 ) ]
               Q =  [                     ],
                    [ -op( Q2 )  op( Q1 ) ]

  where Q1 and Q2 are N-by-N matrices. This residual can be used to
  test wether Q is numerically an orthogonal symplectic matrix.
Specification 
      DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2,
     $                                  LDQ2, RES, LDRES )
C     .. Scalar Arguments ..
      LOGICAL           LTRAN1, LTRAN2
      INTEGER           LDQ1, LDQ2, LDRES, N
C     .. Array Arguments ..
      DOUBLE PRECISION  Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*)
Function Value 
  MA02JD  DOUBLE PRECISION
          The computed residual.
Arguments

Mode Parameters 

  LTRAN1  LOGICAL
          Specifies the form of op( Q1 ) as follows:
          = .FALSE.:  op( Q1 ) = Q1;
          = .TRUE. :  op( Q1 ) = Q1'.

  LTRAN2  LOGICAL
          Specifies the form of op( Q2 ) as follows:
          = .FALSE.:  op( Q2 ) = Q2;
          = .TRUE. :  op( Q2 ) = Q2'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices Q1 and Q2.  N >= 0.

  Q1      (input) DOUBLE PRECISION array, dimension (LDQ1,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix op( Q1 ).

  LDQ1    INTEGER
          The leading dimension of the array Q1.  LDQ1 >= MAX(1,N).

  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix op( Q2 ).

  LDQ2    INTEGER
          The leading dimension of the array Q2.  LDQ2 >= MAX(1,N).
Workspace 
  RES     DOUBLE PRECISION array, dimension (LDRES,N)

  LDRES   INTEGER
          The leading dimension of the array RES.  LDRES >= MAX(1,N).
Method 
  The routine computes the residual by simple elementary operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01KD.html000077500000000000000000000127211201767322700160650ustar00rootroot00000000000000 MB01KD - SLICOT Library Routine Documentation

MB01KD

Rank 2k operation alpha*A*trans(B) - alpha*B*trans(A) + beta*C, with A and C skew-symmetric matrices

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform one of the skew-symmetric rank 2k operations

      C := alpha*A*B' - alpha*B*A' + beta*C,

  or

      C := alpha*A'*B - alpha*B'*A + beta*C,

  where alpha and beta are scalars, C is a real N-by-N skew-
  symmetric matrix and A, B are N-by-K matrices in the first case
  and K-by-N matrices in the second case.

  This is a modified version of the vanilla implemented BLAS
  routine DSYR2K written by Jack Dongarra, Iain Duff,
  Jeremy Du Croz and Sven Hammarling.
Specification 
      SUBROUTINE MB01KD( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA,
     $                   C, LDC, INFO )
C     .. Scalar Arguments ..
      CHARACTER         UPLO, TRANS
      INTEGER           INFO, K, LDA, LDB, LDC, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies whether the upper or lower triangular part of
          the array C is to be referenced, as follows:
          = 'U':  only the strictly upper triangular part of C is to
                  be referenced;
          = 'L':  only the striclty lower triangular part of C is to
                  be referenced.

  TRANS   CHARACTER*1
          Specifies the operation to be performed, as follows:
          = 'N':         C := alpha*A*B' - alpha*B*A' + beta*C;
          = 'T' or 'C':  C := alpha*A'*B - alpha*B'*A + beta*C.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix C.  N >= 0.

  K       (input) INTEGER
          If TRANS = 'N' the number of columns of A and B; and if
          TRANS = 'T' or TRANS = 'C' the number of rows of A and B.
          K >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. If alpha is zero, or N <= 1, or K = 0,
          A and B are not referenced.

  A       (input)  DOUBLE PRECISION array, dimension (LDA,KA),
          where KA is K when TRANS = 'N', and is N otherwise.
          On entry with TRANS = 'N', the leading N-by-K part of
          of this array must contain the matrix A.
          On entry with TRANS = 'T' or TRANS = 'C', the leading
          K-by-N part of this array must contain the matrix A.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N),  if TRANS = 'N';
          LDA >= MAX(1,K),  if TRANS = 'T' or TRANS = 'C'.

  B       (input)  DOUBLE PRECISION array, dimension (LDB,KB),
          where KB is K when TRANS = 'N', and is N otherwise.
          On entry with TRANS = 'N', the leading N-by-K part of
          of this array must contain the matrix B.
          On entry with TRANS = 'T' or TRANS = 'C', the leading
          K-by-N part of this array must contain the matrix B.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N),  if TRANS = 'N';
          LDB >= MAX(1,K),  if TRANS = 'T' or TRANS = 'C'.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. If beta is zero C need not be set before
          entry.

  C       (input/output)  DOUBLE PRECISION array, dimension (LDC,N)
          On entry with UPLO = 'U', the leading N-by-N part of this
          array must contain the strictly upper triangular part of
          the matrix C. The lower triangular part of this array is
          not referenced.
          On entry with UPLO = 'L', the leading N-by-N part of this
          array must contain the strictly lower triangular part of
          the matrix C. The upper triangular part of this array is
          not referenced.
          On exit with UPLO = 'U', the leading N-by-N part of this
          array contains the strictly upper triangular part of the
          updated matrix C.
          On exit with UPLO = 'L', the leading N-by-N part of this
          array contains the strictly lower triangular part of the
          updated matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Numerical Aspects 
  Though being almost identical with the vanilla implementation
  of the BLAS routine DSYR2K the performance of this routine could
  be significantly lower in the case of vendor supplied, highly
  optimized BLAS.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01LD.html000077500000000000000000000163041201767322700160670ustar00rootroot00000000000000 MB01LD - SLICOT Library Routine Documentation

MB01LD

Computation of matrix expression alpha*R + beta*A*X*trans(A) with skew-symmetric matrices R and X

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix formula
     _
     R = alpha*R + beta*op( A )*X*op( A )',
                                              _
  where alpha and beta are scalars, R, X, and R are skew-symmetric
  matrices, A is a general matrix, and op( A ) is one of

     op( A ) = A   or   op( A ) = A'.

  The result is overwritten on R.
Specification 
      SUBROUTINE MB01LD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA,
     $                   X, LDX, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies which triangles of the skew-symmetric matrices R
          and X are given, as follows:
          = 'U':  the strictly upper triangular part is given;
          = 'L':  the strictly lower triangular part is given.

  TRANS   CHARACTER*1
          Specifies the form of op( A ) to be used in the matrix
          multiplication, as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.
Input/Output Parameters 
  M       (input) INTEGER           _
          The order of the matrices R and R and the number of rows
          of the matrix op( A ).  M >= 0.

  N       (input) INTEGER
          The order of the matrix X and the number of columns of the
          matrix op( A ).  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then R need not be
          set before entry, except when R is identified with X in
          the call.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero or N <= 1, or M <= 1,
          then A and X are not referenced.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
          On entry with UPLO = 'U', the leading M-by-M strictly
          upper triangular part of this array must contain the
          strictly upper triangular part of the skew-symmetric
          matrix R. The lower triangle is not referenced.
          On entry with UPLO = 'L', the leading M-by-M strictly
          lower triangular part of this array must contain the
          strictly lower triangular part of the skew-symmetric
          matrix R. The upper triangle is not referenced.
          On exit, the leading M-by-M strictly upper triangular part
          (if UPLO = 'U'), or strictly lower triangular part
          (if UPLO = 'L'), of this array contains the corresponding
                                                          _
          strictly triangular part of the computed matrix R.

  LDR     INTEGER
          The leading dimension of the array R.  LDR >= MAX(1,M).

  A       (input) DOUBLE PRECISION array, dimension (LDA,k)
          where k is N when TRANS = 'N' and is M when TRANS = 'T' or
          TRANS = 'C'.
          On entry with TRANS = 'N', the leading M-by-N part of this
          array must contain the matrix A.
          On entry with TRANS = 'T' or TRANS = 'C', the leading
          N-by-M part of this array must contain the matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,k),
          where k is M when TRANS = 'N' and is N when TRANS = 'T' or
          TRANS = 'C'.

  X       (input or input/output) DOUBLE PRECISION array, dimension
          (LDX,K), where K = N, if UPLO = 'U' or  LDWORK >= M*(N-1),
               or K = MAX(N,M), if UPLO = 'L' and LDWORK <  M*(N-1).
          On entry, if UPLO = 'U', the leading N-by-N strictly upper
          triangular part of this array must contain the strictly
          upper triangular part of the skew-symmetric matrix X and
          the lower triangular part of the array is not referenced.
          On entry, if UPLO = 'L', the leading N-by-N strictly lower
          triangular part of this array must contain the strictly
          lower triangular part of the skew-symmetric matrix X and
          the upper triangular part of the array is not referenced.
          If LDWORK < M*(N-1), this array is overwritten with the
          matrix op(A)*X, if UPLO = 'U', or X*op(A)', if UPLO = 'L'.

  LDX     INTEGER
          The leading dimension of the array X.
          LDX >= MAX(1,N),   if UPLO = 'L' or  LDWORK >= M*(N-1);
          LDX >= MAX(1,N,M), if UPLO = 'U' and LDWORK <  M*(N-1).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          This array is not referenced when beta = 0, or M <= 1, or
          N <= 1.

  LDWORK  The length of the array DWORK.
          LDWORK >= N, if  beta <> 0, and M > 0, and N >  1;
          LDWORK >= 0, if  beta =  0, or  M = 0, or  N <= 1.
          For optimum performance, LDWORK >= M*(N-1), if  beta <> 0,
          M > 1, and N > 1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -k, the k-th argument had an illegal
                value.
Method 
  The matrix expression is efficiently evaluated taking the skew-
  symmetry into account. If LDWORK >= M*(N-1), a BLAS 3 like
  implementation is used. Specifically, let X = T - T', with T a
  strictly upper or strictly lower triangular matrix, defined by

     T = striu( X ),  if UPLO = 'U',
     T = stril( X ),  if UPLO = 'L',

  where striu and stril denote the strictly upper triangular part
  and strictly lower triangular part of X, respectively. Then,

     A*X*A' = ( A*T )*A' - A*( A*T )',  for TRANS = 'N',
     A'*X*A = A'*( T*A ) - ( T*A )'*A,  for TRANS = 'T', or 'C',

  which involve BLAS 3 operations DTRMM and the skew-symmetric
  correspondent of DSYR2K (with a Fortran implementation available
  in the SLICOT Library routine MB01KD).
  If LDWORK < M*(N-1), a BLAS 2 implementation is used.
Numerical Aspects 
  The algorithm requires approximately

                2         2
     3/2 x M x N + 1/2 x M

  operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01MD.html000077500000000000000000000103221201767322700160620ustar00rootroot00000000000000 MB01MD - SLICOT Library Routine Documentation

MB01MD

Matrix-vector operation alpha*A*x + beta*y, with A a skew-symmetric matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the matrix-vector operation

     y := alpha*A*x + beta*y,

  where alpha and beta are scalars, x and y are vectors of length
  n and A is an n-by-n skew-symmetric matrix.

  This is a modified version of the vanilla implemented BLAS
  routine DSYMV written by Jack Dongarra, Jeremy Du Croz,
  Sven Hammarling, and Richard Hanson.
Specification 
      SUBROUTINE MB01MD( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y,
     $                   INCY )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, LDA, N
      CHARACTER          UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), X(*), Y(*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies whether the upper or lower triangular part of
          the array A is to be referenced as follows:
          = 'U':  only the strictly upper triangular part of A is to
                  be referenced;
          = 'L':  only the strictly lower triangular part of A is to
                  be referenced.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. If alpha is zero the array A is not
          referenced.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          On entry with UPLO = 'U', the leading N-by-N part of this
          array must contain the strictly upper triangular part of
          the matrix A. The lower triangular part of this array is
          not referenced.
          On entry with UPLO = 'L', the leading N-by-N part of this
          array must contain the strictly lower triangular part of
          the matrix A. The upper triangular part of this array is
          not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N)

  X       (input) DOUBLE PRECISION array, dimension
          ( 1 + ( N - 1 )*abs( INCX ) ).
          On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of
          this array must contain the elements of the vector X.

  INCX    (input) INTEGER
          The increment for the elements of X. IF INCX < 0 then the
          elements of X are accessed in reversed order.  INCX <> 0.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. If beta is zero then Y need not be set on
          input.

  Y       (input/output) DOUBLE PRECISION array, dimension
          ( 1 + ( N - 1 )*abs( INCY ) ).
          On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of
          this array must contain the elements of the vector Y.
          On exit, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of
          this array contain the updated elements of the vector Y.

  INCY    (input) INTEGER
          The increment for the elements of Y. IF INCY < 0 then the
          elements of Y are accessed in reversed order.  INCY <> 0.
Numerical Aspects 
  Though being almost identical with the vanilla implementation
  of the BLAS routine DSYMV the performance of this routine could
  be significantly lower in the case of vendor supplied, highly
  optimized BLAS.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01ND.html000077500000000000000000000104171201767322700160700ustar00rootroot00000000000000 MB01ND - SLICOT Library Routine Documentation

MB01ND

Rank 2 operation alpha*x*trans(y) - alpha*y*trans(x) + A, with A a skew-symmetric matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the skew-symmetric rank 2 operation

       A := alpha*x*y' - alpha*y*x' + A,

  where alpha is a scalar, x and y are vectors of length n and A is
  an n-by-n skew-symmetric matrix.

  This is a modified version of the vanilla implemented BLAS
  routine DSYR2 written by Jack Dongarra, Jeremy Du Croz,
  Sven Hammarling, and Richard Hanson.
Specification 
      SUBROUTINE MB01ND( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, N
      CHARACTER          UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies whether the upper or lower triangular part of
          the array A is to be referenced as follows:
          = 'U':  only the strictly upper triangular part of A is to
                  be referenced;
          = 'L':  only the strictly lower triangular part of A is to
                  be referenced.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. If alpha is zero X and Y are not
          referenced.

  X       (input) DOUBLE PRECISION array, dimension
          ( 1 + ( N - 1 )*abs( INCX ) ).
          On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of
          this array must contain the elements of the vector X.

  INCX    (input) INTEGER
          The increment for the elements of X. IF INCX < 0 then the
          elements of X are accessed in reversed order.  INCX <> 0.

  Y       (input) DOUBLE PRECISION array, dimension
          ( 1 + ( N - 1 )*abs( INCY ) ).
          On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of
          this array must contain the elements of the vector Y.

  INCY    (input) INTEGER
          The increment for the elements of Y. IF INCY < 0 then the
          elements of Y are accessed in reversed order.  INCY <> 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry with UPLO = 'U', the leading N-by-N part of this
          array must contain the strictly upper triangular part of
          the matrix A. The lower triangular part of this array is
          not referenced.
          On entry with UPLO = 'L', the leading N-by-N part of this
          array must contain the strictly lower triangular part of
          the matrix A. The upper triangular part of this array is
          not referenced.
          On exit with UPLO = 'U', the leading N-by-N part of this
          array contains the strictly upper triangular part of the
          updated matrix A.
          On exit with UPLO = 'L', the leading N-by-N part of this
          array contains the strictly lower triangular part of the
          updated matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N)
Numerical Aspects 
  Though being almost identical with the vanilla implementation
  of the BLAS routine DSYR2 the performance of this routine could
  be significantly lower in the case of vendor supplied, highly
  optimized BLAS.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01PD.html000077500000000000000000000122461201767322700160740ustar00rootroot00000000000000 MB01PD - SLICOT Library Routine Documentation

MB01PD

Matrix scaling (higher level routine)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To scale a matrix or undo scaling.  Scaling is performed, if
  necessary, so that the matrix norm will be in a safe range of
  representable numbers.
Specification 
      SUBROUTINE MB01PD( SCUN, TYPE, M, N, KL, KU, ANRM, NBL, NROWS, A,
     $                   LDA, INFO )
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, * )
Arguments

Mode Parameters 

  SCUN    CHARACTER*1
          SCUN indicates the operation to be performed.
          = 'S':  scale the matrix.
          = 'U':  undo scaling of the matrix.

  TYPE    CHARACTER*1
          TYPE indicates the storage type of the input matrix.
          = 'G':  A is a full matrix.
          = 'L':  A is a (block) lower triangular matrix.
          = 'U':  A is an (block) upper triangular matrix.
          = 'H':  A is an (block) upper Hessenberg matrix.
          = 'B':  A is a symmetric band matrix with lower bandwidth
                  KL and upper bandwidth KU and with the only the
                  lower half stored.
          = 'Q':  A is a symmetric band matrix with lower bandwidth
                  KL and upper bandwidth KU and with the only the
                  upper half stored.
          = 'Z':  A is a band matrix with lower bandwidth KL and
                  upper bandwidth KU.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A. M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A. N >= 0.

  KL      (input) INTEGER
          The lower bandwidth of A.  Referenced only if TYPE = 'B',
          'Q' or 'Z'.

  KU      (input) INTEGER
          The upper bandwidth of A.  Referenced only if TYPE = 'B',
          'Q' or 'Z'.

  ANRM    (input) DOUBLE PRECISION
          The norm of the initial matrix A.  ANRM >= 0.
          When  ANRM = 0  then an immediate return is effected.
          ANRM should be preserved between the call of the routine
          with SCUN = 'S' and the corresponding one with SCUN = 'U'.

  NBL     (input) INTEGER
          The number of diagonal blocks of the matrix A, if it has a
          block structure.  To specify that matrix A has no block
          structure, set NBL = 0.  NBL >= 0.

  NROWS   (input) INTEGER array, dimension max(1,NBL)
          NROWS(i) contains the number of rows and columns of the
          i-th diagonal block of matrix A.  The sum of the values
          NROWS(i),  for  i = 1: NBL,  should be equal to min(M,N).
          The elements of the array  NROWS  are not referenced if
          NBL = 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M by N part of this array must
          contain the matrix to be scaled/unscaled.
          On exit, the leading M by N part of A will contain
          the modified matrix.
          The storage mode of A is specified by TYPE.

  LDA     (input) INTEGER
          The leading dimension of the array A.  LDA  >= max(1,M).
Error Indicator 
  INFO    (output) INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Denote by ANRM the norm of the matrix, and by SMLNUM and BIGNUM,
  two positive numbers near the smallest and largest safely
  representable numbers, respectively.  The matrix is scaled, if
  needed, such that the norm of the result is in the range
  [SMLNUM, BIGNUM].  The scaling factor is represented as a ratio
  of two numbers, one of them being ANRM, and the other one either
  SMLNUM or BIGNUM, depending on ANRM being less than SMLNUM or
  larger than BIGNUM, respectively.  For undoing the scaling, the
  norm is again compared with SMLNUM or BIGNUM, and the reciprocal
  of the previous scaling factor is used.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01QD.html000077500000000000000000000111261201767322700160710ustar00rootroot00000000000000 MB01QD - SLICOT Library Routine Documentation

MB01QD

Matrix scaling (lower level routine)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To multiply the M by N real matrix A by the real scalar CTO/CFROM.
  This is done without over/underflow as long as the final result
  CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
  A may be full, (block) upper triangular, (block) lower triangular,
  (block) upper Hessenberg, or banded.
Specification 
      SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A,
     $                   LDA, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N, NBL
      DOUBLE PRECISION   CFROM, CTO
C     .. Array Arguments ..
      INTEGER            NROWS ( * )
      DOUBLE PRECISION   A( LDA, * )
Arguments

Mode Parameters 

  TYPE    CHARACTER*1
          TYPE indices the storage type of the input matrix.
          = 'G':  A is a full matrix.
          = 'L':  A is a (block) lower triangular matrix.
          = 'U':  A is a (block) upper triangular matrix.
          = 'H':  A is a (block) upper Hessenberg matrix.
          = 'B':  A is a symmetric band matrix with lower bandwidth
                  KL and upper bandwidth KU and with the only the
                  lower half stored.
          = 'Q':  A is a symmetric band matrix with lower bandwidth
                  KL and upper bandwidth KU and with the only the
                  upper half stored.
          = 'Z':  A is a band matrix with lower bandwidth KL and
                  upper bandwidth KU.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  KL      (input) INTEGER
          The lower bandwidth of A.  Referenced only if TYPE = 'B',
          'Q' or 'Z'.

  KU      (input) INTEGER
          The upper bandwidth of A.  Referenced only if TYPE = 'B',
          'Q' or 'Z'.

  CFROM   (input) DOUBLE PRECISION
  CTO     (input) DOUBLE PRECISION
          The matrix A is multiplied by CTO/CFROM. A(I,J) is
          computed without over/underflow if the final result
          CTO*A(I,J)/CFROM can be represented without over/
          underflow.  CFROM must be nonzero.

  NBL     (input) INTEGER
          The number of diagonal blocks of the matrix A, if it has a
          block structure.  To specify that matrix A has no block
          structure, set NBL = 0.  NBL >= 0.

  NROWS   (input) INTEGER array, dimension max(1,NBL)
          NROWS(i) contains the number of rows and columns of the
          i-th diagonal block of matrix A.  The sum of the values
          NROWS(i),  for  i = 1: NBL,  should be equal to min(M,N).
          The array  NROWS  is not referenced if NBL = 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          The matrix to be multiplied by CTO/CFROM.  See TYPE for
          the storage type.

  LDA     (input) INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).
Error Indicator 
  INFO    INTEGER
          Not used in this implementation.
Method 
  Matrix A is multiplied by the real scalar CTO/CFROM, taking into
  account the specified storage mode of the matrix.
  MB01QD is a version of the LAPACK routine DLASCL, modified for
  dealing with block triangular, or block Hessenberg matrices.
  For efficiency, no tests of the input scalar parameters are
  performed.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01RD.html000077500000000000000000000170371201767322700161010ustar00rootroot00000000000000 MB01RD - SLICOT Library Routine Documentation

MB01RD

Computation of matrix expression alpha R + beta A X trans(A), R, X symmetric

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix formula
     _
     R = alpha*R + beta*op( A )*X*op( A )',
                                              _
  where alpha and beta are scalars, R, X, and R are symmetric
  matrices, A is a general matrix, and op( A ) is one of

     op( A ) = A   or   op( A ) = A'.

  The result is overwritten on R.
Specification 
      SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA,
     $                   X, LDX, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1                                         _
          Specifies which triangles of the symmetric matrices R, R,
          and X are given as follows:
          = 'U':  the upper triangular part is given;
          = 'L':  the lower triangular part is given.

  TRANS   CHARACTER*1
          Specifies the form of op( A ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.
Input/Output Parameters 
  M       (input) INTEGER           _
          The order of the matrices R and R and the number of rows
          of the matrix op( A ).  M >= 0.

  N       (input) INTEGER
          The order of the matrix X and the number of columns of the
          the matrix op( A ).  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then R need not be
          set before entry, except when R is identified with X in
          the call (which is possible only in this case).

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then A and X are not
          referenced.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
          On entry with UPLO = 'U', the leading M-by-M upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix R; the strictly
          lower triangular part of the array is used as workspace.
          On entry with UPLO = 'L', the leading M-by-M lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix R; the strictly
          upper triangular part of the array is used as workspace.
          On exit, the leading M-by-M upper triangular part (if
          UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
          this array contains the corresponding triangular part of
                              _
          the computed matrix R. If beta <> 0, the remaining
          strictly triangular part of this array contains the
          corresponding part of the matrix expression
          beta*op( A )*T*op( A )', where T is the triangular matrix
          defined in the Method section.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,M).

  A       (input) DOUBLE PRECISION array, dimension (LDA,k)
          where k is N when TRANS = 'N' and is M when TRANS = 'T' or
          TRANS = 'C'.
          On entry with TRANS = 'N', the leading M-by-N part of this
          array must contain the matrix A.
          On entry with TRANS = 'T' or TRANS = 'C', the leading
          N-by-M part of this array must contain the matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,l),
          where l is M when TRANS = 'N' and is N when TRANS = 'T' or
          TRANS = 'C'.

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix X and the strictly
          lower triangular part of the array is not referenced.
          On entry, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix X and the strictly
          upper triangular part of the array is not referenced.
          On exit, each diagonal element of this array has half its
          input value, but the other elements are not modified.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= MAX(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, the leading M-by-N part of this
          array (with the leading dimension MAX(1,M)) returns the
          matrix product beta*op( A )*T, where T is the triangular
          matrix defined in the Method section.
          This array is not referenced when beta = 0.

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,M*N), if  beta <> 0;
          LDWORK >= 1,          if  beta =  0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -k, the k-th argument had an illegal
                value.
Method 
  The matrix expression is efficiently evaluated taking the symmetry
  into account. Specifically, let X = T + T', with T an upper or
  lower triangular matrix, defined by

     T = triu( X ) - (1/2)*diag( X ),  if UPLO = 'U',
     T = tril( X ) - (1/2)*diag( X ),  if UPLO = 'L',

  where triu, tril, and diag denote the upper triangular part, lower
  triangular part, and diagonal part of X, respectively. Then,

     op( A )*X*op( A )' = B + B',

  where B := op( A )*T*op( A )'. Matrix B is not symmetric, but it
  can be written as tri( B ) + stri( B ), where tri denotes the
  triangular part specified by UPLO, and stri denotes the remaining
  strictly triangular part. Let R = V + V', with V defined as T
  above. Then, the required triangular part of the result can be
  written as

     alpha*V + beta*tri( B )  + beta*(stri( B ))' +
              alpha*diag( V ) + beta*diag( tri( B ) ).
References 
  None.
Numerical Aspects 
  The algorithm requires approximately

                2         2
     3/2 x M x N + 1/2 x M

  operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01RU.html000077500000000000000000000143541201767322700161210ustar00rootroot00000000000000 MB01RU - SLICOT Library Routine Documentation

MB01RU

Computation of matrix expression alpha R + beta A X trans(A), R, X symmetric (MB01RD variant)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix formula
     _
     R = alpha*R + beta*op( A )*X*op( A )',
                                              _
  where alpha and beta are scalars, R, X, and R are symmetric
  matrices, A is a general matrix, and op( A ) is one of

     op( A ) = A   or   op( A ) = A'.

  The result is overwritten on R.
Specification 
      SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA,
     $                   X, LDX, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies which triangles of the symmetric matrices R
          and X are given as follows:
          = 'U':  the upper triangular part is given;
          = 'L':  the lower triangular part is given.

  TRANS   CHARACTER*1
          Specifies the form of op( A ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.
Input/Output Parameters 
  M       (input) INTEGER           _
          The order of the matrices R and R and the number of rows
          of the matrix op( A ).  M >= 0.

  N       (input) INTEGER
          The order of the matrix X and the number of columns of the
          the matrix op( A ).  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then R need not be
          set before entry, except when R is identified with X in
          the call.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then A and X are not
          referenced.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
          On entry with UPLO = 'U', the leading M-by-M upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix R.
          On entry with UPLO = 'L', the leading M-by-M lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix R.
          On exit, the leading M-by-M upper triangular part (if
          UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
          this array contains the corresponding triangular part of
                              _
          the computed matrix R.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,M).

  A       (input) DOUBLE PRECISION array, dimension (LDA,k)
          where k is N when TRANS = 'N' and is M when TRANS = 'T' or
          TRANS = 'C'.
          On entry with TRANS = 'N', the leading M-by-N part of this
          array must contain the matrix A.
          On entry with TRANS = 'T' or TRANS = 'C', the leading
          N-by-M part of this array must contain the matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,k),
          where k is M when TRANS = 'N' and is N when TRANS = 'T' or
          TRANS = 'C'.

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix X and the strictly
          lower triangular part of the array is not referenced.
          On entry, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix X and the strictly
          upper triangular part of the array is not referenced.
          The diagonal elements of this array are modified
          internally, but are restored on exit.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= MAX(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          This array is not referenced when beta = 0, or M*N = 0.

  LDWORK  The length of the array DWORK.
          LDWORK >= M*N, if  beta <> 0;
          LDWORK >= 0,   if  beta =  0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -k, the k-th argument had an illegal
                value.
Method 
  The matrix expression is efficiently evaluated taking the symmetry
  into account. Specifically, let X = T + T', with T an upper or
  lower triangular matrix, defined by

     T = triu( X ) - (1/2)*diag( X ),  if UPLO = 'U',
     T = tril( X ) - (1/2)*diag( X ),  if UPLO = 'L',

  where triu, tril, and diag denote the upper triangular part, lower
  triangular part, and diagonal part of X, respectively. Then,

     A*X*A' = ( A*T )*A' + A*( A*T )',  for TRANS = 'N',
     A'*X*A = A'*( T*A ) + ( T*A )'*A,  for TRANS = 'T', or 'C',

  which involve BLAS 3 operations (DTRMM and DSYR2K).
Numerical Aspects 
  The algorithm requires approximately

                2         2
     3/2 x M x N + 1/2 x M

  operations.
Further Comments 
  This is a simpler version for MB01RD.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01RW.html000077500000000000000000000072351201767322700161230ustar00rootroot00000000000000 MB01RW - SLICOT Library Routine Documentation

MB01RW

Computation of matrix expression alpha A X trans(A), X symmetric (BLAS 2 version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the transformation of the symmetric matrix A by the
  matrix Z in the form

     A := op(Z)*A*op(Z)',

  where op(Z) is either Z or its transpose, Z'.
Specification 
      SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER         TRANS, UPLO
      INTEGER           INFO, LDA, LDZ, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), Z(LDZ,*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies whether the upper or lower triangle of A
          is stored:
          = 'U':  Upper triangle of A is stored;
          = 'L':  Lower triangle of A is stored.

  TRANS   CHARACTER*1
          Specifies whether op(Z) is Z or its transpose Z':
          = 'N':  op(Z) = Z;
          = 'T':  op(Z) = Z'.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the resulting symmetric matrix op(Z)*A*op(Z)'
          and the number of rows of the matrix Z, if TRANS = 'N',
          or the number of columns of the matrix Z, if TRANS = 'T'.
          M >= 0.

  N       (input) INTEGER
          The order of the symmetric matrix A and the number of
          columns of the matrix Z, if TRANS = 'N', or the number of
          rows of the matrix Z, if TRANS = 'T'.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension
          (LDA,MAX(M,N))
          On entry, the leading N-by-N upper or lower triangular
          part of this array must contain the upper (UPLO = 'U')
          or lower (UPLO = 'L') triangular part of the symmetric
          matrix A.
          On exit, the leading M-by-M upper or lower triangular
          part of this array contains the upper (UPLO = 'U') or
          lower (UPLO = 'L') triangular part of the symmetric
          matrix op(Z)*A*op(Z)'.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,M,N).

  Z       (input) DOUBLE PRECISION array, dimension (LDQ,K)
          where K = N if TRANS = 'N' and K = M if TRANS = 'T'.
          The leading M-by-N part, if TRANS = 'N', or N-by-M part,
          if TRANS = 'T', of this array contains the matrix Z.

  LDZ     INTEGER
          The leading dimension of the array Z.
          LDZ >= MAX(1,M) if TRANS = 'N' and
          LDZ >= MAX(1,N) if TRANS = 'T'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Further Comments 
  This is a simpler, BLAS 2 version for MB01RD.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01RX.html000077500000000000000000000151501201767322700161170ustar00rootroot00000000000000 MB01RX - SLICOT Library Routine Documentation

MB01RX

Computation of a triangle of matrix expression alpha R + beta A B or alpha R + beta B A

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute either the upper or lower triangular part of one of the
  matrix formulas
     _
     R = alpha*R + beta*op( A )*B,                               (1)
     _
     R = alpha*R + beta*B*op( A ),                               (2)
                                          _
  where alpha and beta are scalars, R and R are m-by-m matrices,
  op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m
  and m-by-n matrices for (2), respectively, and op( A ) is one of

     op( A ) = A   or   op( A ) = A',  the transpose of A.

  The result is overwritten on R.
Specification 
      SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR,
     $                   A, LDA, B, LDB, INFO )
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,*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies whether the matrix A appears on the left or
          right in the matrix product as follows:
                  _
          = 'L':  R = alpha*R + beta*op( A )*B;
                  _
          = 'R':  R = alpha*R + beta*B*op( A ).

  UPLO    CHARACTER*1                               _
          Specifies which triangles of the matrices R and R are
          computed and given, respectively, as follows:
          = 'U':  the upper triangular part;
          = 'L':  the lower triangular part.

  TRANS   CHARACTER*1
          Specifies the form of op( A ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.
Input/Output Parameters 
  M       (input) INTEGER           _
          The order of the matrices R and R, the number of rows of
          the matrix op( A ) and the number of columns of the
          matrix B, for SIDE = 'L', or the number of rows of the
          matrix B and the number of columns of the matrix op( A ),
          for SIDE = 'R'.  M >= 0.

  N       (input) INTEGER
          The number of rows of the matrix B and the number of
          columns of the matrix op( A ), for SIDE = 'L', or the
          number of rows of the matrix op( A ) and the number of
          columns of the matrix B, for SIDE = 'R'.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then R need not be
          set before entry.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then A and B are not
          referenced.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
          On entry with UPLO = 'U', the leading M-by-M upper
          triangular part of this array must contain the upper
          triangular part of the matrix R; the strictly lower
          triangular part of the array is not referenced.
          On entry with UPLO = 'L', the leading M-by-M lower
          triangular part of this array must contain the lower
          triangular part of the matrix R; the strictly upper
          triangular part of the array is not referenced.
          On exit, the leading M-by-M upper triangular part (if
          UPLO = 'U'), or lower triangular part (if UPLO = 'L') of
          this array contains the corresponding triangular part of
                              _
          the computed matrix R.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,M).

  A       (input) DOUBLE PRECISION array, dimension (LDA,k), where
          k = N  when  SIDE = 'L', and TRANS = 'N', or
                       SIDE = 'R', and TRANS = 'T';
          k = M  when  SIDE = 'R', and TRANS = 'N', or
                       SIDE = 'L', and TRANS = 'T'.
          On entry, if SIDE = 'L', and TRANS = 'N', or
                       SIDE = 'R', and TRANS = 'T',
          the leading M-by-N part of this array must contain the
          matrix A.
          On entry, if SIDE = 'R', and TRANS = 'N', or
                       SIDE = 'L', and TRANS = 'T',
          the leading N-by-M part of this array must contain the
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,l), where
          l = M  when  SIDE = 'L', and TRANS = 'N', or
                       SIDE = 'R', and TRANS = 'T';
          l = N  when  SIDE = 'R', and TRANS = 'N', or
                       SIDE = 'L', and TRANS = 'T'.

  B       (input) DOUBLE PRECISION array, dimension (LDB,p), where
          p = M  when  SIDE = 'L';
          p = N  when  SIDE = 'R'.
          On entry, the leading N-by-M part, if SIDE = 'L', or
          M-by-N part, if SIDE = 'R', of this array must contain the
          matrix B.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,N), if SIDE = 'L';
          LDB >= MAX(1,M), if SIDE = 'R'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix expression is evaluated taking the triangular
  structure into account. BLAS 2 operations are used. A block
  algorithm can be easily constructed; it can use BLAS 3 GEMM
  operations for most computations, and calls of this BLAS 2
  algorithm for computing the triangles.
Further Comments 
  The main application of this routine is when the result should
  be a symmetric matrix, e.g., when B = X*op( A )', for (1), or
  B = op( A )'*X, for (2), where B is already available and X = X'.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01RY.html000077500000000000000000000132771201767322700161300ustar00rootroot00000000000000 MB01RY - SLICOT Library Routine Documentation

MB01RY

Computation of a triangle of matrix expression alpha R + beta H B or alpha R + beta B H, H upper Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute either the upper or lower triangular part of one of the
  matrix formulas
     _
     R = alpha*R + beta*op( H )*B,                               (1)
     _
     R = alpha*R + beta*B*op( H ),                               (2)
                                                 _
  where alpha and beta are scalars, H, B, R, and R are m-by-m
  matrices, H is an upper Hessenberg matrix, and op( H ) is one of

     op( H ) = H   or   op( H ) = H',  the transpose of H.

  The result is overwritten on R.
Specification 
      SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H,
     $                   LDH, B, LDB, DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies whether the Hessenberg matrix H appears on the
          left or right in the matrix product as follows:
                  _
          = 'L':  R = alpha*R + beta*op( H )*B;
                  _
          = 'R':  R = alpha*R + beta*B*op( H ).

  UPLO    CHARACTER*1                               _
          Specifies which triangles of the matrices R and R are
          computed and given, respectively, as follows:
          = 'U':  the upper triangular part;
          = 'L':  the lower triangular part.

  TRANS   CHARACTER*1
          Specifies the form of op( H ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( H ) = H;
          = 'T':  op( H ) = H';
          = 'C':  op( H ) = H'.
Input/Output Parameters 
  M       (input) INTEGER           _
          The order of the matrices R, R, H and B.  M >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then R need not be
          set before entry.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then H and B are not
          referenced.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
          On entry with UPLO = 'U', the leading M-by-M upper
          triangular part of this array must contain the upper
          triangular part of the matrix R; the strictly lower
          triangular part of the array is not referenced.
          On entry with UPLO = 'L', the leading M-by-M lower
          triangular part of this array must contain the lower
          triangular part of the matrix R; the strictly upper
          triangular part of the array is not referenced.
          On exit, the leading M-by-M upper triangular part (if
          UPLO = 'U'), or lower triangular part (if UPLO = 'L') of
          this array contains the corresponding triangular part of
                              _
          the computed matrix R.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,M).

  H       (input) DOUBLE PRECISION array, dimension (LDH,M)
          On entry, the leading M-by-M upper Hessenberg part of
          this array must contain the upper Hessenberg part of the
          matrix H.
          The elements below the subdiagonal are not referenced,
          except possibly for those in the first column, which
          could be overwritten, but are restored on exit.

  LDH     INTEGER
          The leading dimension of array H.  LDH >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading M-by-M part of this array must
          contain the matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          LDWORK >= M, if  beta <> 0 and SIDE = 'L';
          LDWORK >= 0, if  beta =  0 or  SIDE = 'R'.
          This array is not referenced when beta = 0 or SIDE = 'R'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix expression is efficiently evaluated taking the
  Hessenberg/triangular structure into account. BLAS 2 operations
  are used. A block algorithm can be constructed; it can use BLAS 3
  GEMM operations for most computations, and calls of this BLAS 2
  algorithm for computing the triangles.
Further Comments 
  The main application of this routine is when the result should
  be a symmetric matrix, e.g., when B = X*op( H )', for (1), or
  B = op( H )'*X, for (2), where B is already available and X = X'.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01SD.html000077500000000000000000000050511201767322700160730ustar00rootroot00000000000000 MB01SD - SLICOT Library Routine Documentation

MB01SD

Scaling a rectangular matrix using given row and column scaling factors

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To scale a general M-by-N matrix A using the row and column
  scaling factors in the vectors R and C.
Specification 
      SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C )
C     .. Scalar Arguments ..
      CHARACTER          JOBS
      INTEGER            LDA, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), C(*), R(*)
Arguments

Mode Parameters 

  JOBS    CHARACTER*1
          Specifies the scaling operation to be done, as follows:
          = 'R':  row scaling, i.e., A will be premultiplied
                  by diag(R);
          = 'C':  column scaling, i.e., A will be postmultiplied
                  by diag(C);
          = 'B':  both row and column scaling, i.e., A will be
                  replaced by diag(R) * A * diag(C).
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the M-by-N matrix A.
          On exit, the scaled matrix.  See JOBS for the form of the
          scaled matrix.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  R       (input) DOUBLE PRECISION array, dimension (M)
          The row scale factors for A.
          R is not referenced if JOBS = 'C'.

  C       (input) DOUBLE PRECISION array, dimension (N)
          The column scale factors for A.
          C is not referenced if JOBS = 'R'.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01TD.html000077500000000000000000000127471201767322700161060ustar00rootroot00000000000000 MB01TD - SLICOT Library Routine Documentation

MB01TD

Computation of A B in B, with A and B upper quasi-triangular matrices with the same structure

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix product A * B, where A and B are upper
  quasi-triangular matrices (that is, block upper triangular with
  1-by-1 or 2-by-2 diagonal blocks) with the same structure.
  The result is returned in the array B.
Specification 
      SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrices A and B.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          upper quasi-triangular matrix A. The elements below the
          subdiagonal are not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the upper quasi-triangular matrix B, with the same
          structure as matrix A.
          On exit, the leading N-by-N part of this array contains
          the computed product A * B, with the same structure as
          on entry.
          The elements below the subdiagonal are not referenced.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N-1)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrices A and B have not the same structure,
                and/or A and B are not upper quasi-triangular.
Method 
  The matrix product A * B is computed column by column, using
  BLAS 2 and BLAS 1 operations.
Further Comments 
  This routine can be used, for instance, for computing powers of
  a real Schur form matrix.
Example

Program Text 

*     MB01TD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDB
      PARAMETER        ( LDA = NMAX, LDB = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX-1 )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,NMAX), DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         MB01TD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
*        Compute the matrix product A*B.
         CALL MB01TD( N, A, LDA, B, LDB, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N )
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB01TD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB01TD = ',I2)
99997 FORMAT (' The matrix product A*B is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB01TD EXAMPLE PROGRAM DATA
   5
   1.    2.    6.    3.    5.
  -2.   -1.   -1.    0.   -2.
   0.    0.    1.    5.    1.
   0.    0.    0.    0.   -4.
   0.    0.    0.   20.    4.
   5.    5.    1.    5.    1.
  -2.    1.    3.    0.   -4.
   0.    0.    4.   20.    4.
   0.    0.    0.    3.    5.
   0.    0.    0.    1.   -2.
Program Results 
 MB01TD EXAMPLE PROGRAM RESULTS

 The matrix product A*B is 
   1.0000   7.0000  31.0000 139.0000  22.0000
  -8.0000 -11.0000  -9.0000 -32.0000   2.0000
   0.0000   0.0000   4.0000  36.0000  27.0000
   0.0000   0.0000   0.0000  -4.0000   8.0000
   0.0000   0.0000   0.0000  64.0000  92.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01UD.html000077500000000000000000000105751201767322700161040ustar00rootroot00000000000000 MB01UD - SLICOT Library Routine Documentation

MB01UD

Computation of matrix expressions alpha H A or alpha A H, H Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute one of the matrix products

     B = alpha*op( H ) * A, or B = alpha*A * op( H ),

  where alpha is a scalar, A and B are m-by-n matrices, H is an
  upper Hessenberg matrix, and op( H ) is one of

     op( H ) = H   or   op( H ) = H',  the transpose of H.
Specification 
      SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B,
     $                   LDB, INFO )
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,*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies whether the Hessenberg matrix H appears on the
          left or right in the matrix product as follows:
          = 'L':  B = alpha*op( H ) * A;
          = 'R':  B = alpha*A * op( H ).

  TRANS   CHARACTER*1
          Specifies the form of op( H ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( H ) = H;
          = 'T':  op( H ) = H';
          = 'C':  op( H ) = H'.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrices A and B.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrices A and B.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then H is not
          referenced and A need not be set before entry.

  H       (input) DOUBLE PRECISION array, dimension (LDH,k)
          where k is M when SIDE = 'L' and is N when SIDE = 'R'.
          On entry with SIDE = 'L', the leading M-by-M upper
          Hessenberg part of this array must contain the upper
          Hessenberg matrix H.
          On entry with SIDE = 'R', the leading N-by-N upper
          Hessenberg part of this array must contain the upper
          Hessenberg matrix H.
          The elements below the subdiagonal are not referenced,
          except possibly for those in the first column, which
          could be overwritten, but are restored on exit.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,k),
          where k is M when SIDE = 'L' and is N when SIDE = 'R'.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading M-by-N part of this array must contain the
          matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  B       (output) DOUBLE PRECISION array, dimension (LDB,N)
          The leading M-by-N part of this array contains the
          computed product.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The required matrix product is computed in two steps. In the first
  step, the upper triangle of H is used; in the second step, the
  contribution of the subdiagonal is added. A fast BLAS 3 DTRMM
  operation is used in the first step.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01UW.html000077500000000000000000000112331201767322700161170ustar00rootroot00000000000000 MB01UW - SLICOT Library Routine Documentation

MB01UW

Computation of matrix expressions alpha H A or alpha A H, over A, H Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute one of the matrix products

     A : = alpha*op( H ) * A, or A : = alpha*A * op( H ),

  where alpha is a scalar, A is an m-by-n matrix, H is an upper
  Hessenberg matrix, and op( H ) is one of

     op( H ) = H   or   op( H ) = H',  the transpose of H.
Specification 
      SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies whether the Hessenberg matrix H appears on the
          left or right in the matrix product as follows:
          = 'L':  A := alpha*op( H ) * A;
          = 'R':  A := alpha*A * op( H ).

  TRANS   CHARACTER*1
          Specifies the form of op( H ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( H ) = H;
          = 'T':  op( H ) = H';
          = 'C':  op( H ) = H'.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then H is not
          referenced and A need not be set before entry.

  H       (input) DOUBLE PRECISION array, dimension (LDH,k)
          where k is M when SIDE = 'L' and is N when SIDE = 'R'.
          On entry with SIDE = 'L', the leading M-by-M upper
          Hessenberg part of this array must contain the upper
          Hessenberg matrix H.
          On entry with SIDE = 'R', the leading N-by-N upper
          Hessenberg part of this array must contain the upper
          Hessenberg matrix H.
          The elements below the subdiagonal are not referenced,
          except possibly for those in the first column, which
          could be overwritten, but are restored on exit.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,k),
          where k is M when SIDE = 'L' and is N when SIDE = 'R'.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix A.
          On exit, the leading M-by-N part of this array contains
          the computed product.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0,
          DWORK contains a copy of the matrix A, having the leading
          dimension M.
          This array is not referenced when alpha = 0.

  LDWORK  The length of the array DWORK.
          LDWORK >= 0,   if  alpha =  0 or MIN(M,N) = 0;
          LDWORK >= M-1, if  SIDE  = 'L';
          LDWORK >= N-1, if  SIDE  = 'R'.
          For maximal efficiency LDWORK should be at least M*N.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The required matrix product is computed in two steps. In the first
  step, the upper triangle of H is used; in the second step, the
  contribution of the subdiagonal is added. If the workspace can
  accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in
  the first step.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01UX.html000077500000000000000000000135231201767322700161240ustar00rootroot00000000000000 MB01UX - SLICOT Library Routine Documentation

MB01UX

Computation of matrix expressions alpha T A or alpha A T, over A, T quasi-triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute one of the matrix products

    A : = alpha*op( T ) * A, or A : = alpha*A * op( T ),

  where alpha is a scalar, A is an m-by-n matrix, T is a quasi-
  triangular matrix, and op( T ) is one of

     op( T ) = T   or   op( T ) = T',  the transpose of T.
Specification 
      SUBROUTINE MB01UX( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies whether the upper quasi-triangular matrix H
          appears on the left or right in the matrix product as
          follows:
          = 'L':  A := alpha*op( T ) * A;
          = 'R':  A := alpha*A * op( T ).

  UPLO    CHARACTER*1.
          Specifies whether the matrix T is an upper or lower
          quasi-triangular matrix as follows:
          = 'U':  T is an upper quasi-triangular matrix;
          = 'L':  T is a lower quasi-triangular matrix.

  TRANS   CHARACTER*1
          Specifies the form of op( T ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( T ) = T;
          = 'T':  op( T ) = T';
          = 'C':  op( T ) = T'.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then T is not
          referenced and A need not be set before entry.

  T       (input) DOUBLE PRECISION array, dimension (LDT,k)
          where k is M when SIDE = 'L' and is N when SIDE = 'R'.
          On entry with UPLO = 'U', the leading k-by-k upper
          Hessenberg part of this array must contain the upper
          quasi-triangular matrix T. The elements below the
          subdiagonal are not referenced.
          On entry with UPLO = 'L', the leading k-by-k lower
          Hessenberg part of this array must contain the lower
          quasi-triangular matrix T. The elements above the
          supdiagonal are not referenced.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= max(1,k),
          where k is M when SIDE = 'L' and is N when SIDE = 'R'.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix A.
          On exit, the leading M-by-N part of this array contains
          the computed product.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 and ALPHA<>0,  DWORK(1)  returns the
          optimal value of LDWORK.
          On exit, if  INFO = -12,  DWORK(1)  returns the minimum
          value of LDWORK.
          This array is not referenced when alpha = 0.

  LDWORK  The length of the array DWORK.
          LDWORK >= 1,       if alpha =  0 or MIN(M,N) = 0;
          LDWORK >= 2*(M-1), if SIDE  = 'L';
          LDWORK >= 2*(N-1), if SIDE  = 'R'.
          For maximal efficiency LDWORK should be at least
          NOFF*N + M - 1,    if SIDE  = 'L';
          NOFF*M + N - 1,    if SIDE  = 'R';
          where NOFF is the number of nonzero elements on the
          subdiagonal (if UPLO = 'U') or supdiagonal (if UPLO = 'L')
          of T.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The technique used in this routine is similiar to the technique
  used in the SLICOT [1] subroutine MB01UW developed by Vasile Sima.
  The required matrix product is computed in two steps. In the first
  step, the triangle of T specified by UPLO is used; in the second
  step, the contribution of the sub-/supdiagonal is added. If the
  workspace can accommodate parts of A, a fast BLAS 3 DTRMM
  operation is used in the first step.
References 
  [1] Benner, P., Mehrmann, V., Sima, V., Van Huffel, S., and
      Varga, A.
      SLICOT - A subroutine library in systems and control theory.
      In: Applied and computational control, signals, and circuits,
      Vol. 1, pp. 499-539, Birkhauser, Boston, 1999.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01VD.html000077500000000000000000000120301201767322700160710ustar00rootroot00000000000000 MB01VD - SLICOT Library Routine Documentation

MB01VD

Kronecker product of two matrices

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the following matrix operation

     C = alpha*kron( op(A), op(B) ) + beta*C,

  where alpha and beta are real scalars, op(M) is either matrix M or
  its transpose, M', and kron( X, Y ) denotes the Kronecker product
  of the matrices X and Y.
Specification 
      SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA,
     $                   A, LDA, B, LDB, C, LDC, MC, NC, INFO )
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,*)
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used as follows:
          = 'N':  op(A) = A;
          = 'T':  op(A) = A';
          = 'C':  op(A) = A'.

  TRANB   CHARACTER*1
          Specifies the form of op(B) to be used as follows:
          = 'N':  op(B) = B;
          = 'T':  op(B) = B';
          = 'C':  op(B) = B'.
Input/Output Parameters 
  MA      (input) INTEGER
          The number of rows of the matrix op(A).  MA >= 0.

  NA      (input) INTEGER
          The number of columns of the matrix op(A).  NA >= 0.

  MB      (input) INTEGER
          The number of rows of the matrix op(B).  MB >= 0.

  NB      (input) INTEGER
          The number of columns of the matrix op(B).  NB >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then A and B need not
          be set before entry.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then C need not be
          set before entry.

  A       (input) DOUBLE PRECISION array, dimension (LDA,ka),
          where ka is NA when TRANA = 'N', and is MA otherwise.
          If TRANA = 'N', the leading MA-by-NA part of this array
          must contain the matrix A; otherwise, the leading NA-by-MA
          part of this array must contain the matrix A.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= max(1,MA), if TRANA = 'N';
          LDA >= max(1,NA), if TRANA = 'T' or 'C'.

  B       (input) DOUBLE PRECISION array, dimension (LDB,kb)
          where kb is NB when TRANB = 'N', and is MB otherwise.
          If TRANB = 'N', the leading MB-by-NB part of this array
          must contain the matrix B; otherwise, the leading NB-by-MB
          part of this array must contain the matrix B.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= max(1,MB), if TRANB = 'N';
          LDB >= max(1,NB), if TRANB = 'T' or 'C'.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,NC)
          On entry, if beta is nonzero, the leading MC-by-NC part of
          this array must contain the given matric C, where
          MC = MA*MB and NC = NA*NB.
          On exit, the leading MC-by-NC part of this array contains
          the computed matrix expression
          C = alpha*kron( op(A), op(B) ) + beta*C.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= max(1,MC).

  MC      (output) INTEGER
          The number of rows of the matrix C.  MC = MA*MB.

  NC      (output) INTEGER
          The number of columns of the matrix C.  NC = NA*NB.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The Kronecker product of the matrices op(A) and op(B) is computed
  column by column.
Further Comments 
  The multiplications by zero elements in A are avoided, if the
  matrix A is considered to be sparse, i.e., if
  (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes
  NB+1 passes through the matrix A, and MA*NA passes through the
  matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or
  op(B) = B', it could be more efficient to transpose A and/or B
  before calling this routine, and use the 'N' values for TRANA
  and/or TRANB.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01WD.html000077500000000000000000000146031201767322700161020ustar00rootroot00000000000000 MB01WD - SLICOT Library Routine Documentation

MB01WD

Residuals of Lyapunov or Stein equations for Cholesky factored solutions

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix formula
  _
  R = alpha*( op( A )'*op( T )'*op( T ) + op( T )'*op( T )*op( A ) )
      + beta*R,                                                  (1)

  if DICO = 'C', or
  _
  R = alpha*( op( A )'*op( T )'*op( T )*op( A ) -  op( T )'*op( T ))
      + beta*R,                                                  (2)
                                                          _
  if DICO = 'D', where alpha and beta are scalars, R, and R are
  symmetric matrices, T is a triangular matrix, A is a general or
  Hessenberg matrix, and op( M ) is one of

     op( M ) = M   or   op( M ) = M'.

  The result is overwritten on R.
Specification 
      SUBROUTINE MB01WD( DICO, UPLO, TRANS, HESS, N, ALPHA, BETA, R,
     $                   LDR, A, LDA, T, LDT, INFO )
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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the formula to be evaluated, as follows:
          = 'C':  formula (1), "continuous-time" case;
          = 'D':  formula (2), "discrete-time" case.

  UPLO    CHARACTER*1
          Specifies which triangles of the symmetric matrix R and
          triangular matrix T are given, as follows:
          = 'U':  the upper triangular parts of R and T are given;
          = 'L':  the lower triangular parts of R and T are given;

  TRANS   CHARACTER*1
          Specifies the form of op( M ) to be used, as follows:
          = 'N':  op( M ) = M;
          = 'T':  op( M ) = M';
          = 'C':  op( M ) = M'.

  HESS    CHARACTER*1
          Specifies the form of the matrix A, as follows:
          = 'F':  matrix A is full;
          = 'H':  matrix A is Hessenberg (or Schur), either upper
                  (if UPLO = 'U'), or lower (if UPLO = 'L').
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices R, A, and T.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then the arrays A
          and T are not referenced.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then the array R need
          not be set before entry.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
          On entry with UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix R.
          On entry with UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix R.
          On exit, the leading N-by-N upper triangular part (if
          UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
          this array contains the corresponding triangular part of
                              _
          the computed matrix R.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A. If HESS = 'H' the elements below the
          first subdiagonal, if UPLO = 'U', or above the first
          superdiagonal, if UPLO = 'L', need not be set to zero,
          and are not referenced if DICO = 'D'.
          On exit, the leading N-by-N part of this array contains
          the following matrix product
             alpha*T'*T*A, if TRANS = 'N', or
             alpha*A*T*T', otherwise,
          if DICO = 'C', or
             T*A, if TRANS = 'N', or
             A*T, otherwise,
          if DICO = 'D' (and in this case, these products have a
          Hessenberg form, if HESS = 'H').

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular matrix T and
          the strictly lower triangular part need not be set to zero
          (and it is not referenced).
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular matrix T and
          the strictly upper triangular part need not be set to zero
          (and it is not referenced).

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -k, the k-th argument had an illegal
                value.
Method 
  The matrix expression (1) or (2) is efficiently evaluated taking
  the structure into account. BLAS 3 operations (DTRMM, DSYRK and
  their specializations) are used throughout.
Numerical Aspects 
  If A is a full matrix, the algorithm requires approximately
   3
  N  operations, if DICO = 'C';
         3
  7/6 x N  operations, if DICO = 'D'.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01XD.html000077500000000000000000000071501201767322700161020ustar00rootroot00000000000000 MB01XD - SLICOT Library Routine Documentation

MB01XD

Computing U' U or L L', with U and L upper and lower triangular matrices (block algorithm)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix product U' * U or L * L', where U and L are
  upper and lower triangular matrices, respectively, stored in the
  corresponding upper or lower triangular part of the array A.

  If UPLO = 'U' then the upper triangle of the result is stored,
  overwriting the matrix U in A.
  If UPLO = 'L' then the lower triangle of the result is stored,
  overwriting the matrix L in A.
Specification 
      SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO )
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies which triangle (U or L) is given in the array A,
          as follows:
          = 'U':  the upper triangular part U is given;
          = 'L':  the lower triangular part L is given.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the triangular matrices U or L.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular matrix U.
          On entry, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular matrix L.
          On exit, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array contains the upper
          triangular part of the product U' * U. The strictly lower
          triangular part is not referenced.
          On exit, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array contains the lower
          triangular part of the product L * L'. The strictly upper
          triangular part is not referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix product U' * U or L * L' is computed using BLAS 3
  operations as much as possible (a block algorithm).
Further Comments 
  This routine is a counterpart of LAPACK Library routine DLAUUM,
  which computes the matrix product U * U' or L' * L.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01XY.html000077500000000000000000000066321201767322700161330ustar00rootroot00000000000000 MB01XY - SLICOT Library Routine Documentation

MB01XY

Computing U' U or L L', with U and L upper and lower triangular matrices (unblock algorithm)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix product U' * U or L * L', where U and L are
  upper and lower triangular matrices, respectively, stored in the
  corresponding upper or lower triangular part of the array A.

  If UPLO = 'U' then the upper triangle of the result is stored,
  overwriting the matrix U in A.
  If UPLO = 'L' then the lower triangle of the result is stored,
  overwriting the matrix L in A.
Specification 
      SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO )
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies which triangle (U or L) is given in the array A,
          as follows:
          = 'U':  the upper triangular part U is given;
          = 'L':  the lower triangular part L is given.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the triangular matrices U or L.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular matrix U.
          On entry, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular matrix L.
          On exit, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array contains the upper
          triangular part of the product U' * U. The strictly lower
          triangular part is not referenced.
          On exit, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array contains the lower
          triangular part of the product L * L'. The strictly upper
          triangular part is not referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix product U' * U or L * L' is computed using BLAS 2 and
  BLAS 1 operations (an unblocked algorithm).
Further Comments 
  This routine is a counterpart of LAPACK Library routine DLAUU2,
  which computes the matrix product U * U' or L' * L.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB01YD.html000077500000000000000000000145541201767322700161110ustar00rootroot00000000000000 MB01YD - SLICOT Library Routine Documentation

MB01YD

Symmetric rank k operation C := alpha op( A ) op( A )' + beta C, C symmetric

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the symmetric rank k operations

     C := alpha*op( A )*op( A )' + beta*C,

  where alpha and beta are scalars, C is an n-by-n symmetric matrix,
  op( A ) is an n-by-k matrix, and op( A ) is one of

     op( A ) = A   or   op( A ) = A'.

  The matrix A has l nonzero codiagonals, either upper or lower.
Specification 
      SUBROUTINE MB01YD( UPLO, TRANS, N, K, L, ALPHA, BETA, A, LDA, C,
     $                   LDC, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TRANS, UPLO
      INTEGER            INFO, LDA, LDC, K, L, N
      DOUBLE PRECISION   ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * )
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies which triangle of the symmetric matrix C
          is given and computed, as follows:
          = 'U':  the upper triangular part is given/computed;
          = 'L':  the lower triangular part is given/computed.
          UPLO also defines the pattern of the matrix A (see below).

  TRANS   CHARACTER*1
          Specifies the form of op( A ) to be used, as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix C.  N >= 0.

  K       (input) INTEGER
          The number of columns of the matrix op( A ).  K >= 0.

  L       (input) INTEGER
          If UPLO = 'U', matrix A has L nonzero subdiagonals.
          If UPLO = 'L', matrix A has L nonzero superdiagonals.
          MAX(0,NR-1) >= L >= 0, if UPLO = 'U',
          MAX(0,NC-1) >= L >= 0, if UPLO = 'L',
          where NR and NC are the numbers of rows and columns of the
          matrix A, respectively.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then the array A is
          not referenced.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then the array C need
          not be set before entry.

  A       (input) DOUBLE PRECISION array, dimension (LDA,NC), where
          NC is K when TRANS = 'N', and is N otherwise.
          If TRANS = 'N', the leading N-by-K part of this array must
          contain the matrix A, otherwise the leading K-by-N part of
          this array must contain the matrix A.
          If UPLO = 'U', only the upper triangular part and the
          first L subdiagonals are referenced, and the remaining
          subdiagonals are assumed to be zero.
          If UPLO = 'L', only the lower triangular part and the
          first L superdiagonals are referenced, and the remaining
          superdiagonals are assumed to be zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,NR),
          where NR = N, if TRANS = 'N', and NR = K, otherwise.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry with UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix C.
          On entry with UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix C.
          On exit, the leading N-by-N upper triangular part (if
          UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
          this array contains the corresponding triangular part of
          the updated matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The calculations are efficiently performed taking the symmetry
  and structure into account.
Further Comments 
  The matrix A may have the following patterns, when n = 7, k = 5,
  and l = 2 are used for illustration:

  UPLO = 'U', TRANS = 'N'         UPLO = 'L', TRANS = 'N'

         [ x x x x x ]                   [ x x x 0 0 ]
         [ x x x x x ]                   [ x x x x 0 ]
         [ x x x x x ]                   [ x x x x x ]
     A = [ 0 x x x x ],              A = [ x x x x x ],
         [ 0 0 x x x ]                   [ x x x x x ]
         [ 0 0 0 x x ]                   [ x x x x x ]
         [ 0 0 0 0 x ]                   [ x x x x x ]

  UPLO = 'U', TRANS = 'T'         UPLO = 'L', TRANS = 'T'

         [ x x x x x x x ]               [ x x x 0 0 0 0 ]
         [ x x x x x x x ]               [ x x x x 0 0 0 ]
     A = [ x x x x x x x ],          A = [ x x x x x 0 0 ].
         [ 0 x x x x x x ]               [ x x x x x x 0 ]
         [ 0 0 x x x x x ]               [ x x x x x x x ]

  If N = K, the matrix A is upper or lower triangular, for L = 0,
  and upper or lower Hessenberg, for L = 1.

  This routine is a specialization of the BLAS 3 routine DSYRK.
  BLAS 1 calls are used when appropriate, instead of in-line code,
  in order to increase the efficiency. If the matrix A is full, or
  its zero triangle has small order, an optimized DSYRK code could
  be faster than MB01YD.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB01ZD.html000077500000000000000000000155101201767322700161030ustar00rootroot00000000000000 MB01ZD - SLICOT Library Routine Documentation

MB01ZD

Computing H := alpha op( T ) H, or H := alpha H op( T ), with H Hessenberg-like, T triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix product

     H := alpha*op( T )*H,   or   H := alpha*H*op( T ),

  where alpha is a scalar, H is an m-by-n upper or lower
  Hessenberg-like matrix (with l nonzero subdiagonals or
  superdiagonals, respectively), T is a unit, or non-unit,
  upper or lower triangular matrix, and op( T ) is one of

     op( T ) = T   or   op( T ) = T'.
Specification 
      SUBROUTINE MB01ZD( SIDE, UPLO, TRANST, DIAG, M, N, L, ALPHA, T,
     $                   LDT, H, LDH, INFO )
C     .. Scalar Arguments ..
      CHARACTER          DIAG, SIDE, TRANST, UPLO
      INTEGER            INFO, L, LDH, LDT, M, N
      DOUBLE PRECISION   ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION   H( LDH, * ), T( LDT, * )
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies whether the triangular matrix T appears on the
          left or right in the matrix product, as follows:
          = 'L':  the product alpha*op( T )*H is computed;
          = 'R':  the product alpha*H*op( T ) is computed.

  UPLO    CHARACTER*1
          Specifies the form of the matrices T and H, as follows:
          = 'U':  the matrix T is upper triangular and the matrix H
                  is upper Hessenberg-like;
          = 'L':  the matrix T is lower triangular and the matrix H
                  is lower Hessenberg-like.

  TRANST  CHARACTER*1
          Specifies the form of op( T ) to be used, as follows:
          = 'N':  op( T ) = T;
          = 'T':  op( T ) = T';
          = 'C':  op( T ) = T'.

  DIAG    CHARACTER*1.
          Specifies whether or not T is unit triangular, as follows:
          = 'U':  the matrix T is assumed to be unit triangular;
          = 'N':  the matrix T is not assumed to be unit triangular.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of H.  M >= 0.

  N       (input) INTEGER
          The number of columns of H.  N >= 0.

  L       (input) INTEGER
          If UPLO = 'U', matrix H has L nonzero subdiagonals.
          If UPLO = 'L', matrix H has L nonzero superdiagonals.
          MAX(0,M-1) >= L >= 0, if UPLO = 'U';
          MAX(0,N-1) >= L >= 0, if UPLO = 'L'.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then T is not
          referenced and H need not be set before entry.

  T       (input) DOUBLE PRECISION array, dimension (LDT,k), where
          k is m when SIDE = 'L' and is n when SIDE = 'R'.
          If UPLO = 'U', the leading k-by-k upper triangular part
          of this array must contain the upper triangular matrix T
          and the strictly lower triangular part is not referenced.
          If UPLO = 'L', the leading k-by-k lower triangular part
          of this array must contain the lower triangular matrix T
          and the strictly upper triangular part is not referenced.
          Note that when DIAG = 'U', the diagonal elements of T are
          not referenced either, but are assumed to be unity.

  LDT     INTEGER
          The leading dimension of array T.
          LDT >= MAX(1,M), if SIDE = 'L';
          LDT >= MAX(1,N), if SIDE = 'R'.

  H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
          On entry, if UPLO = 'U', the leading M-by-N upper
          Hessenberg part of this array must contain the upper
          Hessenberg-like matrix H.
          On entry, if UPLO = 'L', the leading M-by-N lower
          Hessenberg part of this array must contain the lower
          Hessenberg-like matrix H.
          On exit, the leading M-by-N part of this array contains
          the matrix product alpha*op( T )*H, if SIDE = 'L',
          or alpha*H*op( T ), if SIDE = 'R'. If TRANST = 'N', this
          product has the same pattern as the given matrix H;
          the elements below the L-th subdiagonal (if UPLO = 'U'),
          or above the L-th superdiagonal (if UPLO = 'L'), are not
          referenced in this case. If TRANST = 'T', the elements
          below the (N+L)-th row (if UPLO = 'U', SIDE = 'R', and
          M > N+L), or at the right of the (M+L)-th column
          (if UPLO = 'L', SIDE = 'L', and N > M+L), are not set to
          zero nor referenced.

  LDH     INTEGER
          The leading dimension of array H.  LDH >= max(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The calculations are efficiently performed taking the problem
  structure into account.
Further Comments 
  The matrix H may have the following patterns, when m = 7, n = 6,
  and l = 2 are used for illustration:

            UPLO = 'U'                    UPLO = 'L'

         [ x x x x x x ]               [ x x x 0 0 0 ]
         [ x x x x x x ]               [ x x x x 0 0 ]
         [ x x x x x x ]               [ x x x x x 0 ]
     H = [ 0 x x x x x ],          H = [ x x x x x x ].
         [ 0 0 x x x x ]               [ x x x x x x ]
         [ 0 0 0 x x x ]               [ x x x x x x ]
         [ 0 0 0 0 x x ]               [ x x x x x x ]

  The products T*H or H*T have the same pattern as H, but the
  products T'*H or H*T' may be full matrices.

  If m = n, the matrix H is upper or lower triangular, for l = 0,
  and upper or lower Hessenberg, for l = 1.

  This routine is a specialization of the BLAS 3 routine DTRMM.
  BLAS 1 calls are used when appropriate, instead of in-line code,
  in order to increase the efficiency. If the matrix H is full, or
  its zero triangle has small order, an optimized DTRMM code could
  be faster than MB01ZD.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02CD.html000077500000000000000000000317571201767322700160700ustar00rootroot00000000000000 MB02CD - SLICOT Library Routine Documentation

MB02CD

Cholesky factorization of a positive definite block Toeplitz matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Cholesky factor and the generator and/or the
  Cholesky factor of the inverse of a symmetric positive definite
  (s.p.d.) block Toeplitz matrix T, defined by either its first
  block row, or its first block column, depending on the routine
  parameter TYPET. Transformation information is stored.
Specification 
      SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L,
     $                   LDL, CS, LCS, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the output of the routine, as follows:
          = 'G':  only computes the generator G of the inverse;
          = 'R':  computes the generator G of the inverse and the
                  Cholesky factor R of T, i.e., if TYPET = 'R',
                  then R'*R = T, and if TYPET = 'C', then R*R' = T;
          = 'L':  computes the generator G and the Cholesky factor L
                  of the inverse, i.e., if TYPET = 'R', then
                  L'*L = inv(T), and if TYPET = 'C', then
                  L*L' = inv(T);
          = 'A':  computes the generator G, the Cholesky factor L
                  of the inverse and the Cholesky factor R of T;
          = 'O':  only computes the Cholesky factor R of T.

  TYPET   CHARACTER*1
          Specifies the type of T, as follows:
          = 'R':  T contains the first block row of an s.p.d. block
                  Toeplitz matrix; if demanded, the Cholesky factors
                  R and L are upper and lower triangular,
                  respectively, and G contains the transposed
                  generator of the inverse;
          = 'C':  T contains the first block column of an s.p.d.
                  block Toeplitz matrix; if demanded, the Cholesky
                  factors R and L are lower and upper triangular,
                  respectively, and G contains the generator of the
                  inverse. This choice results in a column oriented
                  algorithm which is usually faster.
          Note:   in the sequel, the notation x / y means that
                  x corresponds to TYPET = 'R' and y corresponds to
                  TYPET = 'C'.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows / columns in T, which should be equal
          to the blocksize.  K >= 0.

  N       (input)  INTEGER
          The number of blocks in T.  N >= 0.

  T       (input/output)  DOUBLE PRECISION array, dimension
          (LDT,N*K) / (LDT,K)
          On entry, the leading K-by-N*K / N*K-by-K part of this
          array must contain the first block row / column of an
          s.p.d. block Toeplitz matrix.
          On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K
          part of this array contains, in the first K-by-K block,
          the upper / lower Cholesky factor of T(1:K,1:K), and in
          the remaining part, the Householder transformations
          applied during the process.

  LDT     INTEGER
          The leading dimension of the array T.
          LDT >= MAX(1,K),    if TYPET = 'R';
          LDT >= MAX(1,N*K),  if TYPET = 'C'.

  G       (output)  DOUBLE PRECISION array, dimension
          (LDG,N*K) / (LDG,2*K)
          If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading
          2*K-by-N*K / N*K-by-2*K part of this array contains, in
          the first K-by-K block of the second block row / column,
          the lower right block of L (necessary for updating
          factorizations in SLICOT Library routine MB02DD), and
          in the remaining part, the generator of the inverse of T.
          Actually, to obtain a generator one has to set
              G(K+1:2*K, 1:K) = 0,    if TYPET = 'R';
              G(1:K, K+1:2*K) = 0,    if TYPET = 'C'.

  LDG     INTEGER
          The leading dimension of the array G.
          LDG >= MAX(1,2*K),  if TYPET = 'R' and
                                 JOB = 'G', 'R', 'L', or 'A';
          LDG >= MAX(1,N*K),  if TYPET = 'C' and
                                 JOB = 'G', 'R', 'L', or 'A';
          LDG >= 1,           if JOB = 'O'.

  R       (output)  DOUBLE PRECISION array, dimension (LDR,N*K)
          If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading
          N*K-by-N*K part of this array contains the upper / lower
          Cholesky factor of T.
          The elements in the strictly lower / upper triangular part
          are not referenced.

  LDR     INTEGER
          The leading dimension of the array R.
          LDR >= MAX(1,N*K),  if JOB = 'R', 'A', or 'O';
          LDR >= 1,           if JOB = 'G', or 'L'.

  L       (output)  DOUBLE PRECISION array, dimension (LDL,N*K)
          If INFO = 0 and JOB = 'L', or 'A', then the leading
          N*K-by-N*K part of this array contains the lower / upper
          Cholesky factor of the inverse of T.
          The elements in the strictly upper / lower triangular part
          are not referenced.

  LDL     INTEGER
          The leading dimension of the array L.
          LDL >= MAX(1,N*K),  if JOB = 'L', or 'A';
          LDL >= 1,           if JOB = 'G', 'R', or 'O'.

  CS      (output)  DOUBLE PRECISION array, dimension (LCS)
          If INFO = 0, then the leading 3*(N-1)*K part of this
          array contains information about the hyperbolic rotations
          and Householder transformations applied during the
          process. This information is needed for updating the
          factorizations in SLICOT Library routine MB02DD.

  LCS     INTEGER
          The length of the array CS.  LCS >= 3*(N-1)*K.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -16,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,(N-1)*K).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction algorithm failed. The Toeplitz matrix
                associated with T is not (numerically) positive
                definite.
Method 
  Householder transformations and modified hyperbolic rotations
  are used in the Schur algorithm [1], [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The implemented method is numerically stable.
                            3 2
  The algorithm requires 0(K N ) floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, NMAX
      PARAMETER        ( KMAX = 20, NMAX = 20 )
      INTEGER          LCS, LDG, LDL, LDR, LDT, LDWORK
      PARAMETER        ( LDG = 2*KMAX, LDL = NMAX*KMAX, LDR = NMAX*KMAX,
     $                   LDT = KMAX, LDWORK = ( NMAX - 1 )*KMAX )
      PARAMETER        ( LCS = 3*LDWORK )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, M, N
      CHARACTER        JOB, TYPET
*     .. Local Arrays .. (Dimensioned for TYPET = 'R'.)
      DOUBLE PRECISION CS(LCS), DWORK(LDWORK), G(LDG, NMAX*KMAX),
     $                 L(LDL, NMAX*KMAX), R(LDR, NMAX*KMAX),
     $                 T(LDT, NMAX*KMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DLASET, MB02CD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, JOB
      TYPET = 'R'
      M = N*K
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         IF( K.LE.0 .OR. K.GT.KMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) K
         ELSE
            READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
*           Compute the Cholesky factor(s) and/or the generator.
            CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L,
     $                   LDL, CS, LCS, DWORK, LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF ( LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'A' ) .OR.
     $              LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'R' ) ) THEN
                  WRITE ( NOUT, FMT = 99997 )
                  CALL DLASET( 'Full', K, K, ZERO, ZERO, G(K+1,1), LDG )
                  DO 10  I = 1, 2*K
                     WRITE ( NOUT, FMT = 99994 ) ( G(I,J), J = 1, M )
   10             CONTINUE
               END IF
               IF ( LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) ) THEN
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20  I = 1, M
                     WRITE ( NOUT, FMT = 99994 ) ( L(I,J), J = 1, M )
   20             CONTINUE
               END IF
               IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' )
     $                                .OR. LSAME( JOB, 'O' ) ) THEN
                  WRITE ( NOUT, FMT = 99995 )
                  DO 30  I = 1, M
                     WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M )
   30             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02CD = ',I2)
99997 FORMAT (' The generator of the inverse of block Toeplitz matrix',
     $        ' is ')
99996 FORMAT (/' The lower Cholesky factor of the inverse is ')
99995 FORMAT (/' The upper Cholesky factor of block Toeplitz matrix is '
     $       )
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' K is out of range.',/' K = ',I5)
      END
Program Data 
MB02CD EXAMPLE PROGRAM DATA
  3    2     A
  3.0000    1.0000    0.1000    0.1000    0.2000    0.0500
  1.0000    4.0000    0.4000    0.1000    0.0400    0.2000
Program Results 
 MB02CD EXAMPLE PROGRAM RESULTS

 The generator of the inverse of block Toeplitz matrix is 
  -0.2355   0.5231  -0.0642   0.0077   0.0187  -0.0265
  -0.5568  -0.0568   0.0229   0.0060   0.0363   0.0000
   0.0000   0.0000  -0.0387   0.0052   0.0003  -0.0575
   0.0000   0.0000   0.0119  -0.0265  -0.0110   0.0076

 The lower Cholesky factor of the inverse is 
   0.5774   0.0000   0.0000   0.0000   0.0000   0.0000
  -0.1741   0.5222   0.0000   0.0000   0.0000   0.0000
   0.0000  -0.0581   0.5812   0.0000   0.0000   0.0000
  -0.0142   0.0080  -0.1747   0.5224   0.0000   0.0000
  -0.0387   0.0052   0.0003  -0.0575   0.5825   0.0000
   0.0119  -0.0265  -0.0110   0.0076  -0.1754   0.5231

 The upper Cholesky factor of block Toeplitz matrix is 
   1.7321   0.5774   0.0577   0.0577   0.1155   0.0289
   0.0000   1.9149   0.1915   0.0348  -0.0139   0.0957
   0.0000   0.0000   1.7205   0.5754   0.0558   0.0465
   0.0000   0.0000   0.0000   1.9142   0.1890   0.0357
   0.0000   0.0000   0.0000   0.0000   1.7169   0.5759
   0.0000   0.0000   0.0000   0.0000   0.0000   1.9118

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02CU.html000077500000000000000000000230021201767322700160710ustar00rootroot00000000000000 MB02CU - SLICOT Library Routine Documentation

MB02CU

Bringing the first blocks of a generator in proper form (extended version of MB02CX)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To bring the first blocks of a generator to proper form.
  The positive part of the generator is contained in the arrays A1
  and A2. The negative part of the generator is contained in B.
  Transformation information will be stored and can be applied
  via SLICOT Library routine MB02CV.
Specification 
      SUBROUTINE MB02CU( TYPEG, K, P, Q, NB, A1, LDA1, A2, LDA2, B, LDB,
     $                   RNK, IPVT, CS, TOL, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  TYPEG   CHARACTER*1
          Specifies the type of the generator, as follows:
          = 'D':  generator is column oriented and rank
                  deficiencies are expected;
          = 'C':  generator is column oriented and rank
                  deficiencies are not expected;
          = 'R':  generator is row oriented and rank
                  deficiencies are not expected.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows in A1 to be processed.  K >= 0.

  P       (input)  INTEGER
          The number of columns of the positive generator.  P >= K.

  Q       (input)  INTEGER
          The number of columns in B containing the negative
          generators.
          If TYPEG = 'D',        Q >= K;
          If TYPEG = 'C' or 'R', Q >= 0.

  NB      (input)  INTEGER
          On entry, if TYPEG = 'C'  or  TYPEG = 'R', NB specifies
          the block size to be used in the blocked parts of the
          algorithm. If NB <= 0, an unblocked algorithm is used.

  A1      (input/output)  DOUBLE PRECISION array, dimension
          (LDA1, K)
          On entry, the leading K-by-K part of this array must
          contain the leading submatrix of the positive part of the
          generator. If TYPEG = 'C', A1 is assumed to be lower
          triangular and the strictly upper triangular part is not
          referenced. If TYPEG = 'R', A1 is assumed to be upper
          triangular and the strictly lower triangular part is not
          referenced.
          On exit, if TYPEG = 'D', the leading K-by-RNK part of this
          array contains the lower trapezoidal part of the proper
          generator and information for the Householder
          transformations applied during the reduction process.
          On exit, if TYPEG = 'C', the leading K-by-K part of this
          array contains the leading lower triangular part of the
          proper generator.
          On exit, if TYPEG = 'R', the leading K-by-K part of this
          array contains the leading upper triangular part of the
          proper generator.

  LDA1    INTEGER
          The leading dimension of the array A1.  LDA1 >= MAX(1,K).

  A2      (input/output)  DOUBLE PRECISION array,
          if TYPEG = 'D'  or  TYPEG = 'C',  dimension (LDA2, P-K);
          if TYPEG = 'R',                   dimension (LDA2, K).
          On entry, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          K-by-(P-K) part of this array must contain the (K+1)-st
          to P-th columns of the positive part of the generator.
          On entry, if TYPEG = 'R', the leading (P-K)-by-K part of
          this array must contain the (K+1)-st to P-th rows of the
          positive part of the generator.
          On exit, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          K-by-(P-K) part of this array contains information for
          Householder transformations.
          On exit, if TYPEG = 'R', the leading (P-K)-by-K part of
          this array contains information for Householder
          transformations.

  LDA2    INTEGER
          The leading dimension of the array A2.
          If P = K,                   LDA2 >= 1;
          If P > K and (TYPEG = 'D' or TYPEG = 'C'),
                                      LDA2 >= MAX(1,K);
          if P > K and TYPEG = 'R',   LDA2 >= P-K.

  B       (input/output)  DOUBLE PRECISION array,
          if TYPEG = 'D'  or  TYPEG = 'C',  dimension (LDB, Q);
          if TYPEG = 'R',                   dimension (LDB, K).
          On entry, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          K-by-Q part of this array must contain the negative part
          of the generator.
          On entry, if TYPEG = 'R', the leading Q-by-K part of this
          array must contain the negative part of the generator.
          On exit, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          K-by-Q part of this array contains information for
          Householder transformations.
          On exit, if TYPEG = 'R', the leading Q-by-K part of this
          array contains information for Householder transformations.

  LDB     INTEGER
          The leading dimension of the array B.
          If Q = 0,                  LDB >= 1;
          if Q > 0 and (TYPEG = 'D' or TYPEG = 'C'),
                                     LDB >= MAX(1,K);
          if Q > 0 and TYPEG = 'R',  LDB >= Q.

  RNK     (output)  INTEGER
          If TYPEG = 'D', the number of columns in the reduced
          generator which are found to be linearly independent.
          If TYPEG = 'C' or TYPEG = 'R', then RNK is not set.

  IPVT    (output)  INTEGER array, dimension (K)
          If TYPEG = 'D', then if IPVT(i) = k, the k-th row of the
          proper generator is the reduced i-th row of the input
          generator.
          If TYPEG = 'C' or TYPEG = 'R', this array is not
          referenced.

  CS      (output)  DOUBLE PRECISION array, dimension (x)
          If TYPEG = 'D' and P = K,                   x = 3*K;
          if TYPEG = 'D' and P > K,                   x = 5*K;
          if (TYPEG = 'C' or TYPEG = 'R') and P = K,  x = 4*K;
          if (TYPEG = 'C' or TYPEG = 'R') and P > K,  x = 6*K.
          On exit, the first x elements of this array contain
          necessary information for the SLICOT library routine
          MB02CV (Givens and modified hyperbolic rotation
          parameters, scalar factors of the Householder
          transformations).
Tolerances 
  TOL     DOUBLE PRECISION
          If TYPEG = 'D', this number specifies the used tolerance
          for handling deficiencies. If the hyperbolic norm
          of two diagonal elements in the positive and negative
          generators appears to be less than or equal to TOL, then
          the corresponding columns are not reduced.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = -17,  DWORK(1) returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,4*K),         if TYPEG = 'D';
          LDWORK >= MAX(1,MAX(NB,1)*K), if TYPEG = 'C' or 'R'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if TYPEG = 'D', the generator represents a
                (numerically) indefinite matrix; and if TYPEG = 'C'
                or TYPEG = 'R', the generator represents a
                (numerically) semidefinite matrix.
Method 
  If TYPEG = 'C' or TYPEG = 'R', blocked Householder transformations
  and modified hyperbolic rotations are used to downdate the
  matrix [ A1  A2  sqrt(-1)*B ], cf. [1], [2].
  If TYPEG = 'D', then an algorithm with row pivoting is used. In
  the first stage it maximizes the hyperbolic norm of the active
  row. As soon as the hyperbolic norm is below the threshold TOL,
  the strategy is changed. Now, in the second stage, the algorithm
  applies an LQ decomposition with row pivoting on B such that
  the Euclidean norm of the active row is maximized.
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
                            2
  The algorithm requires 0(K *( P + Q )) floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02CV.html000077500000000000000000000246061201767322700161050ustar00rootroot00000000000000 MB02CV - SLICOT Library Routine Documentation

MB02CV

Applying the MB02CU transformations on other columns / rows of the generator

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply the transformations created by the SLICOT Library routine
  MB02CU on other columns / rows of the generator, contained in the
  arrays F1, F2 and G.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  TYPEG   CHARACTER*1
          Specifies the type of the generator, as follows:
          = 'D':  generator is column oriented and rank
                  deficient;
          = 'C':  generator is column oriented and not rank
                  deficient;
          = 'R':  generator is row oriented and not rank
                  deficient.
          Note that this parameter must be equivalent with the
          used TYPEG in the call of MB02CU.

  STRUCG  CHARACTER*1
          Information about the structure of the generators,
          as follows:
          = 'T':  the trailing block of the positive generator
                  is upper / lower triangular, and the trailing
                  block of the negative generator is zero;
          = 'N':  no special structure to mention.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows in A1 to be processed.  K >= 0.

  N       (input)  INTEGER
          If TYPEG = 'D'  or  TYPEG = 'C', the number of rows in F1;
          if TYPEG = 'R', the number of columns in F1.  N >= 0.

  P       (input)  INTEGER
          The number of columns of the positive generator.  P >= K.

  Q       (input)  INTEGER
          The number of columns in B.
          If TYPEG = 'D',        Q >= K;
          If TYPEG = 'C' or 'R', Q >= 0.

  NB      (input)  INTEGER
          On entry, if TYPEG = 'C'  or  TYPEG = 'R', NB specifies
          the block size to be used in the blocked parts of the
          algorithm. NB must be equivalent with the used block size
          in the routine MB02CU.

  RNK     (input)  INTEGER
          If TYPEG = 'D', the number of linearly independent columns
          in the generator as returned by MB02CU.  0 <= RNK <= K.
          If TYPEG = 'C' or 'R', the value of this parameter is
          irrelevant.

  A1      (input)  DOUBLE PRECISION array, dimension
          (LDA1, K)
          On entry, if TYPEG = 'D', the leading K-by-K part of this
          array must contain the matrix A1 as returned by MB02CU.
          If TYPEG = 'C' or 'R', this array is not referenced.

  LDA1    INTEGER
          The leading dimension of the array A1.
          If TYPEG = 'D',                   LDA1 >= MAX(1,K);
          if TYPEG = 'C'  or  TYPEG = 'R',  LDA1 >= 1.

  A2      (input)  DOUBLE PRECISION array,
          if TYPEG = 'D'  or  TYPEG = 'C',  dimension (LDA2, P-K);
          if TYPEG = 'R',                   dimension (LDA2, K).
          On entry, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          K-by-(P-K) part of this array must contain the matrix
          A2 as returned by MB02CU.
          On entry, if TYPEG = 'R', the leading (P-K)-by-K part of
          this array must contain the matrix A2 as returned by
          MB02CU.

  LDA2    INTEGER
          The leading dimension of the array A2.
          If P = K,                  LDA2 >= 1;
          If P > K and (TYPEG = 'D' or TYPEG = 'C'),
                                     LDA2 >= MAX(1,K);
          if P > K and TYPEG = 'R',  LDA2 >= P-K.

  B       (input)  DOUBLE PRECISION array,
          if TYPEG = 'D'  or  TYPEG = 'C',  dimension (LDB, Q);
          if TYPEG = 'R',                   dimension (LDB, K).
          On entry, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          K-by-Q part of this array must contain the matrix B as
          returned by MB02CU.
          On entry, if TYPEG = 'R', the leading Q-by-K part of this
          array must contain the matrix B as returned by MB02CU.

  LDB     INTEGER
          The leading dimension of the array B.
          If Q = 0,                  LDB >= 1;
          If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'),
                                     LDB >= MAX(1,K);
          if Q > 0 and TYPEG = 'R',  LDB >= Q.

  F1      (input/output)  DOUBLE PRECISION array,
          if TYPEG = 'D'  or  TYPEG = 'C',  dimension (LDF1, K);
          if TYPEG = 'R',                   dimension (LDF1, N).
          On entry, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          N-by-K part of this array must contain the first part
          of the positive generator to be processed.
          On entry, if TYPEG = 'R', the leading K-by-N part of this
          array must contain the first part of the positive
          generator to be processed.
          On exit, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          N-by-K part of this array contains the first part of the
          transformed positive generator.
          On exit, if TYPEG = 'R', the leading K-by-N part of this
          array contains the first part of the transformed positive
          generator.

  LDF1    INTEGER
          The leading dimension of the array F1.
          If TYPEG = 'D'  or  TYPEG = 'C',   LDF1 >= MAX(1,N);
          if TYPEG = 'R',                    LDF1 >= MAX(1,K).

  F2      (input/output)  DOUBLE PRECISION array,
          if TYPEG = 'D'  or  TYPEG = 'C',  dimension (LDF2, P-K);
          if TYPEG = 'R',                   dimension (LDF2, N).
          On entry, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          N-by-(P-K) part of this array must contain the second part
          of the positive generator to be processed.
          On entry, if TYPEG = 'R', the leading (P-K)-by-N part of
          this array must contain the second part of the positive
          generator to be processed.
          On exit, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          N-by-(P-K) part of this array contains the second part of
          the transformed positive generator.
          On exit, if TYPEG = 'R', the leading (P-K)-by-N part of
          this array contains the second part of the transformed
          positive generator.

  LDF2    INTEGER
          The leading dimension of the array F2.
          If P = K,                  LDF2 >= 1;
          If P > K and (TYPEG = 'D' or TYPEG = 'C'),
                                     LDF2 >= MAX(1,N);
          if P > K and TYPEG = 'R',  LDF2 >= P-K.

  G       (input/output)  DOUBLE PRECISION array,
          if TYPEG = 'D'  or  TYPEG = 'C',  dimension (LDG, Q);
          if TYPEG = 'R',                   dimension (LDG, N).
          On entry, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          N-by-Q part of this array must contain the negative part
          of the generator to be processed.
          On entry, if TYPEG = 'R', the leading Q-by-N part of this
          array must contain the negative part of the generator to
          be processed.
          On exit, if TYPEG = 'D'  or  TYPEG = 'C', the leading
          N-by-Q part of this array contains the transformed
          negative generator.
          On exit, if TYPEG = 'R', the leading Q-by-N part of this
          array contains the transformed negative generator.

  LDG     INTEGER
          The leading dimension of the array G.
          If Q = 0,                  LDG >= 1;
          If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'),
                                     LDG >= MAX(1,N);
          if Q > 0 and TYPEG = 'R',  LDG >= Q.

  CS      (input)  DOUBLE PRECISION array, dimension (x)
          If TYPEG = 'D' and P = K,                   x = 3*K;
          If TYPEG = 'D' and P > K,                   x = 5*K;
          If (TYPEG = 'C' or TYPEG = 'R') and P = K,  x = 4*K;
          If (TYPEG = 'C' or TYPEG = 'R') and P > K,  x = 6*K.
          On entry, the first x elements of this array must contain
          Givens and modified hyperbolic rotation parameters, and
          scalar factors of the Householder transformations as
          returned by MB02CU.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = -23,  DWORK(1) returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          TYPEG = 'D':               LDWORK >= MAX(1,N);
          (TYPEG = 'C' or TYPEG = 'R')  and  NB <= 0:
                                     LDWORK >= MAX(1,N);
          (TYPEG = 'C' or TYPEG = 'R')  and  NB >= 1:
                                     LDWORK >= MAX(1,( N + K )*NB).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Numerical Aspects 
  The algorithm requires 0(N*K*( P + Q )) floating point operations.
Method 
  The Householder transformations and modified hyperbolic rotations
  computed by SLICOT Library routine MB02CU are applied to the
  corresponding parts of the matrices F1, F2 and G.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02CX.html000077500000000000000000000134041201767322700161010ustar00rootroot00000000000000 MB02CX - SLICOT Library Routine Documentation

MB02CX

Bringing the first blocks of a generator in proper form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To bring the first blocks of a generator in proper form.
  The columns / rows of the positive and negative generators
  are contained in the arrays A and B, respectively.
  Transformation information will be stored and can be applied
  via SLICOT Library routine MB02CY.
Specification 
      SUBROUTINE MB02CX( TYPET, P, Q, K, A, LDA, B, LDB, CS, LCS,
     $                   DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  TYPET   CHARACTER*1
          Specifies the type of the generator, as follows:
          = 'R':  A and B are the first blocks of the rows of the
                  positive and negative generators;
          = 'C':  A and B are the first blocks of the columns of the
                  positive and negative generators.
          Note:   in the sequel, the notation x / y means that
                  x corresponds to TYPET = 'R' and y corresponds to
                  TYPET = 'C'.
Input/Output Parameters 
  P       (input)  INTEGER
          The number of rows / columns in A containing the positive
          generators.  P >= 0.

  Q       (input)  INTEGER
          The number of rows / columns in B containing the negative
          generators.  Q >= 0.

  K       (input)  INTEGER
          The number of columns / rows in A and B to be processed.
          Normally, the size of the first block.  P >= K >= 0.

  A       (input/output)  DOUBLE PRECISION array, dimension
          (LDA, K) / (LDA, P)
          On entry, the leading P-by-K upper / K-by-P lower
          triangular part of this array must contain the rows /
          columns of the positive part in the first block of the
          generator.
          On exit, the leading P-by-K upper / K-by-P lower
          triangular part of this array contains the rows / columns
          of the positive part in the first block of the proper
          generator.
          The lower / upper trapezoidal part is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,P),    if TYPET = 'R';
          LDA >= MAX(1,K),    if TYPET = 'C'.

  B       (input/output)  DOUBLE PRECISION array, dimension
          (LDB, K) / (LDB, Q)
          On entry, the leading Q-by-K / K-by-Q part of this array
          must contain the rows / columns of the negative part in
          the first block of the generator.
          On exit, the leading Q-by-K / K-by-Q part of this array
          contains part of the necessary information for the
          Householder transformations.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,Q),    if TYPET = 'R';
          LDB >= MAX(1,K),    if TYPET = 'C'.

  CS      (output)  DOUBLE PRECISION array, dimension (LCS)
          On exit, the leading 2*K + MIN(K,Q) part of this array
          contains necessary information for the SLICOT Library
          routine MB02CY (modified hyperbolic rotation parameters
          and scalar factors of the Householder transformations).

  LCS     INTEGER
          The length of the array CS.  LCS >= 2*K + MIN(K,Q).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -12,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,K).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  succesful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction algorithm failed. The matrix
                associated with the generator is not (numerically)
                positive definite.
Method 
  If  TYPET = 'R',  a QR decomposition of B is first computed.
  Then, the elements below the first row of each column i of B
  are annihilated by a Householder transformation modifying the
  first element in that column. This first element, in turn, is
  then annihilated by a modified hyperbolic rotation, acting also
  on the i-th row of A.

  If  TYPET = 'C',  an LQ decomposition of B is first computed.
  Then, the elements on the right of the first column of each row i
  of B are annihilated by a Householder transformation modifying the
  first element in that row. This first element, in turn, is
  then annihilated by a modified hyperbolic rotation, acting also
  on the i-th column of A.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02CY.html000077500000000000000000000130121201767322700160750ustar00rootroot00000000000000 MB02CY - SLICOT Library Routine Documentation

MB02CY

Applying the MB02CX transformations on other columns / rows of the generator

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply the transformations created by the SLICOT Library
  routine MB02CX on other columns / rows of the generator,
  contained in the arrays A and B of positive and negative
  generators, respectively.
Specification 
      SUBROUTINE MB02CY( TYPET, STRUCG, P, Q, N, K, A, LDA, B, LDB, H,
     $                   LDH, CS, LCS, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  TYPET   CHARACTER*1
          Specifies the type of the generator, as follows:
          = 'R':  A and B are additional columns of the generator;
          = 'C':  A and B are additional rows of the generator.
          Note:   in the sequel, the notation x / y means that
                  x corresponds to TYPET = 'R' and y corresponds to
                  TYPET = 'C'.

  STRUCG  CHARACTER*1
          Information about the structure of the two generators,
          as follows:
          = 'T':  the trailing block of the positive generator
                  is lower / upper triangular, and the trailing
                  block of the negative generator is zero;
          = 'N':  no special structure to mention.
Input/Output Parameters 
  P       (input)  INTEGER
          The number of rows / columns in A containing the positive
          generators.  P >= 0.

  Q       (input)  INTEGER
          The number of rows / columns in B containing the negative
          generators.  Q >= 0.

  N       (input)  INTEGER
          The number of columns / rows in A and B to be processed.
          N >= 0.

  K       (input)  INTEGER
          The number of columns / rows in H.  P >= K >= 0.

  A       (input/output)  DOUBLE PRECISION array, dimension
          (LDA, N) / (LDA, P)
          On entry, the leading P-by-N / N-by-P part of this array
          must contain the positive part of the generator.
          On exit, the leading P-by-N / N-by-P part of this array
          contains the transformed positive part of the generator.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,P),    if TYPET = 'R';
          LDA >= MAX(1,N),    if TYPET = 'C'.

  B       (input/output)  DOUBLE PRECISION array, dimension
          (LDB, N) / (LDB, Q)
          On entry, the leading Q-by-N / N-by-Q part of this array
          must contain the negative part of the generator.
          On exit, the leading Q-by-N / N-by-Q part of this array
          contains the transformed negative part of the generator.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,Q),    if TYPET = 'R';
          LDB >= MAX(1,N),    if TYPET = 'C'.

  H       (input)  DOUBLE PRECISION array, dimension
          (LDH, K) / (LDH, Q)
          The leading Q-by-K / K-by-Q part of this array must
          contain part of the necessary information for the
          Householder transformations computed by SLICOT Library
          routine MB02CX.

  LDH     INTEGER
          The leading dimension of the array H.
          LDH >= MAX(1,Q),    if TYPET = 'R';
          LDH >= MAX(1,K),    if TYPET = 'C'.

  CS      (input)  DOUBLE PRECISION array, dimension (LCS)
          The leading 2*K + MIN(K,Q) part of this array must
          contain the necessary information for modified hyperbolic
          rotations and the scalar factors of the Householder
          transformations computed by SLICOT Library routine MB02CX.

  LCS     INTEGER
          The length of the array CS.  LCS >= 2*K + MIN(K,Q).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -16,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  succesful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The Householder transformations and modified hyperbolic rotations
  computed by SLICOT Library routine MB02CX are applied to the
  corresponding parts of the matrices A and B.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02DD.html000077500000000000000000000505341201767322700160630ustar00rootroot00000000000000 MB02DD - SLICOT Library Routine Documentation

MB02DD

Updating Cholesky factorization of a positive definite block Toeplitz matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To update the Cholesky factor and the generator and/or the
  Cholesky factor of the inverse of a symmetric positive definite
  (s.p.d.) block Toeplitz matrix T, given the information from
  a previous factorization and additional blocks in TA of its first
  block row, or its first block column, depending on the routine
  parameter TYPET. Transformation information is stored.
Specification 
      SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G,
     $                   LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK,
     $                   INFO )
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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the output of the routine, as follows:
          = 'R':  updates the generator G of the inverse and
                  computes the new columns / rows for the Cholesky
                  factor R of T;
          = 'A':  updates the generator G, computes the new
                  columns / rows for the Cholesky factor R of T and
                  the new rows / columns for the Cholesky factor L
                  of the inverse;
          = 'O':  only computes the new columns / rows for the
                  Cholesky factor R of T.

  TYPET   CHARACTER*1
          Specifies the type of T, as follows:
          = 'R':  the first block row of an s.p.d. block Toeplitz
                  matrix was/is defined; if demanded, the Cholesky
                  factors R and L are upper and lower triangular,
                  respectively, and G contains the transposed
                  generator of the inverse;
          = 'C':  the first block column of an s.p.d. block Toeplitz
                  matrix was/is defined; if demanded, the Cholesky
                  factors R and L are lower and upper triangular,
                  respectively, and G contains the generator of the
                  inverse. This choice results in a column oriented
                  algorithm which is usually faster.
          Note:   in this routine, the notation x / y means that
                  x corresponds to TYPET = 'R' and y corresponds to
                  TYPET = 'C'.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows / columns in T, which should be equal
          to the blocksize.  K >= 0.

  M       (input)  INTEGER
          The number of blocks in TA.  M >= 0.

  N       (input)  INTEGER
          The number of blocks in T.  N >= 0.

  TA      (input/output)  DOUBLE PRECISION array, dimension
          (LDTA,M*K) / (LDTA,K)
          On entry, the leading K-by-M*K / M*K-by-K part of this
          array must contain the (N+1)-th to (N+M)-th blocks in the
          first block row / column of an s.p.d. block Toeplitz
          matrix.
          On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part
          of this array contains information on the Householder
          transformations used, such that the array

                     [ T  TA ]    /    [ T  ]
                                       [ TA ]

          serves as the new transformation matrix T for further
          applications of this routine.

  LDTA    INTEGER
          The leading dimension of the array TA.
          LDTA >= MAX(1,K),   if TYPET = 'R';
          LDTA >= MAX(1,M*K), if TYPET = 'C'.

  T       (input)  DOUBLE PRECISION array, dimension (LDT,N*K) /
          (LDT,K)
          The leading K-by-N*K / N*K-by-K part of this array must
          contain transformation information generated by the SLICOT
          Library routine MB02CD, i.e., in the first K-by-K block,
          the upper / lower Cholesky factor of T(1:K,1:K), and in
          the remaining part, the Householder transformations
          applied during the initial factorization process.

  LDT     INTEGER
          The leading dimension of the array T.
          LDT >= MAX(1,K),    if TYPET = 'R';
          LDT >= MAX(1,N*K),  if TYPET = 'C'.

  G       (input/output)  DOUBLE PRECISION array, dimension
          (LDG,( N + M )*K) / (LDG,2*K)
          On entry, if JOB = 'R', or 'A', then the leading
          2*K-by-N*K / N*K-by-2*K part of this array must contain,
          in the first K-by-K block of the second block row /
          column, the lower right block of the Cholesky factor of
          the inverse of T, and in the remaining part, the generator
          of the inverse of T.
          On exit, if INFO = 0 and JOB = 'R', or 'A', then the
          leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of
          this array contains the same information as on entry, now
          for the updated Toeplitz matrix. Actually, to obtain a
          generator of the inverse one has to set
            G(K+1:2*K, 1:K) = 0,    if TYPET = 'R';
            G(1:K, K+1:2*K) = 0,    if TYPET = 'C'.

  LDG     INTEGER
          The leading dimension of the array G.
          LDG >= MAX(1,2*K),  if TYPET = 'R' and JOB = 'R', or 'A';
          LDG >= MAX(1,( N + M )*K),
                              if TYPET = 'C' and JOB = 'R', or 'A';
          LDG >= 1,           if JOB = 'O'.

  R       (input/output)  DOUBLE PRECISION array, dimension
          (LDR,M*K) / (LDR,( N + M )*K)
          On input, the leading N*K-by-K part of R(K+1,1) /
          K-by-N*K part of R(1,K+1) contains the last block column /
          row of the previous Cholesky factor R.
          On exit, if INFO = 0, then the leading
          ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this
          array contains the last M*K columns / rows of the upper /
          lower Cholesky factor of T. The elements in the strictly
          lower / upper triangular part are not referenced.

  LDR     INTEGER
          The leading dimension of the array R.
          LDR >= MAX(1, ( N + M )*K), if TYPET = 'R';
          LDR >= MAX(1, M*K),         if TYPET = 'C'.

  L       (output)  DOUBLE PRECISION array, dimension
          (LDL,( N + M )*K) / (LDL,M*K)
          If INFO = 0 and JOB = 'A', then the leading
          M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this
          array contains the last M*K rows / columns of the lower /
          upper Cholesky factor of the inverse of T. The elements
          in the strictly upper / lower triangular part are not
          referenced.

  LDL     INTEGER
          The leading dimension of the array L.
          LDL >= MAX(1, M*K),         if TYPET = 'R' and JOB = 'A';
          LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A';
          LDL >= 1,                   if JOB = 'R', or 'O'.

  CS      (input/output)  DOUBLE PRECISION array, dimension (LCS)
          On input, the leading 3*(N-1)*K part of this array must
          contain the necessary information about the hyperbolic
          rotations and Householder transformations applied
          previously by SLICOT Library routine MB02CD.
          On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of
          this array contains information about all the hyperbolic
          rotations and Householder transformations applied during
          the whole process.

  LCS     INTEGER
          The length of the array CS.  LCS >= 3*(N+M-1)*K.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -19,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,(N+M-1)*K).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction algorithm failed. The block Toeplitz
                matrix associated with [ T  TA ] / [ T'  TA' ]' is
                not (numerically) positive definite.
Method 
  Householder transformations and modified hyperbolic rotations
  are used in the Schur algorithm [1], [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The implemented method is numerically stable.
                            3         2
  The algorithm requires 0(K ( N M + M ) ) floating point
  operations.
Further Comments 
  For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns.
  Although the calculations could still be performed when N = 0,
  but min(K,M) > 0, this case is not considered as an "update".
  SLICOT Library routine MB02CD should be called with the argument
  M instead of N.
Example

Program Text 

*     MB02DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, MMAX, NMAX
      PARAMETER        ( KMAX = 20, MMAX = 20, NMAX = 20 )
      INTEGER          LCS, LDG, LDL, LDR, LDT, LDWORK
      PARAMETER        ( LDG = KMAX*( MMAX + NMAX ),
     $                   LDL = KMAX*( MMAX + NMAX ),
     $                   LDR = KMAX*( MMAX + NMAX ),
     $                   LDT = KMAX*( MMAX + NMAX ),
     $                   LDWORK = ( MMAX + NMAX - 1 )*KMAX )
      PARAMETER        ( LCS = 3*LDWORK )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, M, N, S
      CHARACTER        JOB, TYPET
*     .. Local Arrays ..
*     The arrays are dimensioned for both TYPET = 'R' and TYPET = 'C'.
*     Arrays G and T could be smaller.
*     For array G, it is assumed that MMAX + NMAX >= 2.
*     The matrix TA is also stored in the array T.
      DOUBLE PRECISION CS(LCS), DWORK(LDWORK),
     $                 G(LDG, KMAX*( MMAX + NMAX )),
     $                 L(LDL, KMAX*( MMAX + NMAX )),
     $                 R(LDR, KMAX*( MMAX + NMAX )),
     $                 T(LDT, KMAX*( MMAX + NMAX ))
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DLACPY, MB02CD, MB02DD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, M, JOB, TYPET
      S = ( N + M )*K
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) N
      ELSE
         IF ( K.LE.0 .OR. K.GT.KMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) K
         ELSE
            IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99987 ) M
            ELSE
               IF ( LSAME( TYPET, 'R' ) ) THEN
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,S ), I = 1,K )
               ELSE
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,S )
               END IF
*              Compute the Cholesky factors.
               CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L,
     $                      LDL, CS, LCS, DWORK, LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 10  I = 1, N*K
                     WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, N*K )
   10             CONTINUE
                  IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) ) THEN
                     WRITE ( NOUT, FMT = 99995 )
                     IF ( LSAME( TYPET, 'R' ) ) THEN
                        DO 20  I = 1, 2*K
                           WRITE ( NOUT, FMT = 99990 )
     $                           ( G(I,J), J = 1, N*K )
   20                   CONTINUE
                     ELSE
                        DO 30  I = 1, N*K
                           WRITE ( NOUT, FMT = 99990 )
     $                           ( G(I,J), J = 1, 2*K )
   30                   CONTINUE
                     END IF
                  END IF
                  IF ( LSAME( JOB, 'A' ) ) THEN
                     WRITE ( NOUT, FMT = 99994 )
                     DO 40  I = 1, N*K
                        WRITE ( NOUT, FMT = 99990 )
     $                        ( L(I,J), J = 1, N*K )
   40                CONTINUE
                  END IF
*                 Update the Cholesky factors.
                  IF ( LSAME( TYPET, 'R' ) ) THEN
*                    Copy the last block column of R.
                     CALL DLACPY( 'All', N*K, K, R(1,(N-1)*K+1), LDR,
     $                            R(K+1,N*K+1), LDR )
                     CALL MB02DD( JOB, TYPET, K, M, N, T(1,N*K+1), LDT,
     $                            T, LDT, G, LDG, R(1,N*K+1), LDR,
     $                            L(N*K+1,1), LDL, CS, LCS, DWORK,
     $                            LDWORK, INFO )
                  ELSE
*                    Copy the last block row of R.
                     CALL DLACPY( 'All', K, N*K, R((N-1)*K+1,1), LDR,
     $                            R(N*K+1,K+1), LDR )
                     CALL MB02DD( JOB, TYPET, K, M, N, T(N*K+1,1), LDT,
     $                            T, LDT, G, LDG, R(N*K+1,1), LDR,
     $                            L(1,N*K+1), LDL, CS, LCS, DWORK,
     $                            LDWORK, INFO )
                  END IF
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99997 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 50  I = 1, S
                        WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, S )
   50                CONTINUE
                     IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) )
     $                       THEN
                        WRITE ( NOUT, FMT = 99992 )
                        IF ( LSAME( TYPET, 'R' ) ) THEN
                           DO 60  I = 1, 2*K
                              WRITE ( NOUT, FMT = 99990 )
     $                              ( G(I,J), J = 1, S )
   60                      CONTINUE
                        ELSE
                           DO 70  I = 1, S
                              WRITE ( NOUT, FMT = 99990 )
     $                              ( G(I,J), J = 1, 2*K )
   70                      CONTINUE
                        END IF
                     END IF
                     IF ( LSAME( JOB, 'A' ) ) THEN
                        WRITE ( NOUT, FMT = 99991 )
                        DO 80  I = 1, S
                           WRITE ( NOUT, FMT = 99990 )
     $                           ( L(I,J), J = 1, S )
   80                   CONTINUE
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT ( ' MB02DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT ( ' INFO on exit from MB02CD = ',I2)
99997 FORMAT ( ' INFO on exit from MB02DD = ',I2)
99996 FORMAT ( ' The Cholesky factor is ')
99995 FORMAT (/' The inverse generator is ')
99994 FORMAT (/' The inverse Cholesky factor is ')
99993 FORMAT (/' The updated Cholesky factor is ')
99992 FORMAT (/' The updated inverse generator is ')
99991 FORMAT (/' The updated inverse Cholesky factor is ')
99990 FORMAT (20(1X,F8.4))
99989 FORMAT (/' N is out of range.',/' N = ',I5)
99988 FORMAT (/' K is out of range.',/' K = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
MB02DD EXAMPLE PROGRAM DATA
        3       2       2       A       R
    3.0000    1.0000    0.1000    0.1000    0.2000    0.0500    0.1000    0.0400    0.01   0.02
    1.0000    4.0000    0.4000    0.1000    0.0400    0.2000    0.0300    0.0200    0.03   0.01
Program Results 
 MB02DD EXAMPLE PROGRAM RESULTS

 The Cholesky factor is 
   1.7321   0.5774   0.0577   0.0577   0.1155   0.0289
   0.0000   1.9149   0.1915   0.0348  -0.0139   0.0957
   0.0000   0.0000   1.7205   0.5754   0.0558   0.0465
   0.0000   0.0000   0.0000   1.9142   0.1890   0.0357
   0.0000   0.0000   0.0000   0.0000   1.7169   0.5759
   0.0000   0.0000   0.0000   0.0000   0.0000   1.9118

 The inverse generator is 
  -0.2355   0.5231  -0.0642   0.0077   0.0187  -0.0265
  -0.5568  -0.0568   0.0229   0.0060   0.0363   0.0000
   0.5825   0.0000  -0.0387   0.0052   0.0003  -0.0575
  -0.1754   0.5231   0.0119  -0.0265  -0.0110   0.0076

 The inverse Cholesky factor is 
   0.5774   0.0000   0.0000   0.0000   0.0000   0.0000
  -0.1741   0.5222   0.0000   0.0000   0.0000   0.0000
   0.0000  -0.0581   0.5812   0.0000   0.0000   0.0000
  -0.0142   0.0080  -0.1747   0.5224   0.0000   0.0000
  -0.0387   0.0052   0.0003  -0.0575   0.5825   0.0000
   0.0119  -0.0265  -0.0110   0.0076  -0.1754   0.5231

 The updated Cholesky factor is 
   1.7321   0.5774   0.0577   0.0577   0.1155   0.0289   0.0577   0.0231   0.0058   0.0115
   0.0000   1.9149   0.1915   0.0348  -0.0139   0.0957  -0.0017   0.0035   0.0139   0.0017
   0.0000   0.0000   1.7205   0.5754   0.0558   0.0465   0.1145   0.0279   0.0564   0.0227
   0.0000   0.0000   0.0000   1.9142   0.1890   0.0357  -0.0152   0.0953  -0.0017   0.0033
   0.0000   0.0000   0.0000   0.0000   1.7169   0.5759   0.0523   0.0453   0.1146   0.0273
   0.0000   0.0000   0.0000   0.0000   0.0000   1.9118   0.1902   0.0357  -0.0157   0.0955
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.7159   0.5757   0.0526   0.0450
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.9118   0.1901   0.0357
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.7159   0.5757
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.9117

 The updated inverse generator is 
  -0.5599   0.3310  -0.0305   0.0098   0.0392  -0.0209   0.0191  -0.0010  -0.0045   0.0035
  -0.2289  -0.4091   0.0612  -0.0012   0.0125   0.0182   0.0042   0.0017   0.0014   0.0000
   0.5828   0.0000   0.0027  -0.0029  -0.0195   0.0072  -0.0393   0.0057   0.0016  -0.0580
  -0.1755   0.5231  -0.0037   0.0022   0.0005  -0.0022   0.0125  -0.0266  -0.0109   0.0077

 The updated inverse Cholesky factor is 
   0.5774   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -0.1741   0.5222   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
   0.0000  -0.0581   0.5812   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -0.0142   0.0080  -0.1747   0.5224   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -0.0387   0.0052   0.0003  -0.0575   0.5825   0.0000   0.0000   0.0000   0.0000   0.0000
   0.0119  -0.0265  -0.0110   0.0076  -0.1754   0.5231   0.0000   0.0000   0.0000   0.0000
  -0.0199   0.0073  -0.0391   0.0056   0.0017  -0.0580   0.5828   0.0000   0.0000   0.0000
   0.0007  -0.0023   0.0122  -0.0265  -0.0110   0.0077  -0.1755   0.5231   0.0000   0.0000
   0.0027  -0.0029  -0.0195   0.0072  -0.0393   0.0057   0.0016  -0.0580   0.5828   0.0000
  -0.0037   0.0022   0.0005  -0.0022   0.0125  -0.0266  -0.0109   0.0077  -0.1755   0.5231

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02ED.html000077500000000000000000000230261201767322700160600ustar00rootroot00000000000000 MB02ED - SLICOT Library Routine Documentation

MB02ED

Solution of T X = B or X T = B with a positive definite block Toeplitz matrix T

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of linear equations  T*X = B  or  X*T = B  with
  a symmetric positive definite (s.p.d.) block Toeplitz matrix T.
  T is defined either by its first block row or its first block
  column, depending on the parameter TYPET.
Specification 
      SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         TYPET
      INTEGER           INFO, K, LDB, LDT, LDWORK, N, NRHS
C     .. Array Arguments ..
      DOUBLE PRECISION  B(LDB,*), DWORK(*), T(LDT,*)
Arguments

Mode Parameters 

  TYPET   CHARACTER*1
          Specifies the type of T, as follows:
          = 'R':  T contains the first block row of an s.p.d. block
                  Toeplitz matrix, and the system X*T = B is solved;
          = 'C':  T contains the first block column of an s.p.d.
                  block Toeplitz matrix, and the system T*X = B is
                  solved.
          Note:   in the sequel, the notation x / y means that
                  x corresponds to TYPET = 'R' and y corresponds to
                  TYPET = 'C'.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows / columns in T, which should be equal
          to the blocksize.  K >= 0.

  N       (input)  INTEGER
          The number of blocks in T.  N >= 0.

  NRHS    (input)  INTEGER
          The number of right hand sides.  NRHS >= 0.

  T       (input/output)  DOUBLE PRECISION array, dimension
          (LDT,N*K) / (LDT,K)
          On entry, the leading K-by-N*K / N*K-by-K part of this
          array must contain the first block row / column of an
          s.p.d. block Toeplitz matrix.
          On exit, if  INFO = 0  and  NRHS > 0,  then the leading
          K-by-N*K / N*K-by-K part of this array contains the last
          row / column of the Cholesky factor of inv(T).

  LDT     INTEGER
          The leading dimension of the array T.
          LDT >= MAX(1,K),    if TYPET = 'R';
          LDT >= MAX(1,N*K),  if TYPET = 'C'.

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,N*K) / (LDB,NRHS)
          On entry, the leading NRHS-by-N*K / N*K-by-NRHS part of
          this array must contain the right hand side matrix B.
          On exit, the leading NRHS-by-N*K / N*K-by-NRHS part of
          this array contains the solution matrix X.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,NRHS),  if TYPET = 'R';
          LDB >= MAX(1,N*K),   if TYPET = 'C'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -10,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,N*K*K+(N+2)*K).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction algorithm failed. The Toeplitz matrix
                associated with T is not (numerically) positive
                definite.
Method 
  Householder transformations, modified hyperbolic rotations and
  block Gaussian eliminations are used in the Schur algorithm [1],
  [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The implemented method is numerically equivalent with forming
  the Cholesky factor R and the inverse Cholesky factor of T, using
  the generalized Schur algorithm, and solving the systems of
  equations  R*X = L*B  or  X*R = B*L by a blocked backward
  substitution algorithm.
                            3 2    2 2
  The algorithm requires 0(K N  + K N NRHS) floating point
  operations.
Further Comments 
  None
Example

Program Text 

*     MB02ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, NMAX
      PARAMETER        ( KMAX = 20, NMAX = 20 )
      INTEGER          LDB, LDT, LDWORK
      PARAMETER        ( LDB = KMAX*NMAX, LDT = KMAX*NMAX,
     $                   LDWORK = NMAX*KMAX*KMAX + ( NMAX+2 )*KMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, M, N, NRHS
      CHARACTER        TYPET
*     .. Local Arrays ..
*     The arrays B and T are dimensioned for both TYPET = 'R' and
*     TYPET = 'C'.
*     NRHS is assumed to be not larger than KMAX*NMAX.
      DOUBLE PRECISION B(LDB, KMAX*NMAX), DWORK(LDWORK),
     $                 T(LDT, KMAX*NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02ED
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, NRHS, TYPET
      M = N*K
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         IF ( K.LE.0 .OR. K.GT.KMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) K
         ELSE
            IF ( NRHS.LE.0 .OR. NRHS.GT.KMAX*NMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) NRHS
            ELSE
               IF ( LSAME( TYPET, 'R' ) ) THEN
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
               ELSE
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,M )
               END IF
               IF ( LSAME( TYPET, 'R' ) ) THEN
                  READ (NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,
     $                                   NRHS )
               ELSE
                  READ (NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,
     $                                   M )
               END IF
*              Compute the solution of X T = B or T X = B.
               CALL MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK,
     $                      LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF ( LSAME( TYPET, 'R' ) ) THEN
                     WRITE ( NOUT, FMT = 99997 )
                     DO 10  I = 1, NRHS
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   10                CONTINUE
                  ELSE
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20  I = 1, M
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,
     $                                                NRHS )
   20                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02ED EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02ED = ',I2)
99997 FORMAT (' The solution of X*T = B is ')
99996 FORMAT (' The solution of T*X = B is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' K is out of range.',/' K = ',I5)
99992 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5)
      END
Program Data 
MB02ED EXAMPLE PROGRAM DATA
  3    3    2     C
    3.0000    1.0000    0.2000
    1.0000    4.0000    0.4000
    0.2000    0.4000    5.0000
    0.1000    0.1000    0.2000
    0.2000    0.0400    0.0300
    0.0500    0.2000    0.1000
    0.1000    0.0300    0.1000
    0.0400    0.0200    0.2000
    0.0100    0.0300    0.0200
    1.0000    2.0000
    1.0000    2.0000
    1.0000    2.0000
    1.0000    2.0000
    1.0000    2.0000
    1.0000    2.0000
    1.0000    2.0000
    1.0000    2.0000
    1.0000    2.0000
Program Results 
 MB02ED EXAMPLE PROGRAM RESULTS

 The solution of T*X = B is 
   0.2408   0.4816
   0.1558   0.3116
   0.1534   0.3068
   0.2302   0.4603
   0.1467   0.2934
   0.1537   0.3075
   0.2349   0.4698
   0.1498   0.2995
   0.1653   0.3307

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02FD.html000077500000000000000000000336151201767322700160660ustar00rootroot00000000000000 MB02FD - SLICOT Library Routine Documentation

MB02FD

Incomplete Cholesky factor of a positive definite block Toeplitz matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the incomplete Cholesky (ICC) factor of a symmetric
  positive definite (s.p.d.) block Toeplitz matrix T, defined by
  either its first block row, or its first block column, depending
  on the routine parameter TYPET.

  By subsequent calls of this routine, further rows / columns of
  the Cholesky factor can be added.
  Furthermore, the generator of the Schur complement of the leading
  (P+S)*K-by-(P+S)*K block in T is available, which can be used,
  e.g., for measuring the quality of the ICC factorization.
Specification 
      SUBROUTINE MB02FD( TYPET, K, N, P, S, T, LDT, R, LDR, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         TYPET
      INTEGER           INFO, K, LDR, LDT, LDWORK, N, P, S
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), R(LDR,*), T(LDT,*)
Arguments

Mode Parameters 

  TYPET   CHARACTER*1
          Specifies the type of T, as follows:
          = 'R':  T contains the first block row of an s.p.d. block
                  Toeplitz matrix; the ICC factor R is upper
                  trapezoidal;
          = 'C':  T contains the first block column of an s.p.d.
                  block Toeplitz matrix; the ICC factor R is lower
                  trapezoidal; this choice leads to better
                  localized memory references and hence a faster
                  algorithm.
          Note:   in the sequel, the notation x / y means that
                  x corresponds to TYPET = 'R' and y corresponds to
                  TYPET = 'C'.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows / columns in T, which should be equal
          to the blocksize.  K >= 0.

  N       (input)  INTEGER
          The number of blocks in T.  N >= 0.

  P       (input)  INTEGER
          The number of previously computed block rows / columns
          of R.  0 <= P <= N.

  S       (input)  INTEGER
          The number of block rows / columns of R to compute.
          0 <= S <= N-P.

  T       (input/output)  DOUBLE PRECISION array, dimension
          (LDT,(N-P)*K) / (LDT,K)
          On entry, if P = 0, then the leading K-by-N*K / N*K-by-K
          part of this array must contain the first block row /
          column of an s.p.d. block Toeplitz matrix.
          If P > 0, the leading K-by-(N-P)*K / (N-P)*K-by-K must
          contain the negative generator of the Schur complement of
          the leading P*K-by-P*K part in T, computed from previous
          calls of this routine.
          On exit, if INFO = 0, then the leading K-by-(N-P)*K /
          (N-P)*K-by-K part of this array contains, in the first
          K-by-K block, the upper / lower Cholesky factor of
          T(1:K,1:K), in the following S-1 K-by-K blocks, the
          Householder transformations applied during the process,
          and in the remaining part, the negative generator of the
          Schur complement of the leading (P+S)*K-by(P+S)*K part
          in T.

  LDT     INTEGER
          The leading dimension of the array T.
          LDT >= MAX(1,K),        if TYPET = 'R';
          LDT >= MAX(1,(N-P)*K),  if TYPET = 'C'.

  R       (input/output)  DOUBLE PRECISION array, dimension
          (LDR, N*K)       / (LDR, S*K )     if P = 0;
          (LDR, (N-P+1)*K) / (LDR, (S+1)*K ) if P > 0.
          On entry, if P > 0, then the leading K-by-(N-P+1)*K /
          (N-P+1)*K-by-K part of this array must contain the
          nonzero blocks of the last block row / column in the
          ICC factor from a previous call of this routine. Note that
          this part is identical with the positive generator of
          the Schur complement of the leading P*K-by-P*K part in T.
          If P = 0, then R is only an output parameter.
          On exit, if INFO = 0 and P = 0, then the leading
          S*K-by-N*K / N*K-by-S*K part of this array contains the
          upper / lower trapezoidal ICC factor.
          On exit, if INFO = 0 and P > 0, then the leading
          (S+1)*K-by-(N-P+1)*K / (N-P+1)*K-by-(S+1)*K part of this
          array contains the upper / lower trapezoidal part of the
          P-th to (P+S)-th block rows / columns of the ICC factor.
          The elements in the strictly lower / upper trapezoidal
          part are not referenced.

  LDR     INTEGER
          The leading dimension of the array R.
          LDR >= MAX(1, S*K ),        if TYPET = 'R' and P = 0;
          LDR >= MAX(1, (S+1)*K ),    if TYPET = 'R' and P > 0;
          LDR >= MAX(1, N*K ),        if TYPET = 'C' and P = 0;
          LDR >= MAX(1, (N-P+1)*K ),  if TYPET = 'C' and P > 0.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -11,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,(N+1)*K,4*K),   if P = 0;
          LDWORK >= MAX(1,(N-P+2)*K,4*K), if P > 0.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction algorithm failed; the Toeplitz matrix
                associated with T is not (numerically) positive
                definite in its leading (P+S)*K-by-(P+S)*K part.
Method 
  Householder transformations and modified hyperbolic rotations
  are used in the Schur algorithm [1], [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The implemented method is numerically stable.
                            3
  The algorithm requires 0(K S (N-P)) floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02FD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          ITMAX, KMAX, NMAX
      PARAMETER        ( ITMAX = 10, KMAX = 20, NMAX = 20 )
      INTEGER          LDR, LDT, LDWORK
      PARAMETER        ( LDR = NMAX*KMAX, LDT = KMAX,
     $                   LDWORK = ( NMAX + 1 )*KMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, IT, J, K, LEN, M, N, P, PIT, POS, POSR,
     $                 S1, SCIT
      CHARACTER        TYPET
      DOUBLE PRECISION NNRM
*     .. Local Arrays .. (Dimensioned for TYPET = 'R'.)
      INTEGER          S(ITMAX)
      DOUBLE PRECISION DWORK(LDWORK), R(LDR, NMAX*KMAX),
     $                 T(LDT, NMAX*KMAX), V(NMAX*KMAX), W(NMAX*KMAX),
     $                 Z(NMAX*KMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DNRM2
      EXTERNAL         DNRM2, LSAME
*     .. External Subroutines ..
      EXTERNAL         DAXPY, DCOPY, DGEMV, DLASET, DSCAL, DTRMV, MB02FD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, IT
      TYPET = 'R'
      M = N*K
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) K
      ELSE IF( IT.LE.0 .OR. IT.GT.ITMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) IT
      ELSE
         READ ( NIN, FMT = * ) ( S(I), I = 1, IT )
         READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
         P   = 0
         POS = 1
         WRITE ( NOUT, FMT = 99997 )
         DO 90  SCIT = 1, IT
            CALL MB02FD( TYPET, K, N, P, S(SCIT), T(1,POS), LDT,
     $                   R(POS,POS), LDR, DWORK, LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
               STOP
            END IF
            S1 = S(SCIT) + P
            IF ( S1.EQ.0 ) THEN
*              Estimate the 2-norm of the Toeplitz matrix with 5 power
*              iterations.
               LEN = N*K
               CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 )
               DO 30  PIT = 1, 5
                  DO 10  I = 1, N
                     CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE, T,
     $                           LDT, V((I-1)*K+1), 1, ZERO,
     $                           W((I-1)*K+1), 1 )
   10             CONTINUE
                  DO 20 I = 1, N-1
                     CALL DGEMV( 'Transpose', K, (N-I)*K, ONE,
     $                           T(1,K+1), LDT, V((I-1)*K+1), 1,
     $                           ONE, W(I*K+1), 1 )
   20             CONTINUE
                  CALL DCOPY( LEN, W, 1, V, 1 )
                  NNRM = DNRM2( LEN, V, 1 )
                  CALL DSCAL( LEN, ONE/NNRM, V, 1 )
   30          CONTINUE
            ELSE
*              Estimate the 2-norm of the Schur complement with 5 power
*              iterations.
               LEN = ( N - S1 )*K
               CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 )
               DO 80  PIT = 1, 5
                  POSR = ( S1 - 1 )*K + 1
                  DO 40  I = 1, N - S1
                     CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE,
     $                           T(1,POSR+K), LDT, V((I-1)*K+1), 1,
     $                           ZERO, W((I-1)*K+1), 1 )
   40             CONTINUE
                  DO 50  I = 1, N - S1
                     CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', K,
     $                           R(POSR,POSR), LDR, V((I-1)*K+1), 1 )
                     CALL DGEMV( 'NoTranspose', K, LEN-I*K, ONE,
     $                           R(POSR,POSR+K), LDR, V(I*K+1), 1, ONE,
     $                           V((I-1)*K+1), 1 )
   50             CONTINUE
                  CALL DLASET( 'All', LEN, 1, ZERO, ZERO, Z, 1 )
                  DO 60  I = 1, N - S1
                     CALL DGEMV( 'Transpose', K, LEN-I*K, ONE,
     $                           R(POSR,POSR+K), LDR, V((I-1)*K+1), 1,
     $                           ONE, Z(I*K+1), 1 )
                     CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', K,
     $                           R(POSR,POSR), LDR, V((I-1)*K+1), 1 )
                     CALL DAXPY( K, ONE, V((I-1)*K+1), 1, Z((I-1)*K+1),
     $                           1 )
   60             CONTINUE
                  CALL DLASET( 'All', LEN, 1, ZERO, ZERO, V, 1 )
                  DO 70  I = 1, N - S1
                     CALL DGEMV( 'Transpose', K, LEN-(I-1)*K, ONE,
     $                           T(1,POSR+K), LDT, W((I-1)*K+1), 1,
     $                           ONE, V((I-1)*K+1), 1 )
   70             CONTINUE
                  CALL DAXPY( LEN, -ONE, Z, 1, V, 1 )
                  NNRM = DNRM2( LEN, V, 1 )
                  CALL DSCAL( LEN, -ONE/NNRM, V, 1 )
   80          CONTINUE
               POS = ( S1 - 1 )*K + 1
               P   = S1
            END IF
            WRITE ( NOUT, FMT = 99995 ) P*K, NNRM
   90    CONTINUE
         WRITE ( NOUT, FMT = 99996 )
         DO 100  I = 1, P*K
            WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M )
  100    CONTINUE
      END IF
      STOP
*
99999 FORMAT (' MB02FD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02FD = ',I2)
99997 FORMAT ('   Incomplete Cholesky factorization ',
     $         //'   rows    norm(Schur complement)',/)
99996 FORMAT (/' The upper ICC factor of the block Toeplitz matrix is '
     $       )
99995 FORMAT (I4,5X,F8.4)
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' K is out of range.',/' K = ',I5)
99991 FORMAT (/' IT is out of range.',/' IT = ',I5)
      END
Program Data 
MB02FD EXAMPLE
4 2 3
0 1 1
    3.0000    1.0000    0.1000    0.1000    0.2000    0.0500   0.2000   0.3000
    1.0000    4.0000    0.4000    0.1000    0.0400    0.2000   0.1000   0.2000
Program Results 
 MB02FD EXAMPLE PROGRAM RESULTS

   Incomplete Cholesky factorization 

   rows    norm(Schur complement)

   0       5.5509
   2       5.1590
   4       4.8766

 The upper ICC factor of the block Toeplitz matrix is 
   1.7321   0.5774   0.0577   0.0577   0.1155   0.0289   0.1155   0.1732
   0.0000   1.9149   0.1915   0.0348  -0.0139   0.0957   0.0174   0.0522
   0.0000   0.0000   1.7205   0.5754   0.0558   0.0465   0.1104   0.0174
   0.0000   0.0000   0.0000   1.9142   0.1890   0.0357  -0.0161   0.0931

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02GD.html000077500000000000000000000257561201767322700160760ustar00rootroot00000000000000 MB02GD - SLICOT Library Routine Documentation

MB02GD

Cholesky factorization of a banded symmetric positive definite block Toeplitz matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Cholesky factor of a banded symmetric positive
  definite (s.p.d.) block Toeplitz matrix, defined by either its
  first block row, or its first block column, depending on the
  routine parameter TYPET.

  By subsequent calls of this routine the Cholesky factor can be
  computed block column by block column.
Specification 
      SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  TYPET   CHARACTER*1
          Specifies the type of T, as follows:
          = 'R':  T contains the first block row of an s.p.d. block
                  Toeplitz matrix; the Cholesky factor is upper
                  triangular;
          = 'C':  T contains the first block column of an s.p.d.
                  block Toeplitz matrix; the Cholesky factor is
                  lower triangular. This choice results in a column
                  oriented algorithm which is usually faster.
          Note:   in the sequel, the notation x / y means that
                  x corresponds to TYPET = 'R' and y corresponds to
                  TYPET = 'C'.

  TRIU    CHARACTER*1
          Specifies the structure of the last block in T, as
          follows:
          = 'N':  the last block has no special structure;
          = 'T':  the last block is lower / upper triangular.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows / columns in T, which should be equal
          to the blocksize.  K >= 0.

  N       (input)  INTEGER
          The number of blocks in T.  N >= 1.
          If TRIU = 'N',   N >= 1;
          if TRIU = 'T',   N >= 2.

  NL      (input)  INTEGER
          The lower block bandwidth, i.e., NL + 1 is the number of
          nonzero blocks in the first block column of the block
          Toeplitz matrix.
          If TRIU = 'N',   0 <= NL < N;
          if TRIU = 'T',   1 <= NL < N.

  P       (input)  INTEGER
          The number of previously computed block rows / columns of
          the Cholesky factor.  0 <= P <= N.

  S       (input)  INTEGER
          The number of block rows / columns of the Cholesky factor
          to compute.  0 <= S <= N - P.

  T       (input/output)  DOUBLE PRECISION array, dimension
          (LDT,(NL+1)*K) / (LDT,K)
          On entry, if P = 0, the leading K-by-(NL+1)*K /
          (NL+1)*K-by-K part of this array must contain the first
          block row / column of an s.p.d. block Toeplitz matrix.
          On entry, if P > 0, the leading K-by-(NL+1)*K /
          (NL+1)*K-by-K part of this array must contain the P-th
          block row / column of the Cholesky factor.
          On exit, if INFO = 0, then the leading K-by-(NL+1)*K /
          (NL+1)*K-by-K part of this array contains the (P+S)-th
          block row / column of the Cholesky factor.

  LDT     INTEGER
          The leading dimension of the array T.
          LDT >= MAX(1,K) / MAX(1,(NL+1)*K).

  RB      (input/output)  DOUBLE PRECISION array, dimension
          (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K)
          On entry, if TYPET = 'R'  and  TRIU = 'N'  and  P > 0,
          the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array
          must contain the (P*K+1)-st to ((P+NL)*K)-th columns
          of the upper Cholesky factor in banded format from a
          previous call of this routine.
          On entry, if TYPET = 'R'  and  TRIU = 'T'  and  P > 0,
          the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array
          must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns
          of the upper Cholesky factor in banded format from a
          previous call of this routine.
          On exit, if TYPET = 'R'  and  TRIU = 'N', the leading
          (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains
          the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the
          upper Cholesky factor in banded format.
          On exit, if TYPET = 'R'  and  TRIU = 'T', the leading
          (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains
          the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the
          upper Cholesky factor in banded format.
          On exit, if TYPET = 'C'  and  TRIU = 'N', the leading
          (NL+1)*K-by-MIN(S,N-P)*K part of this array contains
          the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower
          Cholesky factor in banded format.
          On exit, if TYPET = 'C'  and  TRIU = 'T', the leading
          (NL*K+1)-by-MIN(S,N-P)*K part of this array contains
          the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower
          Cholesky factor in banded format.
          For further details regarding the band storage scheme see
          the documentation of the LAPACK routine DPBTF2.

  LDRB    INTEGER
          The leading dimension of the array RB.
          If TRIU = 'N',   LDRB >= MAX( (NL+1)*K,1 );
          if TRIU = 'T',   LDRB >= NL*K+1.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -13,  DWORK(1)  returns the minimum
          value of LDWORK.
          The first 1 + ( NL + 1 )*K*K elements of DWORK should be
          preserved during successive calls of the routine.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 1 + ( NL + 1 )*K*K + NL*K.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction algorithm failed. The Toeplitz matrix
                associated with T is not (numerically) positive
                definite.
Method 
  Householder transformations and modified hyperbolic rotations
  are used in the Schur algorithm [1], [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The implemented method is numerically stable.
                             3
  The algorithm requires O( K *N*NL ) floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02GD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, NMAX, NLMAX
      PARAMETER        ( KMAX = 20, NMAX = 20, NLMAX = 20 )
      INTEGER          LDRB, LDT, LDWORK
      PARAMETER        ( LDRB = ( NLMAX + 1 )*KMAX, LDT = KMAX*NMAX,
     $                   LDWORK = ( NLMAX + 1 )*KMAX*KMAX +
     $                            ( 3 + NLMAX )*KMAX )
*     .. Local Scalars ..
      INTEGER          I, J, INFO, K, M, N, NL, SIZR
      CHARACTER        TRIU, TYPET
*     .. Local Arrays dimensioned for TYPET = 'R' ..
      DOUBLE PRECISION DWORK(LDWORK), RB(LDRB, NMAX*KMAX),
     $                 T(LDT, NMAX*KMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02GD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K, N, NL, TRIU
      TYPET = 'R'
      M = ( NL + 1 )*K
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE IF( NL.LE.0 .OR. NL.GT.NLMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) NL
      ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) K
      ELSE
         READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
*        Compute the banded Cholesky factor.
         CALL MB02GD( TYPET, TRIU, K, N, NL, 0, N, T, LDT, RB, LDRB,
     $                DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            IF ( LSAME( TRIU, 'T' ) ) THEN
               SIZR = NL*K + 1
            ELSE
               SIZR = ( NL + 1 )*K
            END IF
            DO 10  I = 1, SIZR
               WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1, N*K )
   10       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02GD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02GD = ',I2)
99997 FORMAT (/' The upper Cholesky factor in banded storage format ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' NL is out of range.',/' NL = ',I5)
99993 FORMAT (/' K is out of range.',/' K = ',I5)
      END
Program Data 
MB02GD EXAMPLE PROGRAM DATA
  2    4    2    T
  3.0000    1.0000    0.1000    0.4000    0.2000    0.0000
  0.0000    4.0000    0.1000    0.1000    0.0500    0.2000
Program Results 
 MB02GD EXAMPLE PROGRAM RESULTS


 The upper Cholesky factor in banded storage format 
   0.0000   0.0000   0.0000   0.0000   0.1155   0.1044   0.1156   0.1051
   0.0000   0.0000   0.0000   0.2309  -0.0087   0.2290  -0.0084   0.2302
   0.0000   0.0000   0.0577  -0.0174   0.0541  -0.0151   0.0544  -0.0159
   0.0000   0.5774   0.0348   0.5704   0.0222   0.5725   0.0223   0.5724
   1.7321   1.9149   1.7307   1.9029   1.7272   1.8996   1.7272   1.8995

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02HD.html000077500000000000000000000301541201767322700160630ustar00rootroot00000000000000 MB02HD - SLICOT Library Routine Documentation

MB02HD

Cholesky factorization of the matrix T' T, with T a banded block Toeplitz matrix of full rank

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, for a banded K*M-by-L*N block Toeplitz matrix T with
  block size (K,L), specified by the nonzero blocks of its first
  block column TC and row TR, a LOWER triangular matrix R (in band
  storage scheme) such that
                       T          T
                      T  T  =  R R .                             (1)

  It is assumed that the first MIN(M*K, N*L) columns of T are
  linearly independent.

  By subsequent calls of this routine, the matrix R can be computed
  block column by block column.
Specification 
      SUBROUTINE MB02HD( TRIU, K, L, M, ML, N, NU, P, S, TC, LDTC, TR,
     $                   LDTR, RB, LDRB, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  TRIU    CHARACTER*1
          Specifies the structure, if any, of the last blocks in TC
          and TR, as follows:
          = 'N':  TC and TR have no special structure;
          = 'T':  TC and TR are upper and lower triangular,
                  respectively. Depending on the block sizes, two
                  different shapes of the last blocks in TC and TR
                  are possible, as illustrated below:

                  1)    TC       TR     2)   TC         TR

                       x x x    x 0 0      x x x x    x 0 0 0
                       0 x x    x x 0      0 x x x    x x 0 0
                       0 0 x    x x x      0 0 x x    x x x 0
                       0 0 0    x x x
Input/Output Parameters 
  K       (input) INTEGER
          The number of rows in the blocks of T.  K >= 0.

  L       (input) INTEGER
          The number of columns in the blocks of T.  L >= 0.

  M       (input) INTEGER
          The number of blocks in the first block column of T.
          M >= 1.

  ML      (input) INTEGER
          The lower block bandwidth, i.e., ML + 1 is the number of
          nonzero blocks in the first block column of T.
          0 <= ML < M and (ML + 1)*K >= L and
          if ( M*K <= N*L ),  ML >= M - INT( ( M*K - 1 )/L ) - 1;
                              ML >= M - INT( M*K/L ) or
                              MOD( M*K, L ) >= K;
          if ( M*K >= N*L ),  ML*K >= N*( L - K ).

  N       (input) INTEGER
          The number of blocks in the first block row of T.
          N >= 1.

  NU      (input) INTEGER
          The upper block bandwidth, i.e., NU + 1 is the number of
          nonzero blocks in the first block row of T.
          If TRIU = 'N',   0 <= NU < N and
                           (M + NU)*L >= MIN( M*K, N*L );
          if TRIU = 'T',   MAX(1-ML,0) <= NU < N and
                           (M + NU)*L >= MIN( M*K, N*L ).

  P       (input)  INTEGER
          The number of previously computed block columns of R.
          P*L < MIN( M*K,N*L ) + L and P >= 0.

  S       (input)  INTEGER
          The number of block columns of R to compute.
          (P+S)*L < MIN( M*K,N*L ) + L and S >= 0.

  TC      (input)  DOUBLE PRECISION array, dimension (LDTC,L)
          On entry, if P = 0, the leading (ML+1)*K-by-L part of this
          array must contain the nonzero blocks in the first block
          column of T.

  LDTC    INTEGER
          The leading dimension of the array TC.
          LDTC >= MAX(1,(ML+1)*K),  if P = 0.

  TR      (input)  DOUBLE PRECISION array, dimension (LDTR,NU*L)
          On entry, if P = 0, the leading K-by-NU*L part of this
          array must contain the 2nd to the (NU+1)-st blocks of
          the first block row of T.

  LDTR    INTEGER
          The leading dimension of the array TR.
          LDTR >= MAX(1,K),  if P = 0.

  RB      (output)  DOUBLE PRECISION array, dimension
          (LDRB,MIN( S*L,MIN( M*K,N*L )-P*L ))
          On exit, if INFO = 0 and TRIU = 'N', the leading
          MIN( ML+NU+1,N )*L-by-MIN( S*L,MIN( M*K,N*L )-P*L ) part
          of this array contains the (P+1)-th to (P+S)-th block
          column of the lower R factor (1) in band storage format.
          On exit, if INFO = 0 and TRIU = 'T', the leading
          MIN( (ML+NU)*L+1,N*L )-by-MIN( S*L,MIN( M*K,N*L )-P*L )
          part of this array contains the (P+1)-th to (P+S)-th block
          column of the lower R factor (1) in band storage format.
          For further details regarding the band storage scheme see
          the documentation of the LAPACK routine DPBTF2.

  LDRB    INTEGER
          The leading dimension of the array RB.
          LDRB >= MAX( MIN( ML+NU+1,N )*L,1 ),      if TRIU = 'N';
          LDRB >= MAX( MIN( (ML+NU)*L+1,N*L ),1 ),  if TRIU = 'T'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -17,  DWORK(1)  returns the minimum
          value of LDWORK.
          The first 1 + 2*MIN( ML+NU+1,N )*L*(K+L) elements of DWORK
          should be preserved during successive calls of the routine.

  LDWORK  INTEGER
          The length of the array DWORK.
          Let x = MIN( ML+NU+1,N ), then
          LDWORK >= 1 + MAX( x*L*L + (2*NU+1)*L*K,
                             2*x*L*(K+L) + (6+x)*L ),  if P = 0;
          LDWORK >= 1 + 2*x*L*(K+L) + (6+x)*L,         if P > 0.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the full rank condition for the first MIN(M*K, N*L)
                columns of T is (numerically) violated.
Method 
  Householder transformations and modified hyperbolic rotations
  are used in the Schur algorithm [1], [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The implemented method yields a factor R which has comparable
  accuracy with the Cholesky factor of T^T * T.
  The algorithm requires
            2                                  2
        O( L *K*N*( ML + NU ) + N*( ML + NU )*L *( L + K ) )

  floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02HD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, LMAX, MMAX, MLMAX, NMAX, NUMAX
      PARAMETER        ( KMAX = 20, LMAX  = 20, MMAX = 20, MLMAX = 10,
     $                   NMAX = 20, NUMAX = 10 )
      INTEGER          LDRB, LDTC, LDTR, LDWORK
      PARAMETER        ( LDRB = ( MLMAX + NUMAX + 1 )*LMAX,
     $                   LDTC = ( MLMAX + 1 )*KMAX, LDTR = KMAX )
      PARAMETER        ( LDWORK = LDRB*LMAX + ( 2*NUMAX + 1 )*LMAX*KMAX
     $                            + 2*LDRB*( KMAX + LMAX ) + LDRB
     $                            + 6*LMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, L, LENR, M, ML, N, NU, S
      CHARACTER        TRIU
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,NMAX*LMAX),
     $                 TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02HD
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K, L, M, ML, N, NU, TRIU
      IF( K.LT.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) K
      ELSE IF( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) L
      ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) M
      ELSE IF( ML.LT.0 .OR. ML.GT.MLMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) ML
      ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE IF( NU.LT.0 .OR. NU.GT.NUMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NU
      ELSE
         READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,(ML+1)*K )
         READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,NU*L ), I = 1,K )
         S = ( MIN( M*K, N*L ) + L - 1 ) / L
*        Compute the banded R factor.
         CALL MB02HD( TRIU, K, L, M, ML, N, NU, 0, S, TC, LDTC, TR,
     $                LDTR, RB, LDRB, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            LENR = ( ML + NU + 1 )*L
            IF ( LSAME( TRIU, 'T' ) )  LENR = ( ML + NU )*L + 1
            LENR = MIN( LENR, N*L )
            DO 10  I = 1, LENR
               WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1,
     $                                       MIN( N*L, M*K ) )
   10       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02HD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02HD = ',I2)
99997 FORMAT (/' The lower triangular factor R in banded storage ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' NU is out of range.',/' NU = ',I5)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' ML is out of range.',/' ML = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' L is out of range.',/' L = ',I5)
99990 FORMAT (/' K is out of range.',/' K = ',I5)
      END
Program Data 
MB02HD EXAMPLE PROGRAM DATA
   2  2  6  2  5   1  N
     4.0     4.0
     1.0     3.0
     2.0     1.0
     2.0     2.0
     4.0     4.0
     3.0     4.0
     1.0     3.0   
     2.0     1.0
Program Results 
 MB02HD EXAMPLE PROGRAM RESULTS


 The lower triangular factor R in banded storage 
  -7.0711  -2.4125   6.0822   2.9967   5.9732   2.8593   5.8497   2.7914   2.7298   1.9557
  -7.4953  -0.0829   5.8986  -0.5571   5.5329   0.2059   5.6797   0.3414   0.9565   0.0000
  -4.2426   0.9202   2.4747  -1.6425   2.9472  -1.0052   2.4396  -0.7785   0.0000   0.0000
  -5.2326   0.6218   2.8391  -0.0820   3.2670   0.6327   2.7067   0.0000   0.0000   0.0000
  -3.5355   0.8207   3.1160  -0.4451   3.5758   0.5701   0.0000   0.0000   0.0000   0.0000
  -4.6669  -0.5803   3.9454   0.7682   4.5481   0.0000   0.0000   0.0000   0.0000   0.0000
  -1.4142  -0.0415   1.6441   0.4848   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -2.1213   0.0000   2.4662   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02ID.html000077500000000000000000000275551201767322700160770ustar00rootroot00000000000000 MB02ID - SLICOT Library Routine Documentation

MB02ID

Solution of over- or underdetermined linear systems with a full rank block Toeplitz matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the overdetermined or underdetermined real linear systems
  involving an M*K-by-N*L block Toeplitz matrix T that is specified
  by its first block column and row. It is assumed that T has full
  rank.
  The following options are provided:

  1. If JOB = 'O' or JOB = 'A' :  find the least squares solution of
     an overdetermined system, i.e., solve the least squares problem

               minimize || B - T*X ||.                           (1)

  2. If JOB = 'U' or JOB = 'A' :  find the minimum norm solution of
     the undetermined system
                T
               T * X = C.                                        (2)
Specification 
      SUBROUTINE MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B,
     $                   LDB, C, LDC, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the problem to be solved as follows
          = 'O':  solve the overdetermined system (1);
          = 'U':  solve the underdetermined system (2);
          = 'A':  solve (1) and (2).
Input/Output Parameters 
  K       (input) INTEGER
          The number of rows in the blocks of T.  K >= 0.

  L       (input) INTEGER
          The number of columns in the blocks of T.  L >= 0.

  M       (input) INTEGER
          The number of blocks in the first block column of T.
          M >= 0.

  N       (input) INTEGER
          The number of blocks in the first block row of T.
          0 <= N <= M*K / L.

  RB      (input) INTEGER
          If JOB = 'O' or 'A', the number of columns in B.  RB >= 0.

  RC      (input) INTEGER
          If JOB = 'U' or 'A', the number of columns in C.  RC >= 0.

  TC      (input)  DOUBLE PRECISION array, dimension (LDTC,L)
          On entry, the leading M*K-by-L part of this array must
          contain the first block column of T.

  LDTC    INTEGER
          The leading dimension of the array TC.  LDTC >= MAX(1,M*K)

  TR      (input)  DOUBLE PRECISION array, dimension (LDTR,(N-1)*L)
          On entry, the leading K-by-(N-1)*L part of this array must
          contain the 2nd to the N-th blocks of the first block row
          of T.

  LDTR    INTEGER
          The leading dimension of the array TR.  LDTR >= MAX(1,K).

  B       (input/output)  DOUBLE PRECISION array, dimension (LDB,RB)
          On entry, if JOB = 'O' or JOB = 'A', the leading M*K-by-RB
          part of this array must contain the right hand side
          matrix B of the overdetermined system (1).
          On exit, if JOB = 'O' or JOB = 'A', the leading N*L-by-RB
          part of this array contains the solution of the
          overdetermined system (1).
          This array is not referenced if JOB = 'U'.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,M*K),  if JOB = 'O'  or  JOB = 'A';
          LDB >= 1,           if JOB = 'U'.

  C       (input)  DOUBLE PRECISION array, dimension (LDC,RC)
          On entry, if JOB = 'U' or JOB = 'A', the leading N*L-by-RC
          part of this array must contain the right hand side
          matrix C of the underdetermined system (2).
          On exit, if JOB = 'U' or JOB = 'A', the leading M*K-by-RC
          part of this array contains the solution of the
          underdetermined system (2).
          This array is not referenced if JOB = 'O'.

  LDC     INTEGER
          The leading dimension of the array C.
          LDB >= 1,           if JOB = 'O';
          LDB >= MAX(1,M*K),  if JOB = 'U'  or  JOB = 'A'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -17,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          Let x = MAX( 2*N*L*(L+K) + (6+N)*L,(N*L+M*K+1)*L + M*K )
          and y = N*M*K*L + N*L, then
          if MIN( M,N ) = 1 and JOB = 'O',
                      LDWORK >= MAX( y + MAX( M*K,RB ),1 );
          if MIN( M,N ) = 1 and JOB = 'U',
                      LDWORK >= MAX( y + MAX( M*K,RC ),1 );
          if MIN( M,N ) = 1 and JOB = 'A',
                      LDWORK >= MAX( y +MAX( M*K,MAX( RB,RC ),1 );
          if MIN( M,N ) > 1 and JOB = 'O',
                      LDWORK >= MAX( x,N*L*RB + 1 );
          if MIN( M,N ) > 1 and JOB = 'U',
                      LDWORK >= MAX( x,N*L*RC + 1 );
          if MIN( M,N ) > 1 and JOB = 'A',
                      LDWORK >= MAX( x,N*L*MAX( RB,RC ) + 1 ).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction algorithm failed. The Toeplitz matrix
                associated with T is (numerically) not of full rank.
Method 
  Householder transformations and modified hyperbolic rotations
  are used in the Schur algorithm [1], [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The algorithm requires O( L*L*K*(N+M)*log(N+M) + N*N*L*L*(L+K) )
  and additionally

  if JOB = 'O' or JOB = 'A',
               O( (K*L+RB*L+K*RB)*(N+M)*log(N+M) + N*N*L*L*RB );
  if JOB = 'U' or JOB = 'A',
               O( (K*L+RC*L+K*RC)*(N+M)*log(N+M) + N*N*L*L*RC );

  floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02ID EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, LMAX, MMAX, NMAX, RBMAX, RCMAX
      PARAMETER        ( KMAX  = 20, LMAX  = 20, MMAX = 20, NMAX = 20,
     $                   RBMAX = 20, RCMAX = 20 )
      INTEGER          LDB, LDC, LDTC, LDTR, LDWORK
      PARAMETER        ( LDB  = KMAX*MMAX, LDC  = KMAX*MMAX,
     $                   LDTC = MMAX*KMAX, LDTR = KMAX,
     $                   LDWORK = 2*NMAX*LMAX*( LMAX + KMAX ) +
     $                            ( 6 + NMAX )*LMAX +
     $                            MMAX*KMAX*( LMAX + 1 ) +
     $                            RBMAX + RCMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, L, M, N, RB, RC
      CHARACTER        JOB
      DOUBLE PRECISION B(LDB,RBMAX),  C(LDC,RCMAX), DWORK(LDWORK),
     $                 TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02ID
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  K, L, M, N, RB, RC, JOB
      IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) K
      ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) L
      ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) M
      ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE IF ( ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) )
     $          .AND. ( ( RB.LE.0 ) .OR. ( RB.GT.RBMAX ) ) ) THEN
         WRITE ( NOUT, FMT = 99990 ) RB
      ELSE IF ( ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) )
     $          .AND. ( ( RC.LE.0 ) .OR. ( RC.GT.RCMAX ) ) ) THEN
         WRITE ( NOUT, FMT = 99989 ) RC
      ELSE
         READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K )
         READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,(N-1)*L ), I = 1,K )
         IF ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) THEN
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,RB ), I = 1,M*K )
         END IF
         IF ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) THEN
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,RC ), I = 1,N*L )
         END IF
         CALL MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B,
     $                LDB, C, LDC, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 10  I = 1, N*L
                  WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, RB )
   10          CONTINUE
            END IF
            IF ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99996 )
               DO 20  I = 1, M*K
                  WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, RC )
   20          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02ID EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02ID = ',I2)
99997 FORMAT (' The least squares solution of T * X = B is ')
99996 FORMAT (' The minimum norm solution of T^T * X = C is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' K is out of range.',/' K = ',I5)
99993 FORMAT (/' L is out of range.',/' L = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' RB is out of range.',/' RB = ',I5)
99989 FORMAT (/' RC is out of range.',/' RC = ',I5)
      END
Program Data 
MB02ID EXAMPLE PROGRAM DATA
   3   2   4   3   1   1   A
     5.0     2.0
     1.0     2.0
     4.0     3.0
     4.0     0.0
     2.0     2.0
     3.0     3.0
     5.0     1.0
     3.0     3.0
     1.0     1.0
     2.0     3.0
     1.0     3.0
     2.0     2.0
     1.0     4.0     2.0     3.0
     2.0     2.0     2.0     4.0
     3.0     1.0     0.0     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
     1.0
Program Results 
 MB02ID EXAMPLE PROGRAM RESULTS

 The least squares solution of T * X = B is 
   0.0379
   0.1677
   0.0485
  -0.0038
   0.0429
   0.1365
 The minimum norm solution of T^T * X = C is 
   0.0509
   0.0547
   0.0218
   0.0008
   0.0436
   0.0404
   0.0031
   0.0451
   0.0421
   0.0243
   0.0556
   0.0472

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02JD.html000077500000000000000000000300431201767322700160620ustar00rootroot00000000000000 MB02JD - SLICOT Library Routine Documentation

MB02JD

Full QR factorization of a block Toeplitz matrix of full rank

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a lower triangular matrix R and a matrix Q with
  Q^T Q = I such that
                                 T
                        T  =  Q R ,

  where T is a K*M-by-L*N block Toeplitz matrix with blocks of size
  (K,L). The first column of T will be denoted by TC and the first
  row by TR. It is assumed that the first MIN(M*K, N*L) columns of T
  have full rank.

  By subsequent calls of this routine the factors Q and R can be
  computed block column by block column.
Specification 
      SUBROUTINE MB02JD( JOB, K, L, M, N, P, S, TC, LDTC, TR, LDTR, Q,
     $                   LDQ, R, LDR, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the output of the routine as follows:
          = 'Q':  computes Q and R;
          = 'R':  only computes R.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows in one block of T.  K >= 0.

  L       (input)  INTEGER
          The number of columns in one block of T.  L >= 0.

  M       (input)  INTEGER
          The number of blocks in one block column of T.  M >= 0.

  N       (input)  INTEGER
          The number of blocks in one block row of T.  N >= 0.

  P       (input)  INTEGER
          The number of previously computed block columns of R.
          P*L < MIN( M*K,N*L ) + L and P >= 0.

  S       (input)  INTEGER
          The number of block columns of R to compute.
          (P+S)*L < MIN( M*K,N*L ) + L and S >= 0.

  TC      (input) DOUBLE PRECISION array, dimension (LDTC, L)
          On entry, if P = 0, the leading M*K-by-L part of this
          array must contain the first block column of T.

  LDTC    INTEGER
          The leading dimension of the array TC.
          LDTC >= MAX(1,M*K).

  TR      (input)  DOUBLE PRECISION array, dimension (LDTR,(N-1)*L)
          On entry, if P = 0, the leading K-by-(N-1)*L part of this
          array must contain the first block row of T without the
          leading K-by-L block.

  LDTR    INTEGER
          The leading dimension of the array TR.
          LDTR >= MAX(1,K).

  Q       (input/output)  DOUBLE PRECISION array, dimension
                          (LDQ,MIN( S*L, MIN( M*K,N*L )-P*L ))
          On entry, if JOB = 'Q'  and  P > 0, the leading M*K-by-L
          part of this array must contain the last block column of Q
          from a previous call of this routine.
          On exit, if JOB = 'Q'  and  INFO = 0, the leading
          M*K-by-MIN( S*L, MIN( M*K,N*L )-P*L ) part of this array
          contains the P-th to (P+S)-th block columns of the factor
          Q.

  LDQ     INTEGER
          The leading dimension of the array Q.
          LDQ >= MAX(1,M*K), if JOB = 'Q';
          LDQ >= 1,          if JOB = 'R'.

  R       (input/output)  DOUBLE PRECISION array, dimension
                          (LDR,MIN( S*L, MIN( M*K,N*L )-P*L ))
          On entry, if P > 0, the leading (N-P+1)*L-by-L
          part of this array must contain the nozero part of the
          last block column of R from a previous call of this
          routine.
          One exit, if INFO = 0, the leading
          MIN( N, N-P+1 )*L-by-MIN( S*L, MIN( M*K,N*L )-P*L )
          part of this array contains the nonzero parts of the P-th
          to (P+S)-th block columns of the lower triangular
          factor R.
          Note that elements in the strictly upper triangular part
          will not be referenced.

  LDR     INTEGER
          The leading dimension of the array R.
          LDR >= MAX( 1, MIN( N, N-P+1 )*L )
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.
          On exit, if INFO = -17,  DWORK(1) returns the minimum
          value of LDWORK.
          If JOB = 'Q', the first 1 + ( (N-1)*L + M*K )*( 2*K + L )
          elements of DWORK should be preserved during successive
          calls of the routine.
          If JOB = 'R', the first 1 + (N-1)*L*( 2*K + L ) elements
          of DWORK should be preserved during successive calls of
          the routine.

  LDWORK  INTEGER
          The length of the array DWORK.
          JOB = 'Q':
             LDWORK >= 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L
                         + MAX( M*K,( N - MAX( 1,P )*L ) );
          JOB = 'R':
             If P = 0,
                LDWORK >= MAX( 1 + ( N - 1 )*L*( L + 2*K ) + 6*L
                                 + (N-1)*L, M*K*( L + 1 ) + L );
             If P > 0,
                LDWORK >= 1 + (N-1)*L*( L + 2*K ) + 6*L + (N-P)*L.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the full rank condition for the first MIN(M*K, N*L)
                columns of T is (numerically) violated.
Method 
  Block Householder transformations and modified hyperbolic
  rotations are used in the Schur algorithm [1], [2].
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The implemented method yields a factor R which has comparable
  accuracy with the Cholesky factor of T^T * T. Q is implicitly
  computed from the formula Q = T * inv(R^T R) * R, i.e., for ill
  conditioned problems this factor is of very limited value.
                              2
  The algorithm requires 0(K*L *M*N) floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02JD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, LMAX, MMAX, NMAX
      PARAMETER        ( KMAX = 10, LMAX = 10, MMAX = 20, NMAX = 20 )
      INTEGER          LDR, LDQ, LDTC, LDTR, LDWORK
      PARAMETER        ( LDR  = NMAX*LMAX, LDQ  = MMAX*KMAX,
     $                   LDTC = MMAX*KMAX, LDTR = KMAX,
     $                   LDWORK = ( MMAX*KMAX + NMAX*LMAX )
     $                            *( LMAX + 2*KMAX ) + 6*LMAX
     $                            + MMAX*KMAX + NMAX*LMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, L, M, N, S
      CHARACTER        JOB
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,NMAX*LMAX),
     $                 R(LDR,NMAX*LMAX), TC(LDTC,LMAX),
     $                 TR(LDTR,NMAX*LMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02JD
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K, L, M, N, JOB
      IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) K
      ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) L
      ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) M
      ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K )
         READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,( N - 1 )*L ),
     $                             I = 1,K )
         S = ( MIN( M*K, N*L ) + L - 1 ) / L
*        Compute the required part of the QR factorization.
         CALL MB02JD( JOB, K, L, M, N, 0, S, TC, LDTC, TR, LDTR, Q, LDQ,
     $                R, LDR, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( JOB, 'Q' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 10  I = 1, M*K
                  WRITE ( NOUT, FMT = 99995 )
     $                  ( Q(I,J), J = 1, MIN( N*L, M*K ) )
   10          CONTINUE
            END IF
            WRITE ( NOUT, FMT = 99996 )
            DO 20  I = 1, N*L
               WRITE ( NOUT, FMT = 99995 )
     $               ( R(I,J), J = 1, MIN( N*L, M*K ) )
   20       CONTINUE
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB02JD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02JD = ',I2)
99997 FORMAT (/' The factor Q is ')
99996 FORMAT (/' The factor R is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' K is out of range.',/' K = ',I5)
99993 FORMAT (/' L is out of range.',/' L = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
MB02JD EXAMPLE PROGRAM DATA
    2   3    4    3    Q
     1.0     4.0     0.0
     4.0     1.0     2.0
     4.0     2.0     2.0
     5.0     3.0     2.0
     2.0     4.0     4.0
     5.0     3.0     4.0
     2.0     2.0     5.0
     4.0     2.0     3.0
     3.0     4.0     2.0     5.0     0.0     4.0
     5.0     1.0     1.0     2.0     4.0     1.0
Program Results 
 MB02JD EXAMPLE PROGRAM RESULTS


 The factor Q is 
  -0.0967   0.7166  -0.4651   0.1272   0.4357   0.0435   0.2201   0.0673
  -0.3867  -0.3108  -0.0534   0.5251   0.0963  -0.3894   0.1466   0.5412
  -0.3867  -0.0990  -0.1443  -0.7021   0.3056  -0.3367  -0.3233   0.1249
  -0.4834  -0.0178  -0.3368  -0.1763  -0.5446   0.5100   0.1503   0.2054
  -0.1933   0.5859   0.3214   0.1156  -0.4670  -0.3199  -0.4185   0.0842
  -0.4834  -0.0178   0.1072   0.0357  -0.0575  -0.2859   0.4339  -0.6928
  -0.1933   0.1623   0.7251  -0.1966   0.2736   0.3058   0.3398   0.2968
  -0.3867  -0.0990   0.0777   0.3615   0.3386   0.4421  -0.5693  -0.2641

 The factor R is 
 -10.3441   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -6.3805   4.7212   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -7.3472   1.9320   4.5040   0.0000   0.0000   0.0000   0.0000   0.0000
 -10.0541   2.5101   0.5065   3.6550   0.0000   0.0000   0.0000   0.0000
  -6.5738   3.6127   1.2702  -1.3146   3.5202   0.0000   0.0000   0.0000
  -5.2204   2.4764   2.4113   1.3890   1.2780   2.4976   0.0000   0.0000
  -9.6674   3.2445  -0.5099  -0.0224   2.6548   2.9491   1.0049   0.0000
  -6.3805   0.6968   1.9483   0.3050   0.7002  -2.0220  -2.8246   2.3147
  -4.1570   2.4309  -0.7190  -0.1455   3.0149   0.5454   0.9394  -0.0548

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02JX.html000077500000000000000000000326731201767322700161210ustar00rootroot00000000000000 MB02JX - SLICOT Library Routine Documentation

MB02JX

Low rank QR factorization with column pivoting of a block Toeplitz matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a low rank QR factorization with column pivoting of a
  K*M-by-L*N block Toeplitz matrix T with blocks of size (K,L);
  specifically,
                                  T
                        T P =  Q R ,

  where R is lower trapezoidal, P is a block permutation matrix
  and Q^T Q = I. The number of columns in R is equivalent to the
  numerical rank of T with respect to the given tolerance TOL1.
  Note that the pivoting scheme is local, i.e., only columns
  belonging to the same block in T are permuted.
Specification 
      SUBROUTINE MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q,
     $                   LDQ, R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the output of the routine as follows:
          = 'Q':  computes Q and R;
          = 'R':  only computes R.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of rows in one block of T.  K >= 0.

  L       (input)  INTEGER
          The number of columns in one block of T.  L >= 0.

  M       (input)  INTEGER
          The number of blocks in one block column of T.  M >= 0.

  N       (input)  INTEGER
          The number of blocks in one block row of T.  N >= 0.

  TC      (input) DOUBLE PRECISION array, dimension (LDTC, L)
          The leading M*K-by-L part of this array must contain
          the first block column of T.

  LDTC    INTEGER
          The leading dimension of the array TC.
          LDTC >= MAX(1,M*K).

  TR      (input)  DOUBLE PRECISION array, dimension (LDTR,(N-1)*L)
          The leading K-by-(N-1)*L part of this array must contain
          the first block row of T without the leading K-by-L
          block.

  LDTR    INTEGER
          The leading dimension of the array TR.  LDTR >= MAX(1,K).

  RNK     (output)  INTEGER
          The number of columns in R, which is equivalent to the
          numerical rank of T.

  Q       (output)  DOUBLE PRECISION array, dimension (LDQ,RNK)
          If JOB = 'Q', then the leading M*K-by-RNK part of this
          array contains the factor Q.
          If JOB = 'R', then this array is not referenced.

  LDQ     INTEGER
          The leading dimension of the array Q.
          LDQ >= MAX(1,M*K),  if JOB = 'Q';
          LDQ >= 1,           if JOB = 'R'.

  R       (output)  DOUBLE PRECISION array, dimension (LDR,RNK)
          The leading N*L-by-RNK part of this array contains the
          lower trapezoidal factor R.

  LDR     INTEGER
          The leading dimension of the array R.
          LDR >= MAX(1,N*L)

  JPVT    (output)  INTEGER array, dimension (MIN(M*K,N*L))
          This array records the column pivoting performed.
          If JPVT(j) = k, then the j-th column of T*P was
          the k-th column of T.
Tolerances 
  TOL1    DOUBLE PRECISION
          If TOL1 >= 0.0, the user supplied diagonal tolerance;
          if TOL1 < 0.0, a default diagonal tolerance is used.

  TOL2    DOUBLE PRECISION
          If TOL2 >= 0.0, the user supplied offdiagonal tolerance;
          if TOL2 < 0.0, a default offdiagonal tolerance is used.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK;  DWORK(2) and DWORK(3) return the used values
          for TOL1 and TOL2, respectively.
          On exit, if INFO = -19,  DWORK(1) returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L
                              + MAX(M*K,(N-1)*L) ),    if JOB = 'Q';
          LDWORK >= MAX( 3, ( N - 1 )*L*( L + 2*K + 1 ) + 9*L,
                              M*K*( L + 1 ) + L ),     if JOB = 'R'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  due to perturbations induced by roundoff errors, or
                removal of nearly linearly dependent columns of the
                generator, the Schur algorithm encountered a
                situation where a diagonal element in the negative
                generator is larger in magnitude than the
                corresponding diagonal element in the positive
                generator (modulo TOL1);
          = 2:  due to perturbations induced by roundoff errors, or
                removal of nearly linearly dependent columns of the
                generator, the Schur algorithm encountered a
                situation where diagonal elements in the positive
                and negative generator are equal in magnitude
                (modulo TOL1), but the offdiagonal elements suggest
                that these columns are not linearly dependent
                (modulo TOL2*ABS(diagonal element)).
Method 
  Householder transformations and modified hyperbolic rotations
  are used in the Schur algorithm [1], [2].
  If, during the process, the hyperbolic norm of a row in the
  leading part of the generator is found to be less than or equal
  to TOL1, then this row is not reduced. If the difference of the
  corresponding columns has a norm less than or equal to TOL2 times
  the magnitude of the leading element, then this column is removed
  from the generator, as well as from R. Otherwise, the algorithm
  breaks down. TOL1 is set to norm(TC)*sqrt(eps) and TOL2 is set
  to N*L*sqrt(eps) by default.
  If M*K > L, the columns of T are permuted so that the diagonal
  elements in one block column of R have decreasing magnitudes.
References 
  [1] Kailath, T. and Sayed, A.
      Fast Reliable Algorithms for Matrices with Structure.
      SIAM Publications, Philadelphia, 1999.

  [2] Kressner, D. and Van Dooren, P.
      Factorizations and linear system solvers for matrices with
      Toeplitz structure.
      SLICOT Working Note 2000-2, 2000.
Numerical Aspects 
  The algorithm requires 0(K*RNK*L*M*N) floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02JX EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, LMAX, MMAX, NMAX
      PARAMETER        ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20 )
      INTEGER          LDR, LDQ, LDTC, LDTR, LDWORK
      PARAMETER        ( LDR  = NMAX*LMAX, LDQ  = MMAX*KMAX,
     $                   LDTC = MMAX*KMAX, LDTR = KMAX,
     $                   LDWORK = ( MMAX*KMAX + NMAX*LMAX )
     $                            *( LMAX + 2*KMAX ) + 5*LMAX
     $                            + MMAX*KMAX + NMAX*LMAX )
*     .. Local Scalars ..
      CHARACTER        JOB
      INTEGER          I, INFO, J, K, L, M, N, RNK
      DOUBLE PRECISION TOL1, TOL2
*     .. Local Arrays ..
      INTEGER          JPVT(NMAX*LMAX)
      DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,NMAX*LMAX),
     $                 R(LDR,NMAX*LMAX), TC(LDTC,LMAX),
     $                 TR(LDTR,NMAX*LMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02JX
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K, L, M, N, TOL1, TOL2, JOB
      IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) K
      ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) L
      ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K )
         READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,( N - 1 )*L ),
     $                             I = 1,K )
*        Compute the required part of the QR factorization.
         CALL MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, LDQ,
     $                R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99994 ) RNK
            IF ( LSAME( JOB, 'Q' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 10  I = 1, M*K
                  WRITE ( NOUT, FMT = 99993 ) ( Q(I,J), J = 1, RNK )
   10          CONTINUE
            END IF
            WRITE ( NOUT, FMT = 99996 )
            DO 20  I = 1, N*L
               WRITE ( NOUT, FMT = 99993 ) ( R(I,J), J = 1, RNK )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            WRITE ( NOUT, FMT = 99992 ) ( JPVT(I),
     $                                    I = 1, MIN( M*K, N*L ) )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02JX EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02JX = ',I2)
99997 FORMAT (/' The factor Q is ')
99996 FORMAT (/' The factor R is ')
99995 FORMAT (/' The column permutation is ')
99994 FORMAT (/' Numerical rank ',/' RNK = ',I5)
99993 FORMAT (20(1X,F8.4))
99992 FORMAT (20(1X,I4))
99991 FORMAT (/' K is out of range.',/' K = ',I5)
99990 FORMAT (/' L is out of range.',/' L = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
MB02JX EXAMPLE PROGRAM DATA
   3   3   4   4  -1.0D0  -1.0D0   Q
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     2.0     3.0
     1.0     0.0     1.0
     1.0     1.0     0.0
     2.0     2.0     0.0
     1.0     2.0     3.0     1.0     2.0     3.0     0.0     1.0     1.0
     1.0     2.0     3.0     1.0     2.0     3.0     1.0     2.0     1.0
     1.0     2.0     3.0     1.0     2.0     3.0     1.0     1.0     1.0
     1.0     2.0     3.0     1.0     2.0     3.0     0.0     1.0     0.0
Program Results 
 MB02JX EXAMPLE PROGRAM RESULTS


 Numerical rank 
 RNK =     7

 The factor Q is 
  -0.3313  -0.0105  -0.0353   0.0000  -0.4714  -0.8165   0.0000
  -0.3313  -0.0105  -0.0353   0.0000  -0.4714   0.4082   0.7071
  -0.3313  -0.0105  -0.0353   0.0000  -0.4714   0.4082  -0.7071
  -0.3313  -0.0105  -0.0353   0.0000   0.2357   0.0000   0.0000
  -0.3313  -0.0105  -0.0353   0.0000   0.2357   0.0000   0.0000
  -0.3313  -0.0105  -0.0353   0.0000   0.2357   0.0000   0.0000
  -0.3313  -0.0105  -0.0353   0.0000   0.2357   0.0000   0.0000
  -0.3313  -0.0105  -0.0353   0.0000   0.2357   0.0000   0.0000
  -0.3313  -0.0105  -0.0353   0.0000   0.2357   0.0000   0.0000
  -0.1104   0.2824   0.9529   0.0000   0.0000   0.0000   0.0000
   0.0000   0.4288  -0.1271   0.8944   0.0000   0.0000   0.0000
   0.0000   0.8576  -0.2541  -0.4472   0.0000   0.0000   0.0000

 The factor R is 
  -9.0554   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -3.0921   2.3322   0.0000   0.0000   0.0000   0.0000   0.0000
  -5.9633   1.9557  -1.2706   0.0000   0.0000   0.0000   0.0000
  -9.2762   4.4238   0.7623   1.3416   0.0000   0.0000   0.0000
  -6.1842   2.9492   0.5082   0.8944   0.0000   0.0000   0.0000
  -3.0921   1.4746   0.2541   0.4472   0.0000   0.0000   0.0000
  -9.2762   4.4238   0.7623   1.3416   0.0000   0.0000   0.0000
  -6.1842   2.9492   0.5082   0.8944   0.0000   0.0000   0.0000
  -3.0921   1.4746   0.2541   0.4472   0.0000   0.0000   0.0000
  -7.2885   4.4866   0.9741   1.3416   2.8284   0.0000   0.0000
  -2.7608   1.4851   0.2894   0.4472   0.4714   0.8165   0.0000
  -5.5216   2.9701   0.5788   0.8944   0.9428   0.4082   0.7071

 The column permutation is 
    3    1    2    6    5    4    9    8    7   12   10   11

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02KD.html000077500000000000000000000261721201767322700160730ustar00rootroot00000000000000 MB02KD - SLICOT Library Routine Documentation

MB02KD

Computation of the product C = alpha op( T ) B + beta C, with T a block Toeplitz matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix product

            C = alpha*op( T )*B + beta*C,

  where alpha and beta are scalars and T is a block Toeplitz matrix
  specified by its first block column TC and first block row TR;
  B and C are general matrices of appropriate dimensions.
Specification 
      SUBROUTINE MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA,
     $                   TC, LDTC, TR, LDTR, B, LDB, C, LDC, DWORK,
     $                   LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  LDBLK   CHARACTER*1
          Specifies where the (1,1)-block of T is stored, as
          follows:
          = 'C':  in the first block of TC;
          = 'R':  in the first block of TR.

  TRANS   CHARACTER*1
          Specifies the form of op( T ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( T ) = T;
          = 'T':  op( T ) = T';
          = 'C':  op( T ) = T'.
Input/Output Parameters 
  K       (input) INTEGER
          The number of rows in the blocks of T.  K >= 0.

  L       (input) INTEGER
          The number of columns in the blocks of T.  L >= 0.

  M       (input) INTEGER
          The number of blocks in the first block column of T.
          M >= 0.

  N       (input) INTEGER
          The number of blocks in the first block row of T.  N >= 0.

  R       (input) INTEGER
          The number of columns in B and C.  R >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then TC, TR and B
          are not referenced.

  BETA    (input) DOUBLE PRECISION
          The scalar beta. When beta is zero then C need not be set
          before entry.

  TC      (input)  DOUBLE PRECISION array, dimension (LDTC,L)
          On entry with LDBLK = 'C', the leading M*K-by-L part of
          this array must contain the first block column of T.
          On entry with LDBLK = 'R', the leading (M-1)*K-by-L part
          of this array must contain the 2nd to the M-th blocks of
          the first block column of T.

  LDTC    INTEGER
          The leading dimension of the array TC.
          LDTC >= MAX(1,M*K),      if LDBLK = 'C';
          LDTC >= MAX(1,(M-1)*K),  if LDBLK = 'R'.

  TR      (input)  DOUBLE PRECISION array, dimension (LDTR,k)
          where k is (N-1)*L when LDBLK = 'C' and is N*L when
          LDBLK = 'R'.
          On entry with LDBLK = 'C', the leading K-by-(N-1)*L part
          of this array must contain the 2nd to the N-th blocks of
          the first block row of T.
          On entry with LDBLK = 'R', the leading K-by-N*L part of
          this array must contain the first block row of T.

  LDTR    INTEGER
          The leading dimension of the array TR.  LDTR >= MAX(1,K).

  B       (input)  DOUBLE PRECISION array, dimension (LDB,R)
          On entry with TRANS = 'N', the leading N*L-by-R part of
          this array must contain the matrix B.
          On entry with TRANS = 'T' or TRANS = 'C', the leading
          M*K-by-R part of this array must contain the matrix B.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N*L),  if TRANS = 'N';
          LDB >= MAX(1,M*K),  if TRANS = 'T' or TRANS = 'C'.

  C       (input/output)  DOUBLE PRECISION array, dimension (LDC,R)
          On entry with TRANS = 'N', the leading M*K-by-R part of
          this array must contain the matrix C.
          On entry with TRANS = 'T' or TRANS = 'C', the leading
          N*L-by-R part of this array must contain the matrix C.
          On exit with TRANS = 'N', the leading M*K-by-R part of
          this array contains the updated matrix C.
          On exit with TRANS = 'T' or TRANS = 'C', the leading
          N*L-by-R part of this array contains the updated matrix C.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= MAX(1,M*K),  if TRANS = 'N';
          LDC >= MAX(1,N*L),  if TRANS = 'T' or TRANS = 'C'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -19,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 1.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  For point Toeplitz matrices or sufficiently large block Toeplitz
  matrices, this algorithm uses convolution algorithms based on
  the fast Hartley transforms [1]. Otherwise, TC is copied in
  reversed order into the workspace such that C can be computed from
  barely M matrix-by-matrix multiplications.
References 
  [1] Van Loan, Charles.
      Computational frameworks for the fast Fourier transform.
      SIAM, 1992.
Numerical Aspects 
  The algorithm requires O( (K*L+R*L+K*R)*(N+M)*log(N+M) + K*L*R )
  floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB02KD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, LMAX, MMAX, NMAX, RMAX
      PARAMETER        ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20,
     $                   RMAX = 20 )
      INTEGER          LDB, LDC, LDTC, LDTR, LDWORK
      PARAMETER        ( LDB  = LMAX*NMAX, LDC  = KMAX*MMAX,
     $                   LDTC = MMAX*KMAX, LDTR = KMAX,
     $                   LDWORK = 2*( KMAX*LMAX + KMAX*RMAX
     $                            + LMAX*RMAX + 1 )*( MMAX + NMAX ) )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, L, M, N, R
      CHARACTER        LDBLK, TRANS
      DOUBLE PRECISION ALPHA, BETA
*     .. Local Arrays .. (Dimensioned for TRANS = 'N'.)
      DOUBLE PRECISION B(LDB,RMAX), C(LDC,RMAX), DWORK(LDWORK),
     $                 TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02KD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  K, L, M, N, R, LDBLK, TRANS
      IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) K
      ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) L
      ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) M
      ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE IF( R.LE.0 .OR. R.GT.RMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         IF ( LSAME( LDBLK, 'R' ) ) THEN
            READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ),
     $                              I = 1,(M-1)*K )
            READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,N*L ), I = 1,K )
         ELSE
            READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K )
            READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,(N-1)*L ),
     $                              I = 1,K )
         END IF
         IF ( LSAME( TRANS, 'N' ) ) THEN
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,R ), I = 1,N*L )
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,R ), I = 1,M*K )
         END IF
         ALPHA = ONE
         BETA  = ZERO
         CALL MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, TC,
     $                LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, LDWORK,
     $                INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( TRANS, 'N' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 10  I = 1, M*K
                  WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,R )
   10          CONTINUE
            ELSE
               WRITE ( NOUT, FMT = 99996 )
               DO 20  I = 1, N*L
                  WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,R )
   20          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02KD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02KD = ',I2)
99997 FORMAT (' The product C = T * B is ')
99996 FORMAT (' The product C = T^T * B is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' K is out of range.',/' K = ',I5)
99993 FORMAT (/' L is out of range.',/' L = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' R is out of range.',/' R = ',I5)
      END
Program Data 
MB02KD EXAMPLE PROGRAM DATA
   3    2   4    5    1    C    N
     4.0     1.0
     3.0     5.0
     2.0     1.0
     4.0     1.0
     3.0     4.0
     2.0     4.0
     3.0     1.0
     3.0     0.0
     4.0     4.0
     5.0     1.0
     3.0     1.0
     4.0     3.0
     5.0     2.0     2.0     2.0     2.0     1.0     1.0     3.0
     4.0     1.0     5.0     4.0     5.0     4.0     1.0     2.0
     2.0     3.0     4.0     1.0     3.0     3.0     3.0     3.0
     0.0
     2.0
     2.0
     2.0
     1.0
     3.0
     3.0
     4.0
     2.0
     3.0
Program Results 
 MB02KD EXAMPLE PROGRAM RESULTS

 The product C = T * B is 
  45.0000
  76.0000
  55.0000
  44.0000
  84.0000
  56.0000
  52.0000
  70.0000
  54.0000
  49.0000
  63.0000
  59.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02MD.html000077500000000000000000000412571201767322700160760ustar00rootroot00000000000000 MB02MD - SLICOT Library Routine Documentation

MB02MD

Solution of Total Least-Squares problem using a SVD approach

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the Total Least Squares (TLS) problem using a Singular
  Value Decomposition (SVD) approach.
  The TLS problem assumes an overdetermined set of linear equations
  AX = B, where both the data matrix A as well as the observation
  matrix B are inaccurate. The routine also solves determined and
  underdetermined sets of equations by computing the minimum norm
  solution.
  It is assumed that all preprocessing measures (scaling, coordinate
  transformations, whitening, ... ) of the data have been performed
  in advance.
Specification 
      SUBROUTINE MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL,
     $                   IWORK, DWORK, LDWORK, IWARN, INFO )
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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Determines whether the values of the parameters RANK and
          TOL are to be specified by the user or computed by the
          routine as follows:
          = 'R':  Compute RANK only;
          = 'T':  Compute TOL only;
          = 'B':  Compute both RANK and TOL;
          = 'N':  Compute neither RANK nor TOL.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows in the data matrix A and the
          observation matrix B.  M >= 0.

  N       (input) INTEGER
          The number of columns in the data matrix A.  N >= 0.

  L       (input) INTEGER
          The number of columns in the observation matrix B.
          L >= 0.

  RANK    (input/output) INTEGER
          On entry, if JOB = 'T' or JOB = 'N', then RANK must
          specify r, the rank of the TLS approximation [A+DA|B+DB].
          RANK <= min(M,N).
          Otherwise, r is computed by the routine.
          On exit, if JOB = 'R' or JOB = 'B', and INFO = 0, then
          RANK contains the computed (effective) rank of the TLS
          approximation [A+DA|B+DB].
          Otherwise, the user-supplied value of RANK may be
          changed by the routine on exit if the RANK-th and the
          (RANK+1)-th singular values of C = [A|B] are considered
          to be equal, or if the upper triangular matrix F (as
          defined in METHOD) is (numerically) singular.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N+L)
          On entry, the leading M-by-(N+L) part of this array must
          contain the matrices A and B. Specifically, the first N
          columns must contain the data matrix A and the last L
          columns the observation matrix B (right-hand sides).
          On exit, the leading (N+L)-by-(N+L) part of this array
          contains the (transformed) right singular vectors,
          including null space vectors, if any, of C = [A|B].
          Specifically, the leading (N+L)-by-RANK part of this array
          always contains the first RANK right singular vectors,
          corresponding to the largest singular values of C. If
          L = 0, or if RANK = 0 and IWARN <> 2, the remaining
          (N+L)-by-(N+L-RANK) top-right part of this array contains
          the remaining N+L-RANK right singular vectors. Otherwise,
          this part contains the matrix V2 transformed as described
          in Step 3 of the TLS algorithm (see METHOD).

  LDC     INTEGER
          The leading dimension of array C.  LDC >= max(1,M,N+L).

  S       (output) DOUBLE PRECISION array, dimension (min(M,N+L))
          If INFO = 0, the singular values of matrix C, ordered
          such that S(1) >= S(2) >= ... >= S(p-1) >= S(p) >= 0,
          where p = min(M,N+L).

  X       (output) DOUBLE PRECISION array, dimension (LDX,L)
          If INFO = 0, the leading N-by-L part of this array
          contains the solution X to the TLS problem specified
          by A and B.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= max(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance used to determine the rank of the TLS
          approximation [A+DA|B+DB] and to check the multiplicity
          of the singular values of matrix C. Specifically, S(i)
          and S(j) (i < j) are considered to be equal if
          SQRT(S(i)**2 - S(j)**2) <= TOL, and the TLS approximation
          [A+DA|B+DB] has rank r if S(i) > TOL*S(1) (or S(i) > TOL,
          if TOL specifies sdev (see below)), for i = 1,2,...,r.
          TOL is also used to check the singularity of the upper
          triangular matrix F (as defined in METHOD).
          If JOB = 'R' or JOB = 'N', then TOL must specify the
          desired tolerance. If the user sets TOL to be less than or
          equal to 0, the tolerance is taken as EPS, where EPS is
          the machine precision (see LAPACK Library routine DLAMCH).
          Otherwise, the tolerance is computed by the routine and
          the user must supply the non-negative value sdev, i.e. the
          estimated standard deviation of the error on each element
          of the matrix C, as input value of TOL.
Workspace 
  IWORK   INTEGER array, dimension (L)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and DWORK(2) returns the reciprocal of the
          condition number of the matrix F.
          If INFO > 0, DWORK(1:min(M,N+L)-1) contain the unconverged
          non-diagonal elements of the bidiagonal matrix whose
          diagonal is in S (see LAPACK Library routine DGESVD).

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = max(2, 3*(N+L) + M, 5*(N+L)),       if M >= N+L;
          LDWORK = max(2, M*(N+L) + max( 3M+N+L, 5*M), 3*L),
                                                       if M <  N+L.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warnings;
          = 1:  if the rank of matrix C has been lowered because a
                singular value of multiplicity greater than 1 was
                found;
          = 2:  if the rank of matrix C has been lowered because the
                upper triangular matrix F is (numerically) singular.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if the SVD algorithm (in LAPACK Library routine
                DBDSQR) has failed to converge. In this case, S(1),
                S(2), ..., S(INFO) may not have been found
                correctly and the remaining singular values may
                not be the smallest. This failure is not likely
                to occur.
Method 
  The method used is an extension (see [3,4,5]) of the classical
  TLS algorithm proposed by Golub and Van Loan [1].

  Let [A|B] denote the matrix formed by adjoining the columns of B
  to the columns of A on the right.

  Total Least Squares (TLS) definition:
  -------------------------------------

    Given matrices A and B, find a matrix X satisfying

         (A + DA) X = B + DB,

    where A and DA are M-by-N matrices, B and DB are M-by-L matrices
    and X is an N-by-L matrix.
    The solution X must be such that the Frobenius norm of [DA|DB]
    is a minimum and each column of B + DB is in the range of
    A + DA. Whenever the solution is not unique, the routine singles
    out the minimum norm solution X.

  Define matrix C = [A|B] and s(i) as its i-th singular value for
  i = 1,2,...,min(M,NL), where NL = N + L. If M < NL, then s(j) = 0
  for j = M+1,...,NL.

  The Classical TLS algorithm proceeds as follows (see [3,4,5]):

  Step 1: Compute part of the singular value decomposition (SVD)
          USV' of C = [A|B], namely compute S and V'. (An initial
          QR factorization of C is used when M is larger enough
          than NL.)

  Step 2: If not fixed by the user, compute the rank r0 of the data
          [A|B] based on TOL as follows: if JOB = 'R' or JOB = 'N',

             s(1) >= ... >= s(r0) > TOL*s(1) >= ... >= s(NL).

          Otherwise, using [2], TOL can be computed from the
          standard deviation sdev of the errors on [A|B]:

             TOL = SQRT(2 * max(M,NL)) * sdev,

          and the rank r0 is determined (if JOB = 'R' or 'B') using

             s(1) >= ... >= s(r0) > TOL >= ... >= s(NL).

          The rank r of the approximation [A+DA|B+DB] is then equal
          to the minimum of N and r0.

  Step 3: Let V2 be the matrix of the columns of V corresponding to
          the (NL - r) smallest singular values of C, i.e. the last
          (NL - r) columns of V.
          Compute with Householder transformations the orthogonal
          matrix Q such that:

                    |VH   Y|
           V2 x Q = |      |
                    |0    F|

          where VH is an N-by-(N - r) matrix, Y is an N-by-L matrix
          and F is an L-by-L upper triangular matrix.
          If F is singular, then lower the rank r with the
          multiplicity of s(r) and repeat this step.

  Step 4: If F is nonsingular then the solution X is obtained by
          solving the following equations by forward elimination:

             X F = -Y.

  Notes :
  The TLS solution is unique if r = N, F is nonsingular and
  s(N) > s(N+1).
  If F is singular, however, then the computed solution is infinite
  and hence does not satisfy the second TLS criterion (see TLS
  definition). For these cases, Golub and Van Loan [1] claim that
  the TLS problem has no solution. The properties of these so-called
  nongeneric problems are described in [4] and the TLS computations
  are generalized in order to solve them. As proven in [4], the
  proposed generalization satisfies the TLS criteria for any
  number L of observation vectors in B provided that, in addition,
  the solution | X| is constrained to be orthogonal to all vectors
               |-I|
  of the form |w| which belong to the space generated by the columns
              |0|
  of the submatrix |Y|.
                   |F|
References 
  [1] Golub, G.H. and Van Loan, C.F.
      An Analysis of the Total Least-Squares Problem.
      SIAM J. Numer. Anal., 17, pp. 883-893, 1980.

  [2] Staar, J., Vandewalle, J. and Wemans, M.
      Realization of Truncated Impulse Response Sequences with
      Prescribed Uncertainty.
      Proc. 8th IFAC World Congress, Kyoto, I, pp. 7-12, 1981.

  [3] Van Huffel, S.
      Analysis of the Total Least Squares Problem and its Use in
      Parameter Estimation.
      Doctoral dissertation, Dept. of Electr. Eng., Katholieke
      Universiteit Leuven, Belgium, June 1987.

  [4] Van Huffel, S. and Vandewalle, J.
      Analysis and Solution of the Nongeneric Total Least Squares
      Problem.
      SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988.

  [5] Van Huffel, S. and Vandewalle, J.
      The Total Least Squares Problem: Computational Aspects and
      Analysis.
      Series "Frontiers in Applied Mathematics", Vol. 9,
      SIAM, Philadelphia, 1991.
Numerical Aspects 
  The algorithm consists in (backward) stable steps.
Further Comments 
  None
Example

Program Text 

*     MB02MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, LMAX
      PARAMETER        ( MMAX = 20, NMAX = 20, LMAX = 20 )
      INTEGER          LDC, LDX
      PARAMETER        ( LDC = MAX( MMAX,NMAX+LMAX ), LDX = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MMAX*(NMAX+LMAX) +
     $                            MAX( 3*MIN(MMAX,NMAX+LMAX) +
     $                                   MAX(MMAX,NMAX+LMAX),
     $                                 5*MIN(MMAX,NMAX+LMAX),
     $                                 3*LMAX ) )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = LMAX )
      INTEGER          LENGS
      PARAMETER        ( LENGS = MIN( MMAX, NMAX+LMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION SDEV, TOL
      INTEGER          I, INFO, IWARN, J, L, M, N, RANK
      CHARACTER*1      JOB
*     .. Local Arrays ..
      DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK), S(LENGS),
     $                 X(LDX,LMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, L, JOB
*
      IF ( LSAME( JOB, 'R' ) ) THEN
         READ ( NIN, FMT = * ) TOL
      ELSE IF ( LSAME( JOB, 'T' ) ) THEN
         READ ( NIN, FMT = * ) RANK, SDEV
         TOL = SDEV
      ELSE IF ( LSAME( JOB, 'N' ) ) THEN
         READ ( NIN, FMT = * ) RANK, TOL
      ELSE
         READ ( NIN, FMT = * ) SDEV
         TOL = SDEV
      END IF
*
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) L
      ELSE
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M )
*        Compute the solution to the TLS problem Ax = b.
         CALL MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, IWORK,
     $                DWORK, LDWORK, IWARN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) RANK
            ELSE
               IF ( ( LSAME( JOB, 'R' ) ) .OR. ( LSAME( JOB, 'B' ) ) )
     $            WRITE ( NOUT, FMT = 99996 ) RANK
            END IF
            WRITE ( NOUT, FMT = 99995 )
            DO 40 J = 1, L
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99994 ) X(I,J)
   20          CONTINUE
               IF ( J.LT.L ) WRITE ( NOUT, FMT = 99993 )
   40       CONTINUE
            WRITE ( NOUT, FMT = 99992 ) ( S(J),J = 1, MIN( M, N+L ) )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02MD = ',I2)
99997 FORMAT (' IWARN on exit from MB02MD = ',I2,/)
99996 FORMAT (' The computed rank of the TLS approximation = ',I3,/)
99995 FORMAT (' The solution X to the TLS problem is ',/)
99994 FORMAT (1X,F8.4)
99993 FORMAT (' ')
99992 FORMAT (/' The singular values of C are ',//(1X,F8.4))
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' M is out of range.',/' M = ',I5)
99989 FORMAT (/' L is out of range.',/' L = ',I5)
      END
Program Data 
 MB02MD EXAMPLE PROGRAM DATA
   6     3     1     B
   0.0
   0.80010  0.39985  0.60005  0.89999
   0.29996  0.69990  0.39997  0.82997
   0.49994  0.60003  0.20012  0.79011
   0.90013  0.20016  0.79995  0.85002
   0.39998  0.80006  0.49985  0.99016
   0.20002  0.90007  0.70009  1.02994
Program Results 
 MB02MD EXAMPLE PROGRAM RESULTS

 The computed rank of the TLS approximation =   3

 The solution X to the TLS problem is 

   0.5003
   0.8003
   0.2995

 The singular values of C are 

   3.2281
   0.8716
   0.3697
   0.0001

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02ND.html000077500000000000000000000552021201767322700160720ustar00rootroot00000000000000 MB02ND - SLICOT Library Routine Documentation

MB02ND

Solution of Total Least-Squares problem using a partial SVD approach

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the Total Least Squares (TLS) problem using a Partial
  Singular Value Decomposition (PSVD) approach.
  The TLS problem assumes an overdetermined set of linear equations
  AX = B, where both the data matrix A as well as the observation
  matrix B are inaccurate. The routine also solves determined and
  underdetermined sets of equations by computing the minimum norm
  solution.
  It is assumed that all preprocessing measures (scaling, coordinate
  transformations, whitening, ... ) of the data have been performed
  in advance.
Specification 
      SUBROUTINE MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL,
     $                   TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK,
     $                   IWARN, INFO )
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,*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows in the data matrix A and the
          observation matrix B.  M >= 0.

  N       (input) INTEGER
          The number of columns in the data matrix A.  N >= 0.

  L       (input) INTEGER
          The number of columns in the observation matrix B.
          L >= 0.

  RANK    (input/output) INTEGER
          On entry, if RANK < 0, then the rank of the TLS
          approximation [A+DA|B+DB] (r say) is computed by the
          routine.
          Otherwise, RANK must specify the value of r.
          RANK <= min(M,N).
          On exit, if RANK < 0 on entry and INFO = 0, then RANK
          contains the computed rank of the TLS approximation
          [A+DA|B+DB].
          Otherwise, the user-supplied value of RANK may be
          changed by the routine on exit if the RANK-th and the
          (RANK+1)-th singular values of C = [A|B] are considered
          to be equal, or if the upper triangular matrix F (as
          defined in METHOD) is (numerically) singular.

  THETA   (input/output) DOUBLE PRECISION
          On entry, if RANK < 0, then the rank of the TLS
          approximation [A+DA|B+DB] is computed using THETA as
          (min(M,N+L) - d), where d is the number of singular
          values of [A|B] <= THETA. THETA >= 0.0.
          Otherwise, THETA is an initial estimate (t say) for
          computing a lower bound on the RANK largest singular
          values of [A|B]. If THETA < 0.0 on entry however, then
          t is computed by the routine.
          On exit, if RANK >= 0 on entry, then THETA contains the
          computed bound such that precisely RANK singular values
          of C = [A|B] are greater than THETA + TOL.
          Otherwise, THETA is unchanged.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N+L)
          On entry, the leading M-by-(N+L) part of this array must
          contain the matrices A and B. Specifically, the first N
          columns must contain the data matrix A and the last L
          columns the observation matrix B (right-hand sides).
          On exit, if INFO = 0, the first N+L components of the
          columns of this array whose index i corresponds with
          INUL(i) = .TRUE., are the possibly transformed (N+L-RANK)
          base vectors of the right singular subspace corresponding
          to the singular values of C = [A|B] which are less than or
          equal to THETA. Specifically, if L = 0, or if RANK = 0 and
          IWARN <> 2, these vectors are indeed the base vectors
          above. Otherwise, these vectors form the matrix V2,
          transformed as described in Step 4 of the PTLS algorithm
          (see METHOD). The TLS solution is computed from these
          vectors. The other columns of array C contain no useful
          information.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= max(1,M,N+L).

  X       (output) DOUBLE PRECISION array, dimension (LDX,L)
          If INFO = 0, the leading N-by-L part of this array
          contains the solution X to the TLS problem specified by
          A and B.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= max(1,N).

  Q       (output) DOUBLE PRECISION array, dimension
          (max(1,2*min(M,N+L)-1))
          This array contains the partially diagonalized bidiagonal
          matrix J computed from C, at the moment that the desired
          singular subspace has been found. Specifically, the
          leading p = min(M,N+L) entries of Q contain the diagonal
          elements q(1),q(2),...,q(p) and the entries Q(p+1),Q(p+2),
          ...,Q(2*p-1) contain the superdiagonal elements e(1),e(2),
          ...,e(p-1) of J.

  INUL    (output) LOGICAL array, dimension (N+L)
          The indices of the elements of this array with value
          .TRUE. indicate the columns in C containing the base
          vectors of the right singular subspace of C from which
          the TLS solution has been computed.
Tolerances 
  TOL     DOUBLE PRECISION
          This parameter defines the multiplicity of singular values
          by considering all singular values within an interval of
          length TOL as coinciding. TOL is used in checking how many
          singular values are less than or equal to THETA. Also in
          computing an appropriate upper bound THETA by a bisection
          method, TOL is used as a stopping criterion defining the
          minimum (absolute) subinterval width. TOL is also taken
          as an absolute tolerance for negligible elements in the
          QR/QL iterations. If the user sets TOL to be less than or
          equal to 0, then the tolerance is taken as specified in
          SLICOT Library routine MB04YD document.

  RELTOL  DOUBLE PRECISION
          This parameter specifies the minimum relative width of an
          interval. When an interval is narrower than TOL, or than
          RELTOL times the larger (in magnitude) endpoint, then it
          is considered to be sufficiently small and bisection has
          converged. If the user sets RELTOL to be less than
          BASE * EPS, where BASE is machine radix and EPS is machine
          precision (see LAPACK Library routine DLAMCH), then the
          tolerance is taken as BASE * EPS.
Workspace 
  IWORK   INTEGER array, dimension (N+2*L)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and DWORK(2) returns the reciprocal of the
          condition number of the matrix F.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = max(2, max(M,N+L) + 2*min(M,N+L),
                       min(M,N+L) + LW + max(6*(N+L)-5,
                                             L*L+max(N+L,3*L)),
          where
          LW = (N+L)*(N+L-1)/2,  if M >= N+L,
          LW = M*(N+L-(M-1)/2),  if M <  N+L.
          For optimum performance LDWORK should be larger.

  BWORK   LOGICAL array, dimension (N+L)
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warnings;
          = 1:  if the rank of matrix C has been lowered because a
                singular value of multiplicity greater than 1 was
                found;
          = 2:  if the rank of matrix C has been lowered because the
                upper triangular matrix F is (numerically) singular.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the maximum number of QR/QL iteration steps
                (30*MIN(M,N)) has been exceeded;
          = 2:  if the computed rank of the TLS approximation
                [A+DA|B+DB] exceeds MIN(M,N). Try increasing the
                value of THETA or set the value of RANK to min(M,N).
Method 
  The method used is the Partial Total Least Squares (PTLS) approach
  proposed by Van Huffel and Vandewalle [5].

  Let C = [A|B] denote the matrix formed by adjoining the columns of
  B to the columns of A on the right.

  Total Least Squares (TLS) definition:
  -------------------------------------

    Given matrices A and B, find a matrix X satisfying

         (A + DA) X = B + DB,

    where A and DA are M-by-N matrices, B and DB are M-by-L matrices
    and X is an N-by-L matrix.
    The solution X must be such that the Frobenius norm of [DA|DB]
    is a minimum and each column of B + DB is in the range of
    A + DA. Whenever the solution is not unique, the routine singles
    out the minimum norm solution X.

  Let V denote the right singular subspace of C. Since the TLS
  solution can be computed from any orthogonal basis of the subspace
  of V corresponding to the smallest singular values of C, the
  Partial Singular Value Decomposition (PSVD) can be used instead of
  the classical SVD. The dimension of this subspace of V may be
  determined by the rank of C or by an upper bound for those
  smallest singular values.

  The PTLS algorithm proceeds as follows (see [2 - 5]):

  Step 1: Bidiagonalization phase
          -----------------------
   (a) If M is large enough than N + L, transform C into upper
       triangular form R by Householder transformations.
   (b) Transform C (or R) into upper bidiagonal form
       (p = min(M,N+L)):

                  |q(1) e(1)  0   ...  0   |
             (0)  | 0   q(2) e(2)      .   |
            J   = | .                  .   |
                  | .                e(p-1)|
                  | 0             ... q(p) |

       if M >= N + L, or lower bidiagonal form:

                  |q(1)  0    0   ...  0     0   |
             (0)  |e(1) q(2)  0        .     .   |
            J   = | .                  .     .   |
                  | .                 q(p)   .   |
                  | 0             ... e(p-1) q(p)|

       if M < N + L, using Householder transformations.
       In the second case, transform the matrix to the upper
       bidiagonal form by applying Givens rotations.
   (c) Initialize the right singular base matrix with the identity
       matrix.

  Step 2: Partial diagonalization phase
          -----------------------------
  If the upper bound THETA is not given, then compute THETA such
  that precisely p - RANK singular values (p=min(M,N+L)) of the
  bidiagonal matrix are less than or equal to THETA, using a
  bisection method [5]. Diagonalize the given bidiagonal matrix J
  partially, using either QL iterations (if the upper left diagonal
  element of the considered bidiagonal submatrix is smaller than the
  lower right diagonal element) or QR iterations, such that J is
  split into unreduced bidiagonal submatrices whose singular values
  are either all larger than THETA or are all less than or equal
  to THETA. Accumulate the Givens rotations in V.

  Step 3: Back transformation phase
          -------------------------
  Apply the Householder transformations of Step 1(b) onto the base
  vectors of V associated with the bidiagonal submatrices with all
  singular values less than or equal to THETA.

  Step 4: Computation of F and Y
          ----------------------
  Let V2 be the matrix of the columns of V corresponding to the
  (N + L - RANK) smallest singular values of C.
  Compute with Householder transformations the matrices F and Y
  such that:

                    |VH   Y|
           V2 x Q = |      |
                    |0    F|

  where Q is an orthogonal matrix, VH is an N-by-(N-RANK) matrix,
  Y is an N-by-L matrix and F is an L-by-L upper triangular matrix.
  If F is singular, then reduce the value of RANK by one and repeat
  Steps 2, 3 and 4.

  Step 5: Computation of the TLS solution
          -------------------------------
  If F is non-singular then the solution X is obtained by solving
  the following equations by forward elimination:

           X F = -Y.

  Notes:
  If RANK is lowered in Step 4, some additional base vectors must
  be computed in Step 2. The additional computations are kept to
  a minimum.
  If RANK is lowered in Step 4 but the multiplicity of the RANK-th
  singular value is larger than 1, then the value of RANK is further
  lowered with its multiplicity defined by the parameter TOL. This
  is done at the beginning of Step 2 by calling SLICOT Library
  routine MB03MD (from MB04YD), which estimates THETA using a
  bisection method. If F in Step 4 is singular, then the computed
  solution is infinite and hence does not satisfy the second TLS
  criterion (see TLS definition). For these cases, Golub and
  Van Loan [1] claim that the TLS problem has no solution. The
  properties of these so-called nongeneric problems are described
  in [6] and the TLS computations are generalized in order to solve
  them. As proven in [6], the proposed generalization satisfies the
  TLS criteria for any number L of observation vectors in B provided
  that, in addition, the solution | X| is constrained to be
                                  |-I|
  orthogonal to all vectors of the form |w| which belong to the
                                        |0|
  space generated by the columns of the submatrix |Y|.
                                                  |F|
References 
  [1] Golub, G.H. and Van Loan, C.F.
      An Analysis of the Total Least-Squares Problem.
      SIAM J. Numer. Anal., 17, pp. 883-893, 1980.

  [2] Van Huffel, S., Vandewalle, J. and Haegemans, A.
      An Efficient and Reliable Algorithm for Computing the
      Singular Subspace of a Matrix Associated with its Smallest
      Singular Values.
      J. Comput. and Appl. Math., 19, pp. 313-330, 1987.

  [3] Van Huffel, S.
      Analysis of the Total Least Squares Problem and its Use in
      Parameter Estimation.
      Doctoral dissertation, Dept. of Electr. Eng., Katholieke
      Universiteit Leuven, Belgium, June 1987.

  [4] Chan, T.F.
      An Improved Algorithm for Computing the Singular Value
      Decomposition.
      ACM TOMS, 8, pp. 72-83, 1982.

  [5] Van Huffel, S. and Vandewalle, J.
      The Partial Total Least Squares Algorithm.
      J. Comput. Appl. Math., 21, pp. 333-341, 1988.

  [6] Van Huffel, S. and Vandewalle, J.
      Analysis and Solution of the Nongeneric Total Least Squares
      Problem.
      SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988.
Numerical Aspects 
  The computational efficiency of the PTLS algorithm compared with
  the classical TLS algorithm (see [2 - 5]) is obtained by making
  use of PSVD (see [1]) instead of performing the entire SVD.
  Depending on the gap between the RANK-th and the (RANK+1)-th
  singular values of C, the number (N + L - RANK) of base vectors to
  be computed with respect to the column dimension (N + L) of C and
  the desired accuracy RELTOL, the algorithm used by this routine is
  approximately twice as fast as the classical TLS algorithm at the
  expense of extra storage requirements, namely:
    (N + L) x (N + L - 1)/2  if M >= N + L or
    M x (N + L - (M - 1)/2)  if M <  N + L.
  This is because the Householder transformations performed on the
  rows of C in the bidiagonalization phase (see Step 1) must be kept
  until the end (Step 5).
Further Comments 
  None
Example

Program Text 

*     MB02ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, LMAX
      PARAMETER        ( MMAX = 20, NMAX = 20, LMAX = 20 )
      INTEGER          LDC, LDX
      PARAMETER        ( LDC = MAX( MMAX, NMAX+LMAX ), LDX = NMAX )
      INTEGER          LENGQ
      PARAMETER        ( LENGQ = 2*MIN(MMAX,NMAX+LMAX)-1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX+2*LMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX(2, MAX( MMAX, NMAX+LMAX ) +
     $                            2*MIN( MMAX, NMAX+LMAX ),
     $                            MIN( MMAX, NMAX+LMAX ) +
     $                            MAX( ( NMAX+LMAX )*( NMAX+LMAX-1 )/2,
     $                              MMAX*( NMAX+LMAX-( MMAX-1 )/2 ) ) +
     $                            MAX( 6*(NMAX+LMAX)-5, LMAX*LMAX +
     $                                 MAX( NMAX+LMAX, 3*LMAX ) ) ) )
      INTEGER          LBWORK
      PARAMETER        ( LBWORK = NMAX+LMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION RELTOL, THETA, THETA1, TOL
      INTEGER          I, INFO, IWARN, J, K, L, LOOP, M, MINMNL, N,
     $                 RANK, RANK1
*     .. Local Arrays ..
      DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK),
     $                 Q(LENGQ), X(LDX,LMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LBWORK), INUL(NMAX+LMAX)
*     .. External Subroutines ..
      EXTERNAL         MB02ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, L, RANK, THETA, TOL, RELTOL
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99982 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) N
      ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99981 ) L
      ELSE IF ( RANK.GT.MIN( MMAX, NMAX ) ) THEN
         WRITE ( NOUT, FMT = 99980 ) RANK
      ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         WRITE ( NOUT, FMT = 99979 ) THETA
      ELSE
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M )
         RANK1 = RANK
         THETA1 = THETA
*        Compute the solution to the TLS problem Ax = b.
         CALL MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL,
     $                TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, IWARN,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) RANK
            ELSE
               IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK
            END IF
            IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA
            WRITE ( NOUT, FMT = 99994 )
            MINMNL = MIN( M, N+L )
            LOOP = MINMNL - 1
            DO 20 I = 1, LOOP
               K = I + MINMNL
               WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K)
   20       CONTINUE
            WRITE ( NOUT, FMT = 99992 ) MINMNL, MINMNL, Q(MINMNL)
            WRITE ( NOUT, FMT = 99991 )
            DO 60 J = 1, L
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99990 ) X(I,J)
   40          CONTINUE
               IF ( J.LT.L ) WRITE ( NOUT, FMT = 99989 )
   60       CONTINUE
            WRITE ( NOUT, FMT = 99987 ) N + L, N + L
            WRITE ( NOUT, FMT = 99985 )
            DO 80 I = 1, MAX( M, N + L )
               WRITE ( NOUT, FMT = 99984 ) ( C(I,J), J = 1,N+L )
   80       CONTINUE
            WRITE ( NOUT, FMT = 99986 )
            DO 100 J = 1, N + L
               WRITE ( NOUT, FMT = 99988 ) J, INUL(J)
  100       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02ND = ',I2)
99997 FORMAT (' IWARN on exit from MB02ND = ',I2,/)
99996 FORMAT (' The computed rank of the TLS approximation  = ',I3,/)
99995 FORMAT (' The computed value of THETA = ',F7.4,/)
99994 FORMAT (' The elements of the partially diagonalized bidiagonal ',
     $       'matrix are',/)
99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/)
99991 FORMAT (' The solution X to the TLS problem is ',/)
99990 FORMAT (1X,F8.4)
99989 FORMAT (' ')
99988 FORMAT (I3,L8)
99987 FORMAT (/' Right singular subspace corresponds to the first ',I2,
     $       ' components of the j-th ',/' column of C for which INUL(',
     $       'j) = .TRUE., j = 1,...,',I2,/)
99986 FORMAT (/'  j    INUL(j)',/)
99985 FORMAT (' Matrix C',/)
99984 FORMAT (20(1X,F8.4))
99983 FORMAT (/' N is out of range.',/' N = ',I5)
99982 FORMAT (/' M is out of range.',/' M = ',I5)
99981 FORMAT (/' L is out of range.',/' L = ',I5)
99980 FORMAT (/' RANK is out of range.',/' RANK = ',I5)
99979 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4)
      END
Program Data 
 MB02ND EXAMPLE PROGRAM DATA
   6     3     1     -1     0.001     0.0     0.0
   0.80010  0.39985  0.60005  0.89999
   0.29996  0.69990  0.39997  0.82997
   0.49994  0.60003  0.20012  0.79011
   0.90013  0.20016  0.79995  0.85002
   0.39998  0.80006  0.49985  0.99016
   0.20002  0.90007  0.70009  1.02994
Program Results 
 MB02ND EXAMPLE PROGRAM RESULTS

 The computed rank of the TLS approximation  =   3

 The elements of the partially diagonalized bidiagonal matrix are

 (1,1) =  3.2280   (1,2) = -0.0287
 (2,2) =  0.8714   (2,3) =  0.0168
 (3,3) =  0.3698   (3,4) =  0.0000
 (4,4) =  0.0001

 The solution X to the TLS problem is 

   0.5003
   0.8003
   0.2995

 Right singular subspace corresponds to the first  4 components of the j-th 
 column of C for which INUL(j) = .TRUE., j = 1,..., 4

 Matrix C

  -0.3967  -0.7096   0.4612  -0.3555
   0.9150  -0.2557   0.2414  -0.5687
  -0.0728   0.6526   0.5215  -0.2128
   0.0000   0.0720   0.6761   0.7106
   0.1809   0.3209   0.0247  -0.4139
   0.0905   0.4609  -0.3528   0.5128

  j    INUL(j)

  1       F
  2       F
  3       F
  4       T

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02NY.html000077500000000000000000000154701201767322700161220ustar00rootroot00000000000000 MB02NY - SLICOT Library Routine Documentation

MB02NY

Separation of a zero singular value of a bidiagonal submatrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To separate a zero singular value of a bidiagonal submatrix of
  order k, k <= p, of the bidiagonal matrix

            |Q(1) E(1)  0    ...   0   |
            | 0   Q(2) E(2)        .   |
        J = | .                    .   |
            | .                  E(p-1)|
            | 0   ...  ...   ...  Q(p) |

  with p = MIN(M,N), by annihilating one or two superdiagonal
  elements E(i-1) (if i > 1) and/or E(i) (if i < k).
Specification 
      SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V,
     $                   LDV, DWORK )
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,*)
Arguments

Mode Parameters 

  UPDATU  LOGICAL
          Indicates whether the user wishes to accumulate in a
          matrix U the left-hand Givens rotations S, as follows:
          = .FALSE.:  Do not form U;
          = .TRUE. :  The given matrix U is updated (postmultiplied)
                      by the left-hand Givens rotations S.

  UPDATV  LOGICAL
          Indicates whether the user wishes to accumulate in a
          matrix V the right-hand Givens rotations T, as follows:
          = .FALSE.:  Do not form V;
          = .TRUE. :  The given matrix V is updated (postmultiplied)
                      by the right-hand Givens rotations T.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix U.  M >= 0.

  N       (input) INTEGER
          The number of rows of the matrix V.  N >= 0.

  I       (input) INTEGER
          The index of the negligible diagonal entry Q(I) of the
          bidiagonal matrix J, I <= p.

  K       (input) INTEGER
          The index of the last diagonal entry of the considered
          bidiagonal submatrix of J, i.e., E(K-1) is considered
          negligible, K <= p.

  Q       (input/output) DOUBLE PRECISION array, dimension (p)
          where p = MIN(M,N).
          On entry, Q must contain the diagonal entries of the
          bidiagonal matrix J.
          On exit, Q contains the diagonal entries of the
          transformed bidiagonal matrix S' J T.

  E       (input/output) DOUBLE PRECISION array, dimension (p-1)
          On entry, E must contain the superdiagonal entries of J.
          On exit, E contains the superdiagonal entries of the
          transformed bidiagonal matrix S' J T.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,p)
          On entry, if UPDATU = .TRUE., U must contain the M-by-p
          left transformation matrix.
          On exit, if UPDATU = .TRUE., the Givens rotations S on the
          left, annihilating E(i) if i < k, have been postmultiplied
          into U.
          U is not referenced if UPDATU = .FALSE..

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= max(1,M) if UPDATU = .TRUE.;
          LDU >= 1        if UPDATU = .FALSE..

  V       (input/output) DOUBLE PRECISION array, dimension (LDV,p)
          On entry, if UPDATV = .TRUE., V must contain the N-by-p
          right transformation matrix.
          On exit, if UPDATV = .TRUE., the Givens rotations T on the
          right, annihilating E(i-1) if i > 1,  have been
          postmultiplied into V.
          V is not referenced if UPDATV = .FALSE..

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= max(1,N) if UPDATV = .TRUE.;
          LDV >= 1        if UPDATV = .FALSE..
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (MAX(1,LDWORK))
          LDWORK >= 2*MAX(K-I,I-1),  if UPDATV = UPDATU = .TRUE.;
          LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.;
          LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.;
          LDWORK >= 1,       if UPDATU = UPDATV = .FALSE..
Method 
  Let the considered bidiagonal submatrix be

            |Q(1) E(1)  0                    ...   0   |
            | 0   Q(2) E(2)                        .   |
            | .                                    .   |
            | .           Q(i-1) E(i-1)            .   |
       Jk = | .                   Q(i) E(i)        .   |.
            | .                       Q(i+1) .     .   |
            | .                              ..    .   |
            | .                                  E(k-1)|
            | 0    ...                       ...  Q(k) |

  A zero singular value of Jk manifests itself by a zero diagonal
  entry Q(i) or in practice, a negligible value of Q(i).
  When a negligible diagonal element Q(i) in Jk is present, the
  bidiagonal submatrix Jk is split by the routine into 2 or 3
  unreduced bidiagonal submatrices by annihilating E(i) (if i < k)
  using Givens rotations S on the left and by annihilating E(i-1)
  (if i > 1) using Givens rotations T on the right until Jk is
  reduced to the form:

            |Q(1) E(1)  0                ...   0   |
            | 0         .                ...   .   |
            | .                          ...   .   |
            | .       Q(i-1) 0                 .   |
  S' Jk T = | .              0   0             .   |.
            | .                 Q(i+1)   .     .   |
            | .                          ..    .   |
            | .                              E(k-1)|
            | 0    ...                   ...  Q(k) |

  For more details, see [1, pp.11.12-11.14].
References 
  [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W.
      LINPACK User's Guide.
      SIAM, Philadelphia, 1979.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02OD.html000077500000000000000000000154461201767322700161010ustar00rootroot00000000000000 MB02OD - SLICOT Library Routine Documentation

MB02OD

Solution of matrix equations A X = alpha B, or X A = alpha B, A triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve (if well-conditioned) one of the matrix equations

     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,

  where alpha is a scalar, X and B are m-by-n matrices, A is a unit,
  or non-unit, upper or lower triangular matrix and op( A ) is one
  of

     op( A ) = A   or   op( A ) = A'.

  An estimate of the reciprocal of the condition number of the
  triangular matrix A, in either the 1-norm or the infinity-norm, is
  also computed as

     RCOND = 1 / ( norm(A) * norm(inv(A)) ).

  and the specified matrix equation is solved only if RCOND is
  larger than a given tolerance TOL.  In that case, the matrix X is
  overwritten on B.
Specification 
      SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A,
     $                   LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO )
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(*)
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specifies whether op( A ) appears on the left or right
          of X as follows:
          = 'L':  op( A )*X = alpha*B;
          = 'R':  X*op( A ) = alpha*B.

  UPLO    CHARACTER*1
          Specifies whether the matrix A is an upper or lower
          triangular matrix as follows:
          = 'U':  A is an upper triangular matrix;
          = 'L':  A is a lower triangular matrix.

  TRANS   CHARACTER*1
          Specifies the form of op( A ) to be used in the matrix
          multiplication as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.

  DIAG    CHARACTER*1
          Specifies whether or not A is unit triangular as follows:
          = 'U':  A is assumed to be unit triangular;
          = 'N':  A is not assumed to be unit triangular.

  NORM    CHARACTER*1
          Specifies whether the 1-norm condition number or the
          infinity-norm condition number is required:
          = '1' or 'O':  1-norm;
          = 'I':         Infinity-norm.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of B.  M >= 0.

  N       (input) INTEGER
          The number of columns of B.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar  alpha. When alpha is zero then A is not
          referenced and B need not be set before entry.

  A       (input) DOUBLE PRECISION array, dimension (LDA,k),
          where k is M when SIDE = 'L' and is N when SIDE = 'R'.
          On entry with UPLO = 'U', the leading k-by-k upper
          triangular part of this array must contain the upper
          triangular matrix and the strictly lower triangular part
          of A is not referenced.
          On entry with UPLO = 'L', the leading k-by-k lower
          triangular part of this array must contain the lower
          triangular matrix and the strictly upper triangular part
          of A is not referenced.
          Note that when DIAG = 'U', the diagonal elements of A are
          not referenced either, but are assumed to be unity.

  LDA     INTEGER
          The leading dimension of array A.
          LDA >= max(1,M) when SIDE = 'L';
          LDA >= max(1,N) when SIDE = 'R'.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading M-by-N part of this array must
          contain the right-hand side matrix B.
          On exit, if INFO = 0, the leading M-by-N part of this
          array contains the solution matrix X.
          Otherwise, this array is not modified by the routine.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= max(1,M).

  RCOND   (output) DOUBLE PRECISION
          The reciprocal of the condition number of the matrix A,
          computed as RCOND = 1/(norm(A) * norm(inv(A))).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the matrix A. If the user sets TOL > 0, then the given
          value of TOL is used as a lower bound for the reciprocal
          condition number of that matrix; a matrix whose estimated
          condition number is less than 1/TOL is considered to be
          nonsingular. If the user sets TOL <= 0, then an implicitly
          computed, default tolerance, defined by TOLDEF = k*k*EPS,
          is used instead, where EPS is the machine precision (see
          LAPACK Library routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (k)

  DWORK   DOUBLE PRECISION array, dimension (3*k)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the matrix A is numerically singular, i.e. the
                condition number estimate of A (in the specified
                norm) exceeds 1/TOL.
Method 
  An estimate of the reciprocal of the condition number of the
  triangular matrix A (in the specified norm) is computed, and if
  this estimate is larger then the given (or default) tolerance,
  the specified matrix equation is solved using Level 3 BLAS
  routine DTRSM.
References 
  None.
Numerical Aspects 
                          2
  The algorithm requires k N/2 operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02PD.html000077500000000000000000000334501201767322700160750ustar00rootroot00000000000000 MB02PD - SLICOT Library Routine Documentation

MB02PD

Solution of matrix equation op(A) X = B, with error bounds and condition estimates

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve (if well-conditioned) the matrix equations

     op( A )*X = B,

  where X and B are N-by-NRHS matrices, A is an N-by-N matrix and
  op( A ) is one of

     op( A ) = A   or   op( A ) = A'.

  Error bounds on the solution and a condition estimate are also
  provided.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER         EQUED, FACT, TRANS
      INTEGER           INFO, LDA, LDAF, LDB, LDX, N, NRHS
      DOUBLE PRECISION  RCOND
C     .. Array Arguments ..
      INTEGER           IPIV( * ), IWORK( * )
      DOUBLE PRECISION  A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
     $                  BERR( * ), C( * ), DWORK( * ), FERR( * ),
     $                  R( * ), X( LDX, * )
Arguments

Mode Parameters 

  FACT    CHARACTER*1
          Specifies whether or not the factored form of the matrix A
          is supplied on entry, and if not, whether the matrix A
          should be equilibrated before it is factored.
          = 'F':  On entry, AF and IPIV contain the factored form
                  of A. If EQUED is not 'N', the matrix A has been
                  equilibrated with scaling factors given by R
                  and C. A, AF, and IPIV are not modified.
          = 'N':  The matrix A will be copied to AF and factored.
          = 'E':  The matrix A will be equilibrated if necessary,
                  then copied to AF and factored.

  TRANS   CHARACTER*1
          Specifies the form of the system of equations as follows:
          = 'N':  A * X = B     (No transpose);
          = 'T':  A**T * X = B  (Transpose);
          = 'C':  A**H * X = B  (Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The number of linear equations, i.e., the order of the
          matrix A.  N >= 0.

  NRHS    (input) INTEGER
          The number of right hand sides, i.e., the number of
          columns of the matrices B and X.  NRHS >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.  If FACT = 'F' and EQUED is not 'N',
          then A must have been equilibrated by the scaling factors
          in R and/or C.  A is not modified if FACT = 'F' or 'N',
          or if FACT = 'E' and EQUED = 'N' on exit.
          On exit, if EQUED .NE. 'N', the leading N-by-N part of
          this array contains the matrix A scaled as follows:
          EQUED = 'R':  A := diag(R) * A;
          EQUED = 'C':  A := A * diag(C);
          EQUED = 'B':  A := diag(R) * A * diag(C).

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  AF      (input or output) DOUBLE PRECISION array, dimension
          (LDAF,N)
          If FACT = 'F', then AF is an input argument and on entry
          the leading N-by-N part of this array must contain the
          factors L and U from the factorization A = P*L*U as
          computed by DGETRF.  If EQUED .NE. 'N', then AF is the
          factored form of the equilibrated matrix A.
          If FACT = 'N', then AF is an output argument and on exit
          the leading N-by-N part of this array contains the factors
          L and U from the factorization A = P*L*U of the original
          matrix A.
          If FACT = 'E', then AF is an output argument and on exit
          the leading N-by-N part of this array contains the factors
          L and U from the factorization A = P*L*U of the
          equilibrated matrix A (see the description of A for the
          form of the equilibrated matrix).

  LDAF    (input) INTEGER
          The leading dimension of the array AF.  LDAF >= max(1,N).

  IPIV    (input or output) INTEGER array, dimension (N)
          If FACT = 'F', then IPIV is an input argument and on entry
          it must contain the pivot indices from the factorization
          A = P*L*U as computed by DGETRF; row i of the matrix was
          interchanged with row IPIV(i).
          If FACT = 'N', then IPIV is an output argument and on exit
          it contains the pivot indices from the factorization
          A = P*L*U of the original matrix A.
          If FACT = 'E', then IPIV is an output argument and on exit
          it contains the pivot indices from the factorization
          A = P*L*U of the equilibrated matrix A.

  EQUED   (input or output) CHARACTER*1
          Specifies the form of equilibration that was done as
          follows:
          = 'N':  No equilibration (always true if FACT = 'N');
          = 'R':  Row equilibration, i.e., A has been premultiplied
                  by diag(R);
          = 'C':  Column equilibration, i.e., A has been
                  postmultiplied by diag(C);
          = 'B':  Both row and column equilibration, i.e., A has
                  been replaced by diag(R) * A * diag(C).
          EQUED is an input argument if FACT = 'F'; otherwise, it is
          an output argument.

  R       (input or output) DOUBLE PRECISION array, dimension (N)
          The row scale factors for A.  If EQUED = 'R' or 'B', A is
          multiplied on the left by diag(R); if EQUED = 'N' or 'C',
          R is not accessed.  R is an input argument if FACT = 'F';
          otherwise, R is an output argument.  If FACT = 'F' and
          EQUED = 'R' or 'B', each element of R must be positive.

  C       (input or output) DOUBLE PRECISION array, dimension (N)
          The column scale factors for A.  If EQUED = 'C' or 'B',
          A is multiplied on the right by diag(C); if EQUED = 'N'
          or 'R', C is not accessed.  C is an input argument if
          FACT = 'F'; otherwise, C is an output argument.  If
          FACT = 'F' and EQUED = 'C' or 'B', each element of C must
          be positive.

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,NRHS)
          On entry, the leading N-by-NRHS part of this array must
          contain the right-hand side matrix B.
          On exit,
          if EQUED = 'N', B is not modified;
          if TRANS = 'N' and EQUED = 'R' or 'B', the leading
          N-by-NRHS part of this array contains diag(R)*B;
          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', the leading
          N-by-NRHS part of this array contains diag(C)*B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
          If INFO = 0 or INFO = N+1, the leading N-by-NRHS part of
          this array contains the solution matrix X to the original
          system of equations.  Note that A and B are modified on
          exit if EQUED .NE. 'N', and the solution to the
          equilibrated system is inv(diag(C))*X if TRANS = 'N' and
          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or
          'C' and EQUED = 'R' or 'B'.

  LDX     (input) INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  RCOND   (output) DOUBLE PRECISION
          The estimate of the reciprocal condition number of the
          matrix A after equilibration (if done).  If RCOND is less
          than the machine precision (in particular, if RCOND = 0),
          the matrix is singular to working precision.  This
          condition is indicated by a return code of INFO > 0.
          For efficiency reasons, RCOND is computed only when the
          matrix A is factored, i.e., for FACT = 'N' or 'E'.  For
          FACT = 'F', RCOND is not used, but it is assumed that it
          has been computed and checked before the routine call.

  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
          The estimated forward error bound for each solution vector
          X(j) (the j-th column of the solution matrix X).
          If XTRUE is the true solution corresponding to X(j),
          FERR(j) is an estimated upper bound for the magnitude of
          the largest element in (X(j) - XTRUE) divided by the
          magnitude of the largest element in X(j).  The estimate
          is as reliable as the estimate for RCOND, and is almost
          always a slight overestimate of the true error.

  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
          The componentwise relative backward error of each solution
          vector X(j) (i.e., the smallest relative change in
          any element of A or B that makes X(j) an exact solution).
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (4*N)
          On exit, DWORK(1) contains the reciprocal pivot growth
          factor norm(A)/norm(U). The "max absolute element" norm is
          used. If DWORK(1) is much less than 1, then the stability
          of the LU factorization of the (equilibrated) matrix A
          could be poor. This also means that the solution X,
          condition estimator RCOND, and forward error bound FERR
          could be unreliable. If factorization fails with
          0 < INFO <= N, then DWORK(1) contains the reciprocal pivot
          growth factor for the leading INFO columns of A.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, and i is
                <= N:  U(i,i) is exactly zero.  The factorization
                       has been completed, but the factor U is
                       exactly singular, so the solution and error
                       bounds could not be computed. RCOND = 0 is
                       returned.
                = N+1: U is nonsingular, but RCOND is less than
                       machine precision, meaning that the matrix is
                       singular to working precision.  Nevertheless,
                       the solution and error bounds are computed
                       because there are a number of situations
                       where the computed solution can be more
                       accurate than the value of RCOND would
                       suggest.
          The positive values for INFO are set only when the
          matrix A is factored, i.e., for FACT = 'N' or 'E'.
Method 
  The following steps are performed:

  1. If FACT = 'E', real scaling factors are computed to equilibrate
     the system:

     TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
     TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
     TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B

     Whether or not the system will be equilibrated depends on the
     scaling of the matrix A, but if equilibration is used, A is
     overwritten by diag(R)*A*diag(C) and B by diag(R)*B
     (if TRANS='N') or diag(C)*B (if TRANS = 'T' or 'C').

  2. If FACT = 'N' or 'E', the LU decomposition is used to factor
     the matrix A (after equilibration if FACT = 'E') as
        A = P * L * U,
     where P is a permutation matrix, L is a unit lower triangular
     matrix, and U is upper triangular.

  3. If some U(i,i)=0, so that U is exactly singular, then the
     routine returns with INFO = i. Otherwise, the factored form
     of A is used to estimate the condition number of the matrix A.
     If the reciprocal of the condition number is less than machine
     precision, INFO = N+1 is returned as a warning, but the routine
     still goes on to solve for X and compute error bounds as
     described below.

  4. The system of equations is solved for X using the factored form
     of A.

  5. Iterative refinement is applied to improve the computed
     solution matrix and calculate error bounds and backward error
     estimates for it.

  6. If equilibration was used, the matrix X is premultiplied by
     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
     that it solves the original system before equilibration.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., Sorensen, D.
      LAPACK Users' Guide: Second Edition, SIAM, Philadelphia, 1995.
Further Comments 
  This is a simplified version of the LAPACK Library routine DGESVX,
  useful when several sets of matrix equations with the same
  coefficient matrix  A and/or A'  should be solved.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02QD.html000077500000000000000000000322121201767322700160710ustar00rootroot00000000000000 MB02QD - SLICOT Library Routine Documentation

MB02QD

Solution of a linear least squares problem corresponding to specified free elements

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a solution, optionally corresponding to specified free
  elements, to a real linear least squares problem:

      minimize || A * X - B ||

  using a complete orthogonal factorization of the M-by-N matrix A,
  which may be rank-deficient.

  Several right hand side vectors b and solution vectors x can be
  handled in a single call; they are stored as the columns of the
  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
  matrix X.
Specification 
      SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA,
     $                   B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER          INIPER, JOB
      INTEGER            INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   SVAL( 3 ), Y ( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies whether or not a standard least squares solution
          must be computed, as follows:
          = 'L':  Compute a standard least squares solution (Y = 0);
          = 'F':  Compute a solution with specified free elements
                  (given in Y).

  INIPER  CHARACTER*1
          Specifies whether an initial column permutation, defined
          by JPVT, must be performed, as follows:
          = 'P':  Perform an initial column permutation;
          = 'N':  Do not perform an initial column permutation.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  NRHS    (input) INTEGER
          The number of right hand sides, i.e., the number of
          columns of the matrices B and X.  NRHS >= 0.

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of A, which
          is defined as the order of the largest leading triangular
          submatrix R11 in the QR factorization with pivoting of A,
          whose estimated condition number is less than 1/RCOND.
          0 <= RCOND <= 1.

  SVLMAX  (input) DOUBLE PRECISION
          If A is a submatrix of another matrix C, and the rank
          decision should be related to that matrix, then SVLMAX
          should be an estimate of the largest singular value of C
          (for instance, the Frobenius norm of C).  If this is not
          the case, the input value SVLMAX = 0 should work.
          SVLMAX >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the given matrix A.
          On exit, the leading M-by-N part of this array contains
          details of its complete orthogonal factorization:
          the leading RANK-by-RANK upper triangular part contains
          the upper triangular factor T11 (see METHOD);
          the elements below the diagonal, with the entries 2 to
          min(M,N)+1 of the array DWORK, represent the orthogonal
          matrix Q as a product of min(M,N) elementary reflectors
          (see METHOD);
          the elements of the subarray A(1:RANK,RANK+1:N), with the
          next RANK entries of the array DWORK, represent the
          orthogonal matrix Z as a product of RANK elementary
          reflectors (see METHOD).

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,NRHS)
          On entry, the leading M-by-NRHS part of this array must
          contain the right hand side matrix B.
          On exit, the leading N-by-NRHS part of this array contains
          the solution matrix X.
          If M >= N and RANK = N, the residual sum-of-squares for
          the solution in the i-th column is given by the sum of
          squares of elements N+1:M in that column.
          If NRHS = 0, this array is not referenced, and the routine
          returns the effective rank of A, and its QR factorization.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,M,N).

  Y       (input) DOUBLE PRECISION array, dimension ( N*NRHS )
          If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as
          free elements in computing the solution (see METHOD).
          The remaining elements are not referenced.
          If JOB = 'L', or NRHS = 0, this array is not referenced.

  JPVT    (input/output) INTEGER array, dimension (N)
          On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th
          column of A is an initial column, otherwise it is a free
          column.  Before the QR factorization of A, all initial
          columns are permuted to the leading positions; only the
          remaining free columns are moved as a result of column
          pivoting during the factorization.
          If INIPER = 'N', JPVT need not be set on entry.
          On exit, if JPVT(i) = k, then the i-th column of A*P
          was the k-th column of A.

  RANK    (output) INTEGER
          The effective rank of A, i.e., the order of the submatrix
          R11.  This is the same as the order of the submatrix T11
          in the complete orthogonal factorization of A.

  SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
          The estimates of some of the singular values of the
          triangular factor R11:
          SVAL(1): largest singular value of  R(1:RANK,1:RANK);
          SVAL(2): smallest singular value of R(1:RANK,1:RANK);
          SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
                   if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
                   otherwise.
          If the triangular factorization is a rank-revealing one
          (which will be the case if the leading columns were well-
          conditioned), then SVAL(1) will also be an estimate for
          the largest singular value of A, and SVAL(2) and SVAL(3)
          will be estimates for the RANK-th and (RANK+1)-st singular
          values of A, respectively.
          By examining these values, one can confirm that the rank
          is well defined with respect to the chosen value of RCOND.
          The ratio SVAL(1)/SVAL(2) is an estimate of the condition
          number of R(1:RANK,1:RANK).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension LDWORK
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and the entries 2 to min(M,N) + RANK + 1
          contain the scalar factors of the elementary reflectors
          used in the complete orthogonal factorization of A.
          Among the entries 2 to min(M,N) + 1, only the first RANK
          elements are useful, if INIPER = 'N'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS )
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  If INIPER = 'P', the routine first computes a QR factorization
  with column pivoting:
      A * P = Q * [ R11 R12 ]
                  [  0  R22 ]
  with R11 defined as the largest leading submatrix whose estimated
  condition number is less than 1/RCOND.  The order of R11, RANK,
  is the effective rank of A.
  If INIPER = 'N', the effective rank is estimated during a
  truncated QR factorization (with column pivoting) process, and
  the submatrix R22 is not upper triangular, but full and of small
  norm. (See SLICOT Library routines MB03OD or MB03OY, respectively,
  for further details.)

  Then, R22 is considered to be negligible, and R12 is annihilated
  by orthogonal transformations from the right, arriving at the
  complete orthogonal factorization:
     A * P = Q * [ T11 0 ] * Z
                 [  0  0 ]
  The solution is then
     X = P * Z' [ inv(T11)*Q1'*B ]
                [        Y       ]
  where Q1 consists of the first RANK columns of Q, and Y contains
  free elements (if JOB = 'F'), or is zero (if JOB = 'L').
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  Significant gain in efficiency is possible for small-rank problems
  using truncated QR factorization (option INIPER = 'N').
Example

Program Text 

*     MB02QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, NRHSMX
      PARAMETER        ( NMAX = 20, MMAX = 20, NRHSMX = 20 )
      INTEGER          LDA, LDB
      PARAMETER        ( LDA = MMAX, LDB = MAX( MMAX, NMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX(   MIN( MMAX, NMAX) + 3*NMAX + 1,
     $                                 2*MIN( MMAX, NMAX) + NRHSMX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION RCOND, SVLMAX
      INTEGER          I, INFO, J, M, N, NRHS, RANK
      CHARACTER*1      INIPER, JOB
*     .. Local Arrays ..
      INTEGER          JPVT(NMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,NRHSMX), DWORK(LDWORK),
     $                 SVAL(3), Y(NMAX*NRHSMX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02QD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, NRHS, RCOND, SVLMAX, JOB, INIPER
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) M
      ELSE
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) N
         ELSE
            IF ( NRHS.LT.0 .OR. NRHS.GT.NRHSMX ) THEN
               WRITE ( NOUT, FMT = 99992 ) NRHS
            ELSE
               READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,M )
               IF ( LSAME( JOB, 'F' ) )
     $            READ ( NIN, FMT = * ) ( Y(I),  I = 1,N*NRHS )
               IF ( LSAME( INIPER, 'P' ) )
     $            READ ( NIN, FMT = * ) ( JPVT(I),  I = 1,N )
*              Find the least squares solution.
               CALL MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A,
     $                      LDA, B, LDB, Y, JPVT, RANK, SVAL, DWORK,
     $                      LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) RANK, SVAL
                  WRITE ( NOUT, FMT = 99996 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,NRHS )
   10             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02QD =',I2)
99997 FORMAT (' The effective rank of A =',I2,/
     $        ' Estimates of the singular values SVAL = '/3(1X,F8.4))
99996 FORMAT (' The least squares solution is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' M is out of range.',/' M = ',I5)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5)
      END
Program Data 
 MB02QD EXAMPLE PROGRAM DATA
   4   3   2 2.3D-16     0.0     L     N
   2.0  2.0 -3.0 
   3.0  3.0 -1.0 
   4.0  4.0 -5.0 
  -1.0 -1.0 -2.0 
   1.0  0.0
   0.0  0.0
   0.0  0.0
   0.0  1.0
Program Results 
 MB02QD EXAMPLE PROGRAM RESULTS

 The effective rank of A = 2
 Estimates of the singular values SVAL = 
   7.8659   2.6698   0.0000
 The least squares solution is
  -0.0034  -0.1054
  -0.0034  -0.1054
  -0.0816  -0.1973

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02QY.html000077500000000000000000000134631201767322700161250ustar00rootroot00000000000000 MB02QY - SLICOT Library Routine Documentation

MB02QY

Minimum-norm solution to a linear least squares problem, given a rank-revealing QR factorization

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine the minimum-norm solution to a real linear least
  squares problem:

      minimize || A * X - B ||,

  using the rank-revealing QR factorization of a real general
  M-by-N matrix  A,  computed by SLICOT Library routine  MB03OD.
Specification 
      SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU,
     $                   DWORK, LDWORK, INFO )
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( * )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrices A and B.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  NRHS    (input) INTEGER
          The number of columns of the matrix B.  NRHS >= 0.

  RANK    (input) INTEGER
          The effective rank of  A,  as returned by SLICOT Library
          routine  MB03OD.  min(M,N) >= RANK >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension
          ( LDA, N )
          On entry, the leading min(M,N)-by-N upper trapezoidal
          part of this array contains the triangular factor  R,  as
          returned by SLICOT Library routine  MB03OD.  The strict
          lower trapezoidal part of  A  is not referenced.
          On exit, if  RANK < N,  the leading  RANK-by-RANK  upper
          triangular part of this array contains the upper
          triangular matrix  R  of the complete orthogonal
          factorization of  A,  and the submatrix  (1:RANK,RANK+1:N)
          of this array, with the array  TAU,  represent the
          orthogonal matrix  Z  (of the complete orthogonal
          factorization of  A),  as a product of  RANK  elementary
          reflectors.
          On exit, if  RANK = N,  this array is unchanged.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  JPVT    (input) INTEGER array, dimension ( N )
          The recorded permutations performed by SLICOT Library
          routine  MB03OD;  if  JPVT(i) = k,  then the i-th column
          of  A*P  was the k-th column of the original matrix  A.

  B       (input/output) DOUBLE PRECISION array, dimension
          ( LDB, NRHS )
          On entry, if  NRHS > 0,  the leading M-by-NRHS part of
          this array must contain the matrix  B  (corresponding to
          the transformed matrix  A,  returned by SLICOT Library
          routine  MB03OD).
          On exit, if  NRHS > 0,  the leading N-by-NRHS part of this
          array contains the solution matrix X.
          If  M >= N  and  RANK = N,  the residual sum-of-squares
          for the solution in the i-th column is given by the sum
          of squares of elements  N+1:M  in that column.
          If  NRHS = 0,  the array  B  is not referenced.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= max(1,M,N),  if  NRHS > 0.
          LDB >= 1,           if  NRHS = 0.

  TAU     (output) DOUBLE PRECISION array, dimension ( min(M,N) )
          The scalar factors of the elementary reflectors.
          If  RANK = N,  the array  TAU  is not referenced.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( 1, N, NRHS ).
          For good performance,  LDWORK  should sometimes be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine uses a QR factorization with column pivoting:

     A * P = Q * R = Q * [ R11 R12 ],
                         [  0  R22 ]

  where  R11  is an upper triangular submatrix of estimated rank
  RANK,  the effective rank of  A.  The submatrix  R22  can be
  considered as negligible.

  If  RANK < N,  then  R12  is annihilated by orthogonal
  transformations from the right, arriving at the complete
  orthogonal factorization:

     A * P = Q * [ T11 0 ] * Z.
                 [  0  0 ]

  The minimum-norm solution is then

     X = P * Z' [ inv(T11)*Q1'*B ],
                [        0       ]

  where Q1 consists of the first  RANK  columns of Q.

  The input data for  MB02QY  are the transformed matrices  Q' * A
  (returned by SLICOT Library routine  MB03OD)  and  Q' * B.
  Matrix  Q  is not needed.
Numerical Aspects 
  The implemented method is numerically stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02RD.html000077500000000000000000000070651201767322700161020ustar00rootroot00000000000000 MB02RD - SLICOT Library Routine Documentation

MB02RD

Solution of a system of linear equations with upper Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of linear equations
     H * X = B  or  H' * X = B
  with an upper Hessenberg N-by-N matrix H using the LU
  factorization computed by MB02SD.
Specification 
      SUBROUTINE MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDB, LDH, N, NRHS
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   B( LDB, * ), H( LDH, * )
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies the form of the system of equations:
          = 'N':  H * X = B  (No transpose)
          = 'T':  H'* X = B  (Transpose)
          = 'C':  H'* X = B  (Conjugate transpose = Transpose)
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix H.  N >= 0.

  NRHS    (input) INTEGER
          The number of right hand sides, i.e., the number of
          columns of the matrix B.  NRHS >= 0.

  H       (input) DOUBLE PRECISION array, dimension (LDH,N)
          The factors L and U from the factorization H = P*L*U
          as computed by MB02SD.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  IPIV    (input) INTEGER array, dimension (N)
          The pivot indices from MB02SD; for 1<=i<=N, row i of the
          matrix was interchanged with row IPIV(i).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,NRHS)
          On entry, the right hand side matrix B.
          On exit, the solution matrix X.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).
Error Indicator 
  INFO    (output) INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine uses the factorization
     H = P * L * U
  where P is a permutation matrix, L is lower triangular with unit
  diagonal elements (and one nonzero subdiagonal), and U is upper
  triangular.
References 
  -
Numerical Aspects 
                             2
  The algorithm requires 0( N x NRHS ) operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02RZ.html000077500000000000000000000070301201767322700161200ustar00rootroot00000000000000 MB02RZ - SLICOT Library Routine Documentation

MB02RZ

Solution of a system of linear equations with complex upper Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of linear equations
     H * X = B,  H' * X = B  or  H**H * X = B
  with a complex upper Hessenberg N-by-N matrix H using the LU
  factorization computed by MB02SZ.
Specification 
      SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDB, LDH, N, NRHS
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         B( LDB, * ), H( LDH, * )
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies the form of the system of equations:
          = 'N':  H * X = B  (No transpose)
          = 'T':  H'* X = B  (Transpose)
          = 'C':  H**H * X = B  (Conjugate transpose)
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix H.  N >= 0.

  NRHS    (input) INTEGER
          The number of right hand sides, i.e., the number of
          columns of the matrix B.  NRHS >= 0.

  H       (input) COMPLEX*16 array, dimension (LDH,N)
          The factors L and U from the factorization H = P*L*U
          as computed by MB02SZ.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  IPIV    (input) INTEGER array, dimension (N)
          The pivot indices from MB02SZ; for 1<=i<=N, row i of the
          matrix was interchanged with row IPIV(i).

  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
          On entry, the right hand side matrix B.
          On exit, the solution matrix X.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  INFO    (output) INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine uses the factorization
     H = P * L * U
  where P is a permutation matrix, L is lower triangular with unit
  diagonal elements (and one nonzero subdiagonal), and U is upper
  triangular.
References 
  -
Numerical Aspects 
                             2
  The algorithm requires 0( N x NRHS ) complex operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02SD.html000077500000000000000000000152261201767322700161010ustar00rootroot00000000000000 MB02SD - SLICOT Library Routine Documentation

MB02SD

LU factorization of an upper Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an LU factorization of an n-by-n upper Hessenberg
  matrix H using partial pivoting with row interchanges.
Specification 
      SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N
C     .. Array Arguments ..
      INTEGER           IPIV(*)
      DOUBLE PRECISION  H(LDH,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix H.  N >= 0.

  H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
          On entry, the n-by-n upper Hessenberg matrix to be
          factored.
          On exit, the factors L and U from the factorization
          H = P*L*U; the unit diagonal elements of L are not stored,
          and L is lower bidiagonal.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  IPIV    (output) INTEGER array, dimension (N)
          The pivot indices; for 1 <= i <= N, row i of the matrix
          was interchanged with row IPIV(i).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, U(i,i) is exactly zero. The
                factorization has been completed, but the factor U
                is exactly singular, and division by zero will occur
                if it is used to solve a system of equations.
Method 
  The factorization has the form
     H = P * L * U
  where P is a permutation matrix, L is lower triangular with unit
  diagonal elements (and one nonzero subdiagonal), and U is upper
  triangular.

  This is the right-looking Level 1 BLAS version of the algorithm
  (adapted after DGETF2).
References 
  -
Numerical Aspects 
                             2
  The algorithm requires 0( N ) operations.
Further Comments 
  None
Example

Program Text 

*     MB02SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, NRHMAX
      PARAMETER        ( NMAX = 20, NRHMAX = 20 )
      INTEGER          LDB, LDH
      PARAMETER        ( LDB = NMAX, LDH = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION HNORM, RCOND
      INTEGER          I, INFO, INFO1, J, N, NRHS
      CHARACTER*1      NORM, TRANS
*     .. Local Arrays ..
      DOUBLE PRECISION H(LDH,NMAX), B(LDB,NRHMAX), DWORK(LDWORK)
      INTEGER          IPIV(NMAX), IWORK(LIWORK)
*     .. External Functions ..
      DOUBLE PRECISION DLAMCH, DLANHS
      EXTERNAL         DLAMCH, DLANHS
*     .. External Subroutines ..
      EXTERNAL         DLASET, MB02RD, MB02SD, MB02TD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NRHS, NORM, TRANS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( H(I,J), J = 1,N ), I = 1,N )
         IF ( NRHS.LT.0 .OR. NRHS.GT.NRHMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) NRHS
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,N )
            IF ( N.GT.2 )
     $         CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, H(3,1), LDH )
*           Compute the LU factorization of the upper Hessenberg matrix.
            CALL MB02SD( N, H, LDH, IPIV, INFO )
*           Estimate the reciprocal condition number of the matrix.
            HNORM = DLANHS( NORM, N, H, LDH, DWORK )
            CALL MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK,
     $                   DWORK, INFO1 )
            IF ( INFO.EQ.0 .AND. RCOND.GT.DLAMCH( 'Epsilon' ) ) THEN
*              Solve the linear system.
               CALL MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO )
*
               WRITE ( NOUT, FMT = 99997 )
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO
            END IF
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,NRHS )
   10          CONTINUE
            WRITE ( NOUT, FMT = 99995 ) RCOND
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02SD = ',I2)
99997 FORMAT (' The solution matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' Reciprocal condition number = ',D12.4)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5)
      END
Program Data 
 MB02SD EXAMPLE PROGRAM DATA
   5    4      O      N
   1.    2.    6.    3.    5.
  -2.   -1.   -1.    0.   -2.
   0.    3.    1.    5.    1.
   0.    0.    2.    0.   -4.
   0.    0.    0.    1.    4.
   5.    5.    1.    5.
  -2.    1.    3.    1.
   0.    0.    4.    5.
   2.    1.    1.    3.
  -1.    3.    3.    1.
Program Results 
 MB02SD EXAMPLE PROGRAM RESULTS

 The solution matrix is 
   0.0435   1.2029   1.6377   1.1014
   1.0870  -4.4275  -5.5580  -2.9638
   0.9130   0.7609  -0.1087   0.6304
  -0.8261   2.4783   4.2174   2.7391
  -0.0435   0.1304  -0.3043  -0.4348

 Reciprocal condition number =   0.1554D-01

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02SZ.html000077500000000000000000000064041201767322700161250ustar00rootroot00000000000000 MB02SZ - SLICOT Library Routine Documentation

MB02SZ

LU factorization of a complex upper Hessenberg matrix H

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an LU factorization of a complex n-by-n upper
  Hessenberg matrix H using partial pivoting with row interchanges.
Specification 
      SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N
C     .. Array Arguments ..
      INTEGER           IPIV(*)
      COMPLEX*16        H(LDH,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix H.  N >= 0.

  H       (input/output) COMPLEX*16 array, dimension (LDH,N)
          On entry, the n-by-n upper Hessenberg matrix to be
          factored.
          On exit, the factors L and U from the factorization
          H = P*L*U; the unit diagonal elements of L are not stored,
          and L is lower bidiagonal.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  IPIV    (output) INTEGER array, dimension (N)
          The pivot indices; for 1 <= i <= N, row i of the matrix
          was interchanged with row IPIV(i).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, U(i,i) is exactly zero. The
                factorization has been completed, but the factor U
                is exactly singular, and division by zero will occur
                if it is used to solve a system of equations.
Method 
  The factorization has the form
     H = P * L * U
  where P is a permutation matrix, L is lower triangular with unit
  diagonal elements (and one nonzero subdiagonal), and U is upper
  triangular.

  This is the right-looking Level 2 BLAS version of the algorithm
  (adapted after ZGETF2).
References 
  -
Numerical Aspects 
                             2
  The algorithm requires 0( N ) complex operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02TD.html000077500000000000000000000071731201767322700161040ustar00rootroot00000000000000 MB02TD - SLICOT Library Routine Documentation

MB02TD

Estimation of the reciprocal condition number of an upper Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the reciprocal of the condition number of an upper
  Hessenberg matrix H, in either the 1-norm or the infinity-norm,
  using the LU factorization computed by MB02SD.
Specification 
      SUBROUTINE MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK,
     $                   DWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            INFO, LDH, N
      DOUBLE PRECISION   HNORM, RCOND
C     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   DWORK( * ), H( LDH, * )
Arguments

Mode Parameters 

  NORM    CHARACTER*1
          Specifies whether the 1-norm condition number or the
          infinity-norm condition number is required:
          = '1' or 'O':  1-norm;
          = 'I':         Infinity-norm.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix H.  N >= 0.

  HNORM   (input) DOUBLE PRECISION
          If NORM = '1' or 'O', the 1-norm of the original matrix H.
          If NORM = 'I', the infinity-norm of the original matrix H.

  H       (input) DOUBLE PRECISION array, dimension (LDH,N)
          The factors L and U from the factorization H = P*L*U
          as computed by MB02SD.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  IPIV    (input) INTEGER array, dimension (N)
          The pivot indices; for 1 <= i <= N, row i of the matrix
          was interchanged with row IPIV(i).

  RCOND   (output) DOUBLE PRECISION
          The reciprocal of the condition number of the matrix H,
          computed as RCOND = 1/(norm(H) * norm(inv(H))).
Workspace 
  IWORK   DOUBLE PRECISION array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (3*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  An estimate is obtained for norm(inv(H)), and the reciprocal of
  the condition number is computed as
     RCOND = 1 / ( norm(H) * norm(inv(H)) ).
References 
  -
Numerical Aspects 
                             2
  The algorithm requires 0( N ) operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02TZ.html000077500000000000000000000072331201767322700161270ustar00rootroot00000000000000 MB02TZ - SLICOT Library Routine Documentation

MB02TZ

Estimation of the reciprocal condition number of a complex upper Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the reciprocal of the condition number of a complex
  upper Hessenberg matrix H, in either the 1-norm or the
  infinity-norm, using the LU factorization computed by MB02SZ.
Specification 
      SUBROUTINE MB02TZ( NORM, N, HNORM, H, LDH, IPIV, RCOND, DWORK,
     $                   ZWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            INFO, LDH, N
      DOUBLE PRECISION   HNORM, RCOND
C     .. Array Arguments ..
      INTEGER            IPIV(*)
      DOUBLE PRECISION   DWORK( * )
      COMPLEX*16         H( LDH, * ), ZWORK( * )
Arguments

Mode Parameters 

  NORM    CHARACTER*1
          Specifies whether the 1-norm condition number or the
          infinity-norm condition number is required:
          = '1' or 'O':  1-norm;
          = 'I':         Infinity-norm.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix H.  N >= 0.

  HNORM   (input) DOUBLE PRECISION
          If NORM = '1' or 'O', the 1-norm of the original matrix H.
          If NORM = 'I', the infinity-norm of the original matrix H.

  H       (input) COMPLEX*16 array, dimension (LDH,N)
          The factors L and U from the factorization H = P*L*U
          as computed by MB02SZ.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  IPIV    (input) INTEGER array, dimension (N)
          The pivot indices; for 1 <= i <= N, row i of the matrix
          was interchanged with row IPIV(i).

  RCOND   (output) DOUBLE PRECISION
          The reciprocal of the condition number of the matrix H,
          computed as RCOND = 1/(norm(H) * norm(inv(H))).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)

  ZWORK   COMPLEX*16 array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  An estimate is obtained for norm(inv(H)), and the reciprocal of
  the condition number is computed as
     RCOND = 1 / ( norm(H) * norm(inv(H)) ).
References 
  -
Numerical Aspects 
                             2
  The algorithm requires 0( N ) complex operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02UD.html000077500000000000000000000232331201767322700161000ustar00rootroot00000000000000 MB02UD - SLICOT Library Routine Documentation

MB02UD

Minimum norm least squares solution of op(R) X = alpha B, or X op(R) = alpha B, with R upper triangular, using singular value decomposition

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the minimum norm least squares solution of one of the
  following linear systems

     op(R)*X = alpha*B,                                          (1)
     X*op(R) = alpha*B,                                          (2)

  where alpha is a real scalar, op(R) is either R or its transpose,
  R', R is an L-by-L real upper triangular matrix, B is an M-by-N
  real matrix, and L = M for (1), or L = N for (2). Singular value
  decomposition, R = Q*S*P', is used, assuming that R is rank
  deficient.
Specification 
      SUBROUTINE MB02UD( FACT, SIDE, TRANS, JOBP, M, N, ALPHA, RCOND,
     $                   RANK, R, LDR, Q, LDQ, SV, B, LDB, RP, LDRP,
     $                   DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  FACT    CHARACTER*1
          Specifies whether R has been previously factored or not,
          as follows:
          = 'F':  R has been factored and its rank and singular
                  value decomposition, R = Q*S*P', are available;
          = 'N':  R has not been factored and its singular value
                  decomposition, R = Q*S*P', should be computed.

  SIDE    CHARACTER*1
          Specifies whether op(R) appears on the left or right
          of X as follows:
          = 'L':  Solve op(R)*X = alpha*B  (op(R) is on the left);
          = 'R':  Solve X*op(R) = alpha*B  (op(R) is on the right).

  TRANS   CHARACTER*1
          Specifies the form of op(R) to be used as follows:
          = 'N':  op(R) = R;
          = 'T':  op(R) = R';
          = 'C':  op(R) = R'.

  JOBP    CHARACTER*1
          Specifies whether or not the pseudoinverse of R is to be
          computed or it is available as follows:
          = 'P':  Compute pinv(R), if FACT = 'N', or
                  use pinv(R),     if FACT = 'F';
          = 'N':  Do not compute or use pinv(R).
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix B.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix B.  N >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar alpha. When alpha is zero then B need not be
          set before entry.

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of R.
          Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are
          treated as zero. If RCOND <= 0, then EPS is used instead,
          where EPS is the relative machine precision (see LAPACK
          Library routine DLAMCH).  RCOND <= 1.
          RCOND is not used if FACT = 'F'.

  RANK    (input or output) INTEGER
          The rank of matrix R.
          RANK is an input parameter when FACT = 'F', and an output
          parameter when FACT = 'N'.  L >= RANK >= 0.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,L)
          On entry, if FACT = 'F', the leading L-by-L part of this
          array must contain the L-by-L orthogonal matrix P' from
          singular value decomposition, R = Q*S*P', of the matrix R;
          if JOBP = 'P', the first RANK rows of P' are assumed to be
          scaled by inv(S(1:RANK,1:RANK)).
          On entry, if FACT = 'N', the leading L-by-L upper
          triangular part of this array must contain the upper
          triangular matrix R.
          On exit, if INFO = 0, the leading L-by-L part of this
          array contains the L-by-L orthogonal matrix P', with its
          first RANK rows scaled by inv(S(1:RANK,1:RANK)), when
          JOBP = 'P'.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,L).

  Q       (input or output) DOUBLE PRECISION array, dimension
          (LDQ,L)
          On entry, if FACT = 'F', the leading L-by-L part of this
          array must contain the L-by-L orthogonal matrix Q from
          singular value decomposition, R = Q*S*P', of the matrix R.
          If FACT = 'N', this array need not be set on entry, and
          on exit, if INFO = 0, the leading L-by-L part of this
          array contains the orthogonal matrix Q.

  LDQ     INTEGER
          The leading dimension of array Q.  LDQ >= MAX(1,L).

  SV      (input or output) DOUBLE PRECISION array, dimension (L)
          On entry, if FACT = 'F', the first RANK entries of this
          array must contain the reciprocal of the largest RANK
          singular values of the matrix R, and the last L-RANK
          entries of this array must contain the remaining singular
          values of R sorted in descending order.
          If FACT = 'N', this array need not be set on input, and
          on exit, if INFO = 0, the first RANK entries of this array
          contain the reciprocal of the largest RANK singular values
          of the matrix R, and the last L-RANK entries of this array
          contain the remaining singular values of R sorted in
          descending order.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, if ALPHA <> 0, the leading M-by-N part of this
          array must contain the matrix B.
          On exit, if INFO = 0 and RANK > 0, the leading M-by-N part
          of this array contains the M-by-N solution matrix X.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).

  RP      (input or output) DOUBLE PRECISION array, dimension
          (LDRP,L)
          On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the
          leading L-by-L part of this array must contain the L-by-L
          matrix pinv(R), the Moore-Penrose pseudoinverse of R.
          On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the
          leading L-by-L part of this array contains the L-by-L
          matrix pinv(R), the Moore-Penrose pseudoinverse of R.
          If JOBP = 'N', this array is not referenced.

  LDRP    INTEGER
          The leading dimension of array RP.
          LDRP >= MAX(1,L), if JOBP = 'P'.
          LDRP >= 1,        if JOBP = 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK;
          if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the
          unconverged superdiagonal elements of an upper bidiagonal
          matrix D whose diagonal is in SV (not necessarily sorted).
          D satisfies R = Q*D*P', so it has the same singular
          values as R, and singular vectors related by Q and P'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,L),   if FACT = 'F';
          LDWORK >= MAX(1,5*L), if FACT = 'N'.
          For optimum performance LDWORK should be larger than
          MAX(1,L,M*N),   if FACT = 'F';
          MAX(1,5*L,M*N), if FACT = 'N'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, i = 1:L, the SVD algorithm has failed
                to converge. In this case INFO specifies how many
                superdiagonals did not converge (see the description
                of DWORK); this failure is not likely to occur.
Method 
  The L-by-L upper triangular matrix R is factored as  R = Q*S*P',
  if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P
  are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix
  with non-negative diagonal elements, SV(1), SV(2), ..., SV(L),
  ordered decreasingly. Then, the effective rank of R is estimated,
  and matrix (or matrix-vector) products and scalings are used to
  compute X. If FACT = 'F', only matrix (or matrix-vector) products
  and scalings are performed.
Further Comments 
  Option JOBP = 'P' should be used only if the pseudoinverse is
  really needed. Usually, it is possible to avoid the use of
  pseudoinverse, by computing least squares solutions.
  The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2
  calculations, otherwise. No advantage of any additional workspace
  larger than L is taken for matrix products, but the routine can
  be called repeatedly for chunks of columns of B, if LDWORK < M*N.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02UU.html000077500000000000000000000055741201767322700161310ustar00rootroot00000000000000 MB02UU - SLICOT Library Routine Documentation

MB02UU

Solution of a system of linear equations using LU factorization with complete pivoting

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for x in A * x = scale * RHS, using the LU factorization
  of the N-by-N matrix A computed by SLICOT Library routine MB02UV.
  The factorization has the form A = P * L * U * Q, where P and Q
  are permutation matrices, L is unit lower triangular and U is
  upper triangular.
Specification 
      SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE )
C     .. Scalar Arguments ..
      INTEGER            LDA, N
      DOUBLE PRECISION   SCALE
C     .. Array Arguments ..
      INTEGER            IPIV( * ), JPIV( * )
      DOUBLE PRECISION   A( LDA, * ), RHS( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.

  A       (input) DOUBLE PRECISION array, dimension (LDA, N)
          The leading N-by-N part of this array must contain
          the LU part of the factorization of the matrix A computed
          by SLICOT Library routine MB02UV:  A = P * L * U * Q.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1, N).

  RHS     (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the right hand side
          of the system.
          On exit, this array contains the solution of the system.

  IPIV    (input) INTEGER array, dimension (N)
          The pivot indices; for 1 <= i <= N, row i of the
          matrix has been interchanged with row IPIV(i).

  JPIV    (input) INTEGER array, dimension (N)
          The pivot indices; for 1 <= j <= N, column j of the
          matrix has been interchanged with column JPIV(j).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, chosen 0 < SCALE <= 1 to prevent
          overflow in the solution.
Further Comments 
  In the interest of speed, this routine does not check the input
  for errors. It should only be used if the order of the matrix A
  is very small.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02UV.html000077500000000000000000000057071201767322700161300ustar00rootroot00000000000000 MB02UV - SLICOT Library Routine Documentation

MB02UV

LU factorization with complete pivoting of a general matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an LU factorization, using complete pivoting, of the
  N-by-N matrix A. The factorization has the form A = P * L * U * Q,
  where P and Q are permutation matrices, L is lower triangular with
  unit diagonal elements and U is upper triangular.
Specification 
      SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
C     .. Array Arguments ..
      INTEGER            IPIV( * ), JPIV( * )
      DOUBLE PRECISION   A( LDA, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A to be factored.
          On exit, the leading N-by-N part of this array contains
          the factors L and U from the factorization A = P*L*U*Q;
          the unit diagonal elements of L are not stored. If U(k, k)
          appears to be less than SMIN, U(k, k) is given the value
          of SMIN, giving a nonsingular perturbed system.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1, N).

  IPIV    (output) INTEGER array, dimension (N)
          The pivot indices; for 1 <= i <= N, row i of the
          matrix has been interchanged with row IPIV(i).

  JPIV    (output) INTEGER array, dimension (N)
          The pivot indices; for 1 <= j <= N, column j of the
          matrix has been interchanged with column JPIV(j).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = k:  U(k, k) is likely to produce owerflow if one tries
                to solve for x in Ax = b. So U is perturbed to get
                a nonsingular system. This is a warning.
Further Comments 
  In the interests of speed, this routine does not check the input
  for errors. It should only be used to factorize matrices A of
  very small order.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02UW.html000077500000000000000000000115601201767322700161230ustar00rootroot00000000000000 MB02UW - SLICOT Library Routine Documentation

MB02UW

Solving a set of linear systems of order at most 2 with possible scaling and perturbation of system matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of the form  A X = s B  or  A' X = s B  with
  possible scaling ("s") and perturbation of A.  (A' means
  A-transpose.)  A is an N-by-N real matrix, and X and B are
  N-by-M matrices.  N may be 1 or 2.  The scalar "s" is a scaling
  factor (.LE. 1), computed by this subroutine, which is so chosen
  that X can be computed without overflow.  X is further scaled if
  necessary to assure that norm(A)*norm(X) is less than overflow.
Specification 
      SUBROUTINE MB02UW( LTRANS, N, M, PAR, A, LDA, B, LDB, SCALE,
     $                   IWARN )
C     .. Scalar Arguments ..
      LOGICAL            LTRANS
      INTEGER            IWARN, LDA, LDB, N, M
      DOUBLE PRECISION   SCALE, SMIN
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), PAR( * )
Arguments

Mode Parameters 

  LTRANS  LOGICAL
          Specifies if A or A-transpose is to be used, as follows:
          =.TRUE. :  A-transpose will be used;
          =.FALSE.:  A will be used (not transposed).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  It may (only) be 1 or 2.

  M       (input) INTEGER
          The number of right hand size vectors.

  PAR     (input) DOUBLE PRECISION array, dimension (3)
          Machine related parameters:
          PAR(1) =: PREC  (machine precision)*base, DLAMCH( 'P' );
          PAR(2) =: SFMIN safe minimum,             DLAMCH( 'S' );
          PAR(3) =: SMIN  The desired lower bound on the singular
                          values of A.  This should be a safe
                          distance away from underflow or overflow,
                          say, between (underflow/machine precision)
                          and (machine precision * overflow).

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= N.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix B (right-hand side).
          On exit, the leading N-by-M part of this array contains
          the N-by-M matrix X (unknowns).

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N.

  SCALE   (output) DOUBLE PRECISION
          The scale factor that B must be multiplied by to insure
          that overflow does not occur when computing X.  Thus,
          A X  will be SCALE*B, not B (ignoring perturbations of A).
          SCALE will be at most 1.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warnings (A did not have to be perturbed);
          = 1:  A had to be perturbed to make its smallest (or only)
                singular value greater than SMIN (see below).
Method 
  Gaussian elimination with complete pivoting is used. The matrix A
  is slightly perturbed if it is (close to being) singular.
Further Comments 
  If both singular values of A are less than SMIN, SMIN*identity
  will be used instead of A.  If only one singular value is less
  than SMIN, one element of A will be perturbed enough to make the
  smallest singular value roughly SMIN.  If both singular values
  are at least SMIN, A will not be perturbed.  In any case, the
  perturbation will be at most some small multiple of
  max( SMIN, EPS*norm(A) ), where EPS is the machine precision
  (see LAPACK Library routine DLAMCH).  The singular values are
  computed by infinity-norm approximations, and thus will only be
  correct to a factor of 2 or so.

  Note: all input quantities are assumed to be smaller than overflow
  by a reasonable factor.  (See BIGNUM.)  In the interests of speed,
  this routine does not check the inputs for errors.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02VD.html000077500000000000000000000147341201767322700161070ustar00rootroot00000000000000 MB02VD - SLICOT Library Routine Documentation

MB02VD

Solution of linear equations X op(A) = B

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the solution to a real system of linear equations
     X * op(A) = B,
  where op(A) is either A or its transpose, A is an N-by-N matrix,
  and X and B are M-by-N matrices.
  The LU decomposition with partial pivoting and row interchanges,
  A = P * L * U, is used, where P is a permutation matrix, L is unit
  lower triangular, and U is upper triangular.
Specification 
      SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, M, N
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies the form of op(A) to be used as follows:
          = 'N':  op(A) = A;
          = 'T':  op(A) = A';
          = 'C':  op(A) = A'.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix B.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix B, and the order of
          the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the coefficient matrix A.
          On exit, the leading N-by-N part of this array contains
          the factors L and U from the factorization A = P*L*U;
          the unit diagonal elements of L are not stored.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  IPIV    (output) INTEGER array, dimension (N)
          The pivot indices that define the permutation matrix P;
          row i of the matrix was interchanged with row IPIV(i).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading M-by-N part of this array must
          contain the right hand side matrix B.
          On exit, if INFO = 0, the leading M-by-N part of this
          array contains the solution matrix X.

  LDB     (input) INTEGER
          The leading dimension of the array B.  LDB >= max(1,M).

  INFO    (output) INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, U(i,i) is exactly zero.  The
                factorization has been completed, but the factor U
                is exactly singular, so the solution could not be
                computed.
Method 
  The LU decomposition with partial pivoting and row interchanges is
  used to factor A as
     A = P * L * U,
  where P is a permutation matrix, L is unit lower triangular, and
  U is upper triangular.  The factored form of A is then used to
  solve the system of equations X * A = B or X * A' = B.
Further Comments 
  This routine enables to solve the system X * A = B or X * A' = B
  as easily and efficiently as possible; it is similar to the LAPACK
  Library routine DGESV, which solves A * X = B.
Example

Program Text 

*     MB02VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDB
      PARAMETER        ( LDA = NMAX, LDB = MMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
      CHARACTER*1      TRANS
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,NMAX)
      INTEGER          IPIV(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB02VD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, TRANS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M )
*           Solve the linear system using the LU factorization.
            CALL MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO )
*
            IF ( INFO.EQ.0 ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 10 I = 1, M
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N )
   10          CONTINUE
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02VD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02VD = ',I2)
99997 FORMAT (' The solution matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 MB02VD EXAMPLE PROGRAM DATA
   5    4      N
   1.    2.    6.    3.
  -2.   -1.   -1.    0.
   2.    3.    1.    5.
   1.   -1.    2.    0.
   0.    0.    0.    1.
   5.    5.    1.    5.
  -2.    1.    3.    1.
   0.    0.    4.    5.
   2.    1.    1.    3.
Program Results 
 MB02VD EXAMPLE PROGRAM RESULTS

 The solution matrix is 
  -0.0690   0.3333   0.2414   0.2529
  -0.1724  -1.6667   1.1034  -0.3678
   0.9655   0.6667  -0.3793  -0.8736
   0.3448   1.6667   0.7931   1.4023
  -0.2069   0.0000   0.7241   0.7586

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB02WD.html000077500000000000000000000250461201767322700161060ustar00rootroot00000000000000 MB02WD - SLICOT Library Routine Documentation

MB02WD

Solution of Ax = b or f(A, x) = b, for a positive definite linear mapping, using conjugate gradients

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the system of linear equations Ax = b, with A symmetric,
  positive definite, or, in the implicit form, f(A, x) = b, where
  y = f(A, x) is a symmetric positive definite linear mapping
  from x to y, using the conjugate gradient (CG) algorithm without
  preconditioning.
Specification 
      SUBROUTINE MB02WD( FORM, F, N, IPAR, LIPAR, DPAR, LDPAR, ITMAX,
     $                   A, LDA, B, INCB, X, INCX, TOL, DWORK, LDWORK,
     $                   IWARN, INFO )
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(*)
Arguments

Mode Parameters 

  FORM     CHARACTER*1
           Specifies the form of the system of equations, as
           follows:
           = 'U' :  Ax = b, the upper triagular part of A is used;
           = 'L' :  Ax = b, the lower triagular part of A is used;
           = 'F' :  the implicit, function form, f(A, x) = b.
Function Parameters 
  F       EXTERNAL
          If FORM = 'F', then F is a subroutine which calculates the
          value of f(A, x), for given A and x.
          If FORM <> 'F', then F is not called.

          F must have the following interface:

          SUBROUTINE F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, X,
         $              INCX, DWORK, LDWORK, INFO )

          where

          N       (input) INTEGER
                  The dimension of the vector x.  N >= 0.

          IPAR    (input) INTEGER array, dimension (LIPAR)
                  The integer parameters describing the structure of
                  the matrix A.

          LIPAR   (input) INTEGER
                  The length of the array IPAR.  LIPAR >= 0.

          DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
                  The real parameters needed for solving the
                  problem.

          LDPAR   (input) INTEGER
                  The length of the array DPAR.  LDPAR >= 0.

          A       (input) DOUBLE PRECISION array, dimension
                  (LDA, NC), where NC is the number of columns.
                  The leading NR-by-NC part of this array must
                  contain the (compressed) representation of the
                  matrix A, where NR is the number of rows of A
                  (function of IPAR entries).

          LDA     (input) INTEGER
                  The leading dimension of the array A.
                  LDA >= MAX(1,NR).

          X       (input/output) DOUBLE PRECISION array, dimension
                  (1+(N-1)*INCX)
                  On entry, this incremented array must contain the
                  vector x.
                  On exit, this incremented array contains the value
                  of the function f, y = f(A, x).

          INCX    (input) INTEGER
                  The increment for the elements of X.  INCX > 0.

          DWORK   DOUBLE PRECISION array, dimension (LDWORK)
                  The workspace array for subroutine F.

          LDWORK  (input) INTEGER
                  The size of the array DWORK (as large as needed
                  in the subroutine F).

          INFO    INTEGER
                  Error indicator, set to a negative value if an
                  input scalar argument is erroneous, and to
                  positive values for other possible errors in the
                  subroutine F. The LAPACK Library routine XERBLA
                  should be used in conjunction with negative INFO.
                  INFO must be zero if the subroutine finished
                  successfully.

          Parameters marked with "(input)" must not be changed.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the vector x.  N >= 0.
          If FORM = 'U' or FORM = 'L', N is also the number of rows
          and columns of the matrix A.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          If FORM = 'F', the integer parameters describing the
          structure of the matrix A.
          This parameter is ignored if FORM = 'U' or FORM = 'L'.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 0.

  DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
          If FORM = 'F', the real parameters needed for solving
          the problem.
          This parameter is ignored if FORM = 'U' or FORM = 'L'.

  LDPAR   (input) INTEGER
          The length of the array DPAR.  LDPAR >= 0.

  ITMAX   (input) INTEGER
          The maximal number of iterations to do.  ITMAX >= 0.

  A       (input) DOUBLE PRECISION array,
                  dimension (LDA, NC), if FORM = 'F',
                  dimension (LDA, N),  otherwise.
          If FORM = 'F', the leading NR-by-NC part of this array
          must contain the (compressed) representation of the
          matrix A, where NR and NC are the number of rows and
          columns, respectively, of the matrix A. The array A is
          not referenced by this routine itself, except in the
          calls to the routine F.
          If FORM <> 'F', the leading N-by-N part of this array
          must contain the matrix A, assumed to be symmetric;
          only the triangular part specified by FORM is referenced.

  LDA     (input) INTEGER
          The leading dimension of array A.
          LDA >= MAX(1,NR), if FORM = 'F';
          LDA >= MAX(1,N),  if FORM = 'U' or FORM = 'L'.

  B       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCB)
          The incremented vector b.

  INCB    (input) INTEGER
          The increment for the elements of B.  INCB > 0.

  X       (input/output) DOUBLE PRECISION array, dimension
          (1+(N-1)*INCX)
          On entry, this incremented array must contain an initial
          approximation of the solution. If an approximation is not
          known, setting all elements of x to zero is recommended.
          On exit, this incremented array contains the computed
          solution x of the system of linear equations.

  INCX    (input) INTEGER
          The increment for the elements of X.  INCX > 0.
Tolerances 
  TOL     DOUBLE PRECISION
          If TOL > 0, absolute tolerance for the iterative process.
          The algorithm will stop if || Ax - b ||_2 <= TOL. Since
          it is advisable to use a relative tolerance, say TOLER,
          TOL should be chosen as TOLER*|| b ||_2.
          If TOL <= 0, a default relative tolerance,
          TOLDEF = N*EPS*|| b ||_2,  is used, where EPS is the
          machine precision (see LAPACK Library routine DLAMCH).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the number of
          iterations performed and DWORK(2) returns the remaining
          residual, || Ax - b ||_2.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(2,3*N + DWORK(F)),  if FORM = 'F',
                    where DWORK(F) is the workspace needed by F;
          LDWORK >= MAX(2,3*N),       if FORM = 'U' or FORM = 'L'.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  the algorithm finished after ITMAX > 0 iterations,
                without achieving the desired precision TOL;
          = 2:  ITMAX is zero; in this case, DWORK(2) is not set.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, then F returned with INFO = i.
Method 
  The following CG iteration is used for solving Ax = b:

  Start: q(0) = r(0) = Ax - b

                < q(k),  r(k) >
  ALPHA(k) = - ----------------
                < q(k), Aq(k) >
  x(k+1)   = x(k) - ALPHA(k) * q(k)
  r(k+1)   = r(k) - ALPHA(k) * Aq(k)
              < r(k+1), r(k+1) >
  BETA(k)  = --------------------
              < r(k)  , r(k)   >
  q(k+1)   = r(k+1) + BETA(k) * q(k)

  where <.,.> denotes the scalar product.
References 
  [1] Golub, G.H. and van Loan, C.F.
      Matrix Computations. Third Edition.
      M. D. Johns Hopkins University Press, Baltimore, pp. 520-528,
      1996.

  [2] Luenberger, G.
      Introduction to Linear and Nonlinear Programming.
      Addison-Wesley, Reading, MA, p.187, York, 1973.
Numerical Aspects 
  Since the residuals are orthogonal in the scalar product
  <x, y> = y'Ax, the algorithm is theoretically finite. But rounding
  errors cause a loss of orthogonality, so a finite termination
  cannot be guaranteed. However, one can prove [2] that

     || x-x_k ||_A := sqrt( (x-x_k)' * A * (x-x_k) )

                                          sqrt( kappa_2(A) ) - 1
                   <=  2 || x-x_0 ||_A * ------------------------ ,
                                          sqrt( kappa_2(A) ) + 1

  where kappa_2 is the condition number.

  The approximate number of floating point operations is
     (k*(N**2 + 15*N) + N**2 + 3*N)/2, if FORM <> 'F',
     k*(f + 7*N) + f,                  if FORM =  'F',
  where k is the number of CG iterations performed, and f is the
  number of floating point operations required by the subroutine F.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02XD.html000077500000000000000000000254511201767322700161070ustar00rootroot00000000000000 MB02XD - SLICOT Library Routine Documentation

MB02XD

Solution of A' A X = B, or f(A) X = B, using symmetric Gaussian elimination

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a set of systems of linear equations, A'*A*X = B, or,
  in the implicit form, f(A)*X = B, with A'*A or f(A) positive
  definite, using symmetric Gaussian elimination.
Specification 
      SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR,
     $                   DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK,
     $                   LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  FORM    CHARACTER*1
          Specifies the form in which the matrix A is provided, as
          follows:
          = 'S' :  standard form, the matrix A is given;
          = 'F' :  the implicit, function form f(A) is provided.
          If FORM = 'F', then the routine F is called to compute the
          matrix A'*A.

  STOR    CHARACTER*1
          Specifies the storage scheme for the symmetric
          matrix A'*A, as follows:
          = 'F' :  full storage is used;
          = 'P' :  packed storage is used.

  UPLO    CHARACTER*1
          Specifies which part of the matrix A'*A is stored, as
          follows:
          = 'U' :  the upper triagular part is stored;
          = 'L' :  the lower triagular part is stored.
Function Parameters 
  F       EXTERNAL
          If FORM = 'F', then F is a subroutine which calculates the
          value of f(A) = A'*A, for given A.
          If FORM = 'S', then F is not called.

          F must have the following interface:

          SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A,
         $              LDA, ATA, LDATA, DWORK, LDWORK, INFO )

          where

          STOR    (input) CHARACTER*1
                  Specifies the storage scheme for the symmetric
                  matrix A'*A, as follows:
                  = 'F' :  full storage is used;
                  = 'P' :  packed storage is used.

          UPLO    (input) CHARACTER*1
                  Specifies which part of the matrix A'*A is stored,
                  as follows:
                  = 'U' :  the upper triagular part is stored;
                  = 'L' :  the lower triagular part is stored.

          N       (input) INTEGER
                  The order of the matrix A'*A.  N >= 0.

          IPAR    (input) INTEGER array, dimension (LIPAR)
                  The integer parameters describing the structure of
                  the matrix A.

          LIPAR   (input) INTEGER
                  The length of the array IPAR.  LIPAR >= 0.

          DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
                  The real parameters needed for solving the
                  problem.

          LDPAR   (input) INTEGER
                  The length of the array DPAR.  LDPAR >= 0.

          A       (input) DOUBLE PRECISION array, dimension
                  (LDA, NC), where NC is the number of columns.
                  The leading NR-by-NC part of this array must
                  contain the (compressed) representation of the
                  matrix A, where NR is the number of rows of A
                  (function of IPAR entries).

          LDA     (input) INTEGER
                  The leading dimension of the array A.
                  LDA >= MAX(1,NR).

          ATA     (output) DOUBLE PRECISION array,
                           dimension (LDATA,N),    if STOR = 'F',
                           dimension (N*(N+1)/2),  if STOR = 'P'.
                  The leading N-by-N (if STOR = 'F'), or N*(N+1)/2
                  (if STOR = 'P') part of this array contains the
                  upper or lower triangle of the matrix A'*A,
                  depending on UPLO = 'U', or UPLO = 'L',
                  respectively, stored either as a two-dimensional,
                  or one-dimensional array, depending on STOR.

          LDATA   (input) INTEGER
                  The leading dimension of the array ATA.
                  LDATA >= MAX(1,N), if STOR = 'F'.
                  LDATA >= 1,        if STOR = 'P'.

          DWORK   DOUBLE PRECISION array, dimension (LDWORK)
                  The workspace array for subroutine F.

          LDWORK  (input) INTEGER
                  The size of the array DWORK (as large as needed
                  in the subroutine F).

          INFO    INTEGER
                  Error indicator, set to a negative value if an
                  input scalar argument is erroneous, and to
                  positive values for other possible errors in the
                  subroutine F. The LAPACK Library routine XERBLA
                  should be used in conjunction with negative INFO.
                  INFO must be zero if the subroutine finished
                  successfully.

          Parameters marked with "(input)" must not be changed.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The order of the matrix A'*A, the number of columns of the
          matrix A, and the number of rows of the matrix X.  N >= 0.

  NRHS    (input) INTEGER
          The number of columns of the matrices B and X.  NRHS >= 0.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          If FORM = 'F', the integer parameters describing the
          structure of the matrix A.
          This parameter is ignored if FORM = 'S'.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 0.

  DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
          If FORM = 'F', the real parameters needed for solving
          the problem.
          This parameter is ignored if FORM = 'S'.

  LDPAR   (input) INTEGER
          The length of the array DPAR.  LDPAR >= 0.

  A       (input) DOUBLE PRECISION array,
                  dimension (LDA, N),  if FORM = 'S',
                  dimension (LDA, NC), if FORM = 'F', where NC is
                  the number of columns.
          If FORM = 'S', the leading M-by-N part of this array
          must contain the matrix A.
          If FORM = 'F', the leading NR-by-NC part of this array
          must contain an appropriate representation of matrix A,
          where NR is the number of rows.
          If FORM = 'F', this array is not referenced by this
          routine itself, except in the call to the routine F.

  LDA     INTEGER
          The leading dimension of array A.
          LDA >= MAX(1,M),  if FORM = 'S';
          LDA >= MAX(1,NR), if FORM = 'F'.

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB, NRHS)
          On entry, the leading N-by-NRHS part of this array must
          contain the right hand side matrix B.
          On exit, if INFO = 0 and M (or NR) is nonzero, the leading
          N-by-NRHS part of this array contains the solution X of
          the set of systems of linear equations A'*A*X = B or
          f(A)*X = B. If M (or NR) is zero, then B is unchanged.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  ATA     (output) DOUBLE PRECISION array,
                   dimension (LDATA,N),    if STOR = 'F',
                   dimension (N*(N+1)/2),  if STOR = 'P'.
          The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if
          STOR = 'P') part of this array contains the upper or lower
          triangular Cholesky factor of the matrix A'*A, depending
          on UPLO = 'U', or UPLO = 'L', respectively, stored either
          as a two-dimensional, or one-dimensional array, depending
          on STOR.

  LDATA   INTEGER
          The leading dimension of the array ATA.
          LDATA >= MAX(1,N), if STOR = 'F'.
          LDATA >= 1,        if STOR = 'P'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, then the (i,i) element of the
                triangular factor of the matrix A'*A is exactly
                zero (the matrix A'*A is exactly singular);
                if INFO = j > n, then F returned with INFO = j-n.
Method 
  The matrix A'*A is built either directly (if FORM = 'S'), or
  implicitly, by calling the routine F. Then, A'*A is Cholesky
  factored and its factor is used to solve the set of systems of
  linear equations, A'*A*X = B.
References 
  [1] Golub, G.H. and van Loan, C.F.
      Matrix Computations. Third Edition.
      M. D. Johns Hopkins University Press, Baltimore, 1996.

  [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J.,
      Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S.,
      McKenney, A., Sorensen, D.
      LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999.
Numerical Aspects 
  For speed, this routine does not check for near singularity of the
  matrix A'*A. If the matrix A is nearly rank deficient, then the
  computed X could be inaccurate. Estimates of the reciprocal
  condition numbers of the matrices A and A'*A can be obtained
  using LAPACK routines DGECON and DPOCON (DPPCON), respectively.

  The approximate number of floating point operations is
     (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S',
     f + N**3/6 + NRHS*N**2,            if FORM = 'F',
  where M is the number of rows of A, and f is the number of
  floating point operations required by the subroutine F.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB02YD.html000077500000000000000000000153161201767322700161070ustar00rootroot00000000000000 MB02YD - SLICOT Library Routine Documentation

MB02YD

Solving the linear system A x = b, D x = 0, D diagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine a vector x which solves the system of linear
  equations

        A*x = b ,     D*x = 0 ,

  in the least squares sense, where A is an m-by-n matrix,
  D is an n-by-n diagonal matrix, and b is an m-vector.
  It is assumed that a QR factorization, with column pivoting, of A
  is available, that is, A*P = Q*R, where P is a permutation matrix,
  Q has orthogonal columns, and R is an upper triangular matrix
  with diagonal elements of nonincreasing magnitude.
  The routine needs the full upper triangle of R, the permutation
  matrix P, and the first n components of Q'*b (' denotes the
  transpose). The system A*x = b, D*x = 0, is then equivalent to

        R*z = Q'*b ,  P'*D*P*z = 0 ,                             (1)

  where x = P*z. If this system does not have full rank, then a
  least squares solution is obtained. On output, MB02YD also
  provides an upper triangular matrix S such that

        P'*(A'*A + D*D)*P = S'*S .

  The system (1) is equivalent to S*z = c , where c contains the
  first n components of the vector obtained by applying to
  [ (Q'*b)'  0 ]' the transformations which triangularized
  [ R'  P'*D*P ]', getting S.
Specification 
      SUBROUTINE MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANK, X, TOL,
     $                   DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  COND    CHARACTER*1
          Specifies whether the condition of the matrix S should be
          estimated, as follows:
          = 'E' :  use incremental condition estimation and store
                   the numerical rank of S in RANK;
          = 'N' :  do not use condition estimation, but check the
                   diagonal entries of S for zero values;
          = 'U' :  use the rank already stored in RANK.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix R.  N >= 0.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR, N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the upper triangular matrix R.
          On exit, the full upper triangle is unaltered, and the
          strict lower triangle contains the strict upper triangle
          (transposed) of the upper triangular matrix S.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  IPVT    (input) INTEGER array, dimension (N)
          This array must define the permutation matrix P such that
          A*P = Q*R. Column j of P is column IPVT(j) of the identity
          matrix.

  DIAG    (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the diagonal elements of the
          matrix D.

  QTB     (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the first n elements of the
          vector Q'*b.

  RANK    (input or output) INTEGER
          On entry, if COND = 'U', this parameter must contain the
          (numerical) rank of the matrix S.
          On exit, if COND = 'E' or 'N', this parameter contains
          the numerical rank of the matrix S, estimated according
          to the value of COND.

  X       (output) DOUBLE PRECISION array, dimension (N)
          This array contains the least squares solution of the
          system A*x = b, D*x = 0.
Tolerances 
  TOL     DOUBLE PRECISION
          If COND = 'E', the tolerance to be used for finding the
          rank of the matrix S. If the user sets TOL > 0, then the
          given value of TOL is used as a lower bound for the
          reciprocal condition number;  a (sub)matrix whose
          estimated condition number is less than 1/TOL is
          considered to be of full rank.  If the user sets TOL <= 0,
          then an implicitly computed, default tolerance, defined by
          TOLDEF = N*EPS,  is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not relevant if COND = 'U' or 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, the first N elements of this array contain the
          diagonal elements of the upper triangular matrix S, and
          the next N elements contain the solution z.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 4*N, if COND =  'E';
          LDWORK >= 2*N, if COND <> 'E'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Standard plane rotations are used to annihilate the elements of
  the diagonal matrix D, updating the upper triangular matrix R
  and the first n elements of the vector Q'*b. A basic least squares
  solution is computed.
References 
  [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
      User's Guide for MINPACK-1.
      Applied Math. Division, Argonne National Laboratory, Argonne,
      Illinois, Report ANL-80-74, 1980.
Numerical Aspects 
                            2
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  This routine is a LAPACK-based modification of QRSOLV from the
  MINPACK package [1], and with optional condition estimation.
  The option COND = 'U' is useful when dealing with several
  right-hand side vectors.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03AD.html000077500000000000000000000070301201767322700160520ustar00rootroot00000000000000 MB03AD - SLICOT Library Routine Documentation

MB03AD

Reducing the first column of a real Wilkinson shift polynomial for a product of matrices to the first unit vector

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute two Givens rotations (C1,S1) and (C2,S2)
  such that the orthogonal matrix

             [  C1  S1  0 ]   [ 1  0   0  ]
        Q =  [ -S1  C1  0 ] * [ 0  C2  S2 ]
             [  0   0   1 ]   [ 0 -S2  C2 ]

  makes the first column of the real Wilkinson single/double shift
  polynomial of the general product of matrices, stored in the
  array A, parallel to the first unit vector.
Specification 
      SUBROUTINE MB03AD( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1,
     $                   S1, C2, S2 )
C     .. Scalar Arguments ..
      CHARACTER         SHFT
      INTEGER           K, LDA1, LDA2, N, SINV
      DOUBLE PRECISION  C1, S1, C2, S2
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*)
Arguments

Mode Parameters 

  SHFT    CHARACTER*1
          Specifies the number of shifts employed by the shift
          polynomial, as follows:
          = 'D':  two real shifts;
          = 'S':  one real shift.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of factors.  K >= 1.

  N       (input)  INTEGER
          The order of the factors in the array A.  N >= 3.

  AMAP    (input) INTEGER array, dimension (K)
          The map for accessing the factors, i.e., if AMAP(I) = J,
          then the factor A_I is stored at the J-th position in A.

  S       (input)  INTEGER array, dimension (K)
          The signature array. Each entry of S must be 1 or -1.

  SINV    (input) INTEGER
          Signature multiplier. Entries of S are virtually
          multiplied by SINV.

  A       (input)  DOUBLE PRECISION array, dimension (LDA1,LDA2,K)
          On entry, the leading N-by-N-by-K part of this array must
          contain a n-by-n product (implicitly represented by its K
          factors) in upper Hessenberg form.

  LDA1    INTEGER
          The first leading dimension of the array A.  LDA1 >= N.

  LDA2    INTEGER
          The second leading dimension of the array A.  LDA2 >= N.

  C1      (output)  DOUBLE PRECISION
  S1      (output)  DOUBLE PRECISION
          On exit, C1 and S1 contain the parameters for the first
          Givens rotation.

  C2      (output)  DOUBLE PRECISION
  S2      (output)  DOUBLE PRECISION
          On exit, if SHFT = 'D', C2 and S2 contain the parameters
          for the second Givens rotation.
Method 
  Two Givens rotations are properly computed and applied.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03BA.html000077500000000000000000000042451201767322700160550ustar00rootroot00000000000000 MB03BA - SLICOT Library Routine Documentation

MB03BA

Computing maps for Hessenberg index and signature array

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the suitable maps for Hessenberg index H and
  signature array S. Auxiliary routine for the periodic QZ
  algorithms.
Specification 
      SUBROUTINE MB03BA( K, H, S, SMULT, AMAP, QMAP )
C     .. Scalar Arguments ..
      INTEGER           K, H, SMULT
C     .. Array Arguments ..
      INTEGER           AMAP(*), QMAP(*), S(*)
Arguments

Input/Output Parameters 

  K       (input)  INTEGER
          The number of factors.  K >= 1.

  H       (input)  INTEGER
          Index which corresponds to A_1.

  S       (input)  INTEGER array, dimension (K)
          The signature array. Each entry of S must be 1 or -1.

  SMULT   (output)  INTEGER
          Signature multiplier. Entries of S are virtually
          multiplied by SMULT.

  AMAP    (output)  INTEGER array, dimension (K)
          The map for accessing the factors, that is,
          if AMAP(I) = J, then the factor A_I is stored at the J-th
          position in A.

  QMAP    (output)  INTEGER array, dimension (K)
          The map for accessing the orthognal transformation
          matrices, that is, if QMAP(I) = J, then the matrix Q_I is
          stored at the J-th position in Q.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03BB.html000077500000000000000000000077561201767322700160700ustar00rootroot00000000000000 MB03BB - SLICOT Library Routine Documentation

MB03BB

Eigenvalues of a 2-by-2 matrix product via a complex single shifted periodic QZ algorithm

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of a general 2-by-2 matrix product via
  a complex single shifted periodic QZ algorithm.
Specification 
      SUBROUTINE MB03BB( BASE, LGBAS, ULP, K, AMAP, S, SINV, A, LDA1,
     $                   LDA2, ALPHAR, ALPHAI, BETA, SCAL, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, K, LDA1, LDA2, SINV
      DOUBLE PRECISION  BASE, LGBAS, ULP
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA1,LDA2,*), ALPHAI(2), ALPHAR(2), BETA(2),
     $                  DWORK(*)
      INTEGER           AMAP(*), S(*), SCAL(2)
Arguments

Input/Output Parameters 

  BASE    (input)  DOUBLE PRECISION
          Machine base.

  LGBAS   (input)  DOUBLE PRECISION
          Logarithm of BASE.

  ULP     (input)  DOUBLE PRECISION
          Machine precision.

  K       (input)  INTEGER
          The number of factors.  K >= 1.

  AMAP    (input) INTEGER array, dimension (K)
          The map for accessing the factors, i.e., if AMAP(I) = J,
          then the factor A_I is stored at the J-th position in A.

  S       (input)  INTEGER array, dimension (K)
          The signature array. Each entry of S must be 1 or -1.

  SINV    (input) INTEGER
          Signature multiplier. Entries of S are virtually
          multiplied by SINV.

  A       (input)  DOUBLE PRECISION array, dimension (LDA1,LDA2,K)
          On entry, the leading 2-by-2-by-K part of this array must
          contain a 2-by-2 product (implicitly represented by its K
          factors) in upper Hessenberg-triangular form.

  LDA1    INTEGER
          The first leading dimension of the array A.  LDA1 >= 2.

  LDA2    INTEGER
          The second leading dimension of the array A.  LDA2 >= 2.

  ALPHAR  (output)  DOUBLE PRECISION array, dimension (2)
          On exit, if INFO = 0, this array contains the scaled real
          part of the two eigenvalues. If BETA(I) <> 0, then the
          I-th eigenvalue (I = 1 : 2) is given by
              (ALPHAR(I) + ALPHAI(I)*SQRT(-1) ) * (BASE)**SCAL(I).

  ALPHAI  (output)  DOUBLE PRECISION array, dimension (2)
          On exit, if INFO = 0, this array contains the scaled
          imaginary part of the two eigenvalues. ALPHAI(1) >= 0.

  BETA    (output)  DOUBLE PRECISION array, dimension (2)
          On exit, if INFO = 0, this array contains information
          about infinite eigenvalues. If BETA(I) = 0, then the
          I-th eigenvalue is infinite. Otherwise, BETA(I) = 1.0.

  SCAL    (output)  INTEGER array, dimension (2)
          On exit, if INFO = 0, this array contains the scaling
          exponents for the two eigenvalues.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (8*K)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  the periodic QZ algorithm did not converge.
Method 
  A complex single shifted periodic QZ iteration is applied.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03BC.html000077500000000000000000000111331201767322700160510ustar00rootroot00000000000000 MB03BC - SLICOT Library Routine Documentation

MB03BC

Product singular value decomposition of K-1 triangular factors of order 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the product singular value decomposition of the K-1
  triangular factors corresponding to a 2-by-2 product of K
  factors in upper Hessenberg-triangular form.
  For a general product of 2-by-2 triangular matrices

                     S(2)        S(3)            S(K)
         A = A(:,:,2)    A(:,:,3)    ... A(:,:,K),

  Givens rotators are computed so that
                                                       S(i)
    [  CV(i-1) SV(i-1) ] [ A(1,1,i)(in)  A(1,2,i)(in) ]
    [ -SV(i-1) CV(i-1) ] [     0         A(2,2,i)(in) ]
                                   S(i)
    [ A(1,1,i)(out) A(1,2,i)(out) ]    [  CV(i) SV(i) ]
  = [     0         A(2,2,i)(out) ]    [ -SV(i) CV(i) ]

  stays upper triangular and

    [  CV(1) SV(1) ]       [ CV(K) -SV(K) ]
    [ -SV(1) CV(1) ] * A * [ SV(K)  CV(K) ]

  is diagonal.
Specification 
      SUBROUTINE MB03BC( K, AMAP, S, SINV, A, LDA1, LDA2, MACPAR, CV,
     $                   SV, DWORK )
C     .. Scalar Arguments ..
      INTEGER           K, LDA1, LDA2, SINV
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*), CV(*), DWORK(*), MACPAR(*),
     $                  SV(*)
Arguments

Input/Output Parameters 

  K       (input)  INTEGER
          The number of factors.  K >= 1.

  AMAP    (input) INTEGER array, dimension (K)
          The map for accessing the factors, i.e., if AMAP(I) = J,
          then the factor A_I is stored at the J-th position in A.

  S       (input)  INTEGER array, dimension (K)
          The signature array. Each entry of S must be 1 or -1.

  SINV    (input) INTEGER
          Signature multiplier. Entries of S are virtually
          multiplied by SINV.

  A       (input/output)  DOUBLE PRECISION array, dimension
                          (LDA1,LDA2,K)
          On entry, the leading 2-by-2-by-K part of this array must
          contain a 2-by-2 product (implicitly represented by its K
          factors) in upper Hessenberg-triangular form.
          On exit, the leading 2-by-2-by-K part of this array
          contains modified triangular factors such that their
          product is diagonal.

  LDA1    INTEGER
          The first leading dimension of the array A.  LDA1 >= 2.

  LDA2    INTEGER
          The second leading dimension of the array A.  LDA2 >= 2.

  MACPAR  (input)  DOUBLE PRECISION array, dimension (5)
          Machine parameters:
          MACPAR(1)  overflow threshold,         DLAMCH( 'O' );
          MACPAR(2)  underflow threshold,        DLAMCH( 'U' );
          MACPAR(3)  safe minimum,               DLAMCH( 'S' );
          MACPAR(4)  relative machine precision, DLAMCH( 'E' );
          MACPAR(5)  base of the machine,        DLAMCH( 'B' ).

  CV      (output)  DOUBLE PRECISION array, dimension (K)
          On exit, the first K elements of this array contain the
          cosines of the Givens rotators.

  SV      (output)  DOUBLE PRECISION array, dimension (K)
          On exit, the first K elements of this array contain the
          sines of the Givens rotators.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension 3*(K-1)
Method 
  The product singular value decomposition of the K-1
  triangular factors are computed as described in [1].
References 
  [1] Bojanczyk, A. and Van Dooren, P.
      On propagating orthogonal transformations in a product of 2x2
      triangular matrices.
      In Reichel, Ruttan and Varga: 'Numerical Linear Algebra',
      pp. 1-9, 1993.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03BD.html000077500000000000000000000446611201767322700160660ustar00rootroot00000000000000 MB03BD - SLICOT Library Routine Documentation

MB03BD

Finding eigenvalues of a generalized matrix product in Hessenberg-triangular form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find the eigenvalues of the generalized matrix product

               S(1)           S(2)                 S(K)
       A(:,:,1)     * A(:,:,2)     * ... * A(:,:,K)

  where A(:,:,H) is upper Hessenberg and A(:,:,i), i <> H, is upper
  triangular, using a double-shift version of the periodic
  QZ method. In addition, A may be reduced to periodic Schur form:
  A(:,:,H) is upper quasi-triangular and all the other factors
  A(:,:,I) are upper triangular. Optionally, the 2-by-2 triangular
  matrices corresponding to 2-by-2 diagonal blocks in A(:,:,H)
  are so reduced that their product is a 2-by-2 diagonal matrix.

  If COMPQ = 'U' or COMPQ = 'I', then the orthogonal factors are
  computed and stored in the array Q so that for S(I) = 1,

                      T
          Q(:,:,I)(in)   A(:,:,I)(in)   Q(:,:,MOD(I,K)+1)(in)
                       T                                        (1)
      =   Q(:,:,I)(out)  A(:,:,I)(out)  Q(:,:,MOD(I,K)+1)(out),

  and for S(I) = -1,

                               T
          Q(:,:,MOD(I,K)+1)(in)   A(:,:,I)(in)   Q(:,:,I)(in)
                                T                               (2)
      =   Q(:,:,MOD(I,K)+1)(out)  A(:,:,I)(out)  Q(:,:,I)(out).

  A partial generation of the orthogonal factors can be realized
  via the array QIND.
Specification 
      SUBROUTINE MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S,
     $                   A, LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI,
     $                   BETA, SCAL, IWORK, LIWORK, DWORK, LDWORK,
     $                   IWARN, INFO )
C     .. Scalar Arguments ..
      CHARACTER         COMPQ, DEFL, JOB
      INTEGER           H, IHI, ILO, INFO, IWARN, K, LDA1, LDA2, LDQ1,
     $                  LDQ2, LDWORK, LIWORK, N
C     .. Array Arguments ..
      INTEGER           IWORK(*), QIND(*), S(*), SCAL(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*), ALPHAI(*), ALPHAR(*),
     $                  BETA(*), DWORK(*), Q(LDQ1,LDQ2,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'E': compute the eigenvalues only; A will not
                 necessarily be put into periodic Schur form;
          = 'S': put A into periodic Schur form, and return the
                 eigenvalues in ALPHAR, ALPHAI, BETA, and SCAL;
          = 'T': as JOB = 'S', but A is put into standardized
                 periodic Schur form, that is, the general product
                 of the 2-by-2 triangular matrices corresponding to
                 a complex eigenvalue is diagonal.

  DEFL    CHARACTER*1
          Specifies the deflation strategy to be used, as follows:
          = 'C': apply a careful deflation strategy, that is,
                 the criteria are based on the magnitudes of
                 neighboring elements and infinite eigenvalues are
                 only deflated at the top; this is the recommended
                 option;
          = 'A': apply a more aggressive strategy, that is,
                 elements on the subdiagonal or diagonal are set
                 to zero as soon as they become smaller in magnitude
                 than eps times the norm of the corresponding
                 factor; this option is only recommended if
                 balancing is applied beforehand and convergence
                 problems are observed.

  COMPQ   CHARACTER*1
          Specifies whether or not the orthogonal transformations
          should be accumulated in the array Q, as follows:
          = 'N': do not modify Q;
          = 'U': modify (update) the array Q by the orthogonal
                 transformations that are applied to the matrices in
                 the array A to reduce them to periodic Schur form;
          = 'I': like COMPQ = 'U', except that each matrix in the
                 array Q will be first initialized to the identity
                 matrix;
          = 'P': use the parameters as encoded in QIND.

  QIND    INTEGER array, dimension (K)
          If COMPQ = 'P', then this array describes the generation
          of the orthogonal factors as follows:
             If QIND(I) > 0, then the array Q(:,:,QIND(I)) is
          modified by the transformations corresponding to the
          i-th orthogonal factor in (1) and (2).
             If QIND(I) < 0, then the array Q(:,:,-QIND(I)) is
          initialized to the identity and modified by the
          transformations corresponding to the i-th orthogonal
          factor in (1) and (2).
             If QIND(I) = 0, then the transformations corresponding
          to the i-th orthogonal factor in (1), (2) are not applied.
Input/Output Parameters 
  K       (input)  INTEGER
          The number of factors.  K >= 1.

  N       (input)  INTEGER
          The order of each factor in the array A.  N >= 0.

  H       (input)  INTEGER
          Hessenberg index. The factor A(:,:,H) is on entry in upper
          Hessenberg form.  1 <= H <= K.

  ILO     (input)  INTEGER
  IHI     (input)  INTEGER
          It is assumed that each factor in A is already upper
          triangular in rows and columns 1:ILO-1 and IHI+1:N.
          1 <= ILO <= IHI <= N, if N > 0;
          ILO = 1 and IHI  = 0, if N = 0.

  S       (input)  INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          signatures of the factors. Each entry in S must be either
          1 or -1.

  A       (input/output)  DOUBLE PRECISION array, dimension
                          (LDA1,LDA2,K)
          On entry, the leading N-by-N-by-K part of this array
          must contain the factors in upper Hessenberg-triangular
          form, that is, A(:,:,H) is upper Hessenberg and the other
          factors are upper triangular.
          On exit, if JOB = 'S' and INFO = 0, the leading
          N-by-N-by-K part of this array contains the factors of
          A in periodic Schur form, that is, A(:,:,H) is upper quasi
          triangular and the other factors are upper triangular.
          On exit, if JOB = 'T' and INFO = 0, the leading
          N-by-N-by-K part of this array contains the factors of
          A as for the option JOB = 'S', but the product of the
          triangular factors corresponding to a 2-by-2 block in
          A(:,:,H) is diagonal.
          On exit, if JOB = 'E', then the leading N-by-N-by-K part
          of this array contains meaningless elements.

  LDA1    INTEGER
          The first leading dimension of the array A.
          LDA1 >= MAX(1,N).

  LDA2    INTEGER
          The second leading dimension of the array A.
          LDA2 >= MAX(1,N).

  Q       (input/output)  DOUBLE PRECISION array, dimension
                          (LDQ1,LDQ2,K)
          On entry, if COMPQ = 'U', the leading N-by-N-by-K part
          of this array must contain the initial orthogonal factors
          as described in (1) and (2).
          On entry, if COMPQ = 'P', only parts of the leading
          N-by-N-by-K part of this array must contain some
          orthogonal factors as described by the parameters QIND.
          If COMPQ = 'I', this array should not set on entry.
          On exit, if COMPQ = 'U' or COMPQ = 'I', the leading
          N-by-N-by-K part of this array contains the modified
          orthogonal factors as described in (1) and (2).
          On exit, if COMPQ = 'P', only parts of the leading
          N-by-N-by-K part contain some modified orthogonal factors
          as described by the parameters QIND.
          This array is not referenced if COMPQ = 'N'.

  LDQ1    INTEGER
          The first leading dimension of the array Q.  LDQ1 >= 1,
          and, if COMPQ <> 'N', LDQ1 >= MAX(1,N).

  LDQ2    INTEGER
          The second leading dimension of the array Q.  LDQ2 >= 1,
          and, if COMPQ <> 'N', LDQ2 >= MAX(1,N).

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
          On exit, if IWARN = 0 and INFO = 0, the leading N elements
          of this array contain the scaled real parts of the
          eigenvalues of the matrix product A. The i-th eigenvalue
          of A is given by

          (ALPHAR(I) + ALPHAI(I)*SQRT(-1))/BETA(I) * BASE**SCAL(I),

          where BASE is the machine base (often 2.0).

  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
          On exit, if IWARN = 0 and INFO = 0, the leading N elements
          of this array contain the scaled imaginary parts of the
          eigenvalues of A.

  BETA    (output) DOUBLE PRECISION array, dimension (N)
          On exit, if IWARN = 0 and INFO = 0, the leading N elements
          of this array contain indicators for infinite eigenvalues.
          That is, if BETA(I) = 0.0, then the i-th eigenvalue is
          infinite. Otherwise BETA(I) is set to 1.0.

  SCAL    (output) INTEGER array, dimension (N)
          On exit, if IWARN = 0 and INFO = 0, the leading N elements
          of this array contain the scaling parameters for the
          eigenvalues of A.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
          On exit, if INFO = -22, IWORK(1) returns the minimum value
          of LIWORK.

  LIWORK  INTEGER
          The length of the array IWORK.  LIWORK  >= MAX( 1,2*K ).

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
          On exit, if INFO = -24, DWORK(1) returns the minimum value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          If DEFL = 'C', LDWORK >= MAX( 1,MAX( 2*N,8*K ) );
          if DEFL = 'A', LDWORK >= MAX( 1,K + MAX( 2*N,8*K ) ).
Warning Indicator 
  IWARN   INTEGER
          = 0        :  no warnings;
          = 1,..,N-1 :  A is in periodic Schur form, but the
                        algorithm was not able to reveal information
                        about the eigenvalues from the 2-by-2
                        blocks.
                        ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i),
                        can be incorrect for i = 1, ..., IWARN+1.
Error Indicator 
  INFO    INTEGER
          = 0      :  succesful exit;
          < 0      :  if INFO = -i, the i-th argument had an illegal
                      value;
          = 1,..,N :  the periodic QZ iteration did not converge.
                      A is not in periodic Schur form, but
                      ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i), for
                      i = INFO+1,...,N should be correct.
Method 
  A modified version of the periodic QZ algorithm is used [1], [2].
References 
  [1] Bojanczyk, A., Golub, G. H. and Van Dooren, P.
      The periodic Schur decomposition: algorithms and applications.
      In F.T. Luk (editor), Advanced Signal Processing Algorithms,
      Architectures, and Implementations III, Proc. SPIE Conference,
      vol. 1770, pp. 31-42, 1992.

  [2] Kressner, D.
      An efficient and reliable implementation of the periodic QZ
      algorithm. IFAC Workshop on Periodic Control Systems (PSYCO
      2001), Como (Italy), August 27-28 2001. Periodic Control
      Systems 2001 (IFAC Proceedings Volumes), Pergamon.
Numerical Aspects 
  The implemented method is numerically backward stable.
                              3
  The algorithm requires 0(K N ) floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB03BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            KMAX, NMAX
      PARAMETER          ( KMAX = 6, NMAX = 50 )
      INTEGER            LDA1, LDA2, LDQ1, LDQ2, LDWORK, LIWORK
      PARAMETER          ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX,
     $                     LDQ2 = NMAX,
     $                     LDWORK = KMAX + MAX( 2*NMAX, 8*KMAX ),
     $                     LIWORK = 2*KMAX )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ, DEFL, JOB
      INTEGER            H, I, IHI, ILO, INFO, IWARN, J, K, L, N
*
*     .. Local Arrays ..
      INTEGER            IWORK( LIWORK ), QIND( KMAX ), S( KMAX ),
     $                   SCAL( NMAX )
      DOUBLE PRECISION   A( LDA1, LDA2, KMAX ), ALPHAI( NMAX ),
     $                   ALPHAR( NMAX ), BETA( NMAX ), DWORK( LDWORK),
     $                   Q( LDQ1, LDQ2, KMAX )
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           MB03BD
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) JOB, DEFL, COMPQ, K, N, H, ILO, IHI
      IF( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         READ( NIN, FMT = * ) ( S( I ), I = 1, K )
         READ( NIN, FMT = * ) ( ( ( A( I, J, L ), J = 1, N ),
     $                                I = 1, N ), L = 1, K )
         IF( LSAME( COMPQ, 'U' ) )
     $      READ( NIN, FMT = * ) ( ( ( Q( I, J, L ), J = 1, N ),
     $                                   I = 1, N ), L = 1, K )
         IF( LSAME( COMPQ, 'P' ) ) THEN
            READ( NIN, FMT = * ) ( QIND( I ), I = 1, K )
            DO 10 L = 1, K
               IF( QIND( L ).GT.0 )
     $            READ( NIN, FMT = * ) ( ( Q( I, J, QIND( L ) ),
     $                                    J = 1, N ), I = 1, N )
   10       CONTINUE
         END IF
*        Compute the eigenvalues and the transformed matrices, if
*        required.
         CALL MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, A,
     $                LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, BETA,
     $                SCAL, IWORK, LIWORK, DWORK, LDWORK, IWARN, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE IF( IWARN.EQ.0 ) THEN
            IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'T' ) ) THEN
               WRITE( NOUT, FMT = 99996 )
               DO 30 L = 1, K
                  WRITE( NOUT, FMT = 99988 ) L
                  DO 20 I = 1, N
                     WRITE( NOUT, FMT = 99995 ) ( A( I, J, L ), J = 1, N
     $                                          )
   20             CONTINUE
   30          CONTINUE
            END IF
            IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN
               WRITE( NOUT, FMT = 99994 )
               DO 50 L = 1, K
                  WRITE( NOUT, FMT = 99988 ) L
                  DO 40 I = 1, N
                     WRITE( NOUT, FMT = 99995 ) ( Q( I, J, L ), J = 1, N
     $                                          )
   40             CONTINUE
   50          CONTINUE
            ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
               WRITE( NOUT, FMT = 99994 )
               DO 70 L = 1, K
                  IF( QIND( L ).GT.0 ) THEN
                     WRITE( NOUT, FMT = 99988 ) QIND( L )
                     DO 60 I = 1, N
                        WRITE( NOUT, FMT = 99995 )
     $                       ( Q( I, J, QIND( L ) ), J = 1, N )
   60                CONTINUE
                  END IF
   70          CONTINUE
            END IF
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, N )
            WRITE( NOUT, FMT = 99992 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, N )
            WRITE( NOUT, FMT = 99991 )
            WRITE( NOUT, FMT = 99995 ) (   BETA( I ), I = 1, N )
            WRITE( NOUT, FMT = 99990 )
            WRITE( NOUT, FMT = 99989 ) (   SCAL( I ), I = 1, N )
         ELSE
            WRITE( NOUT, FMT = 99987 ) IWARN
         END IF
      END IF
      STOP
*
99999 FORMAT( 'MB03BD EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT( 'INFO on exit from MB03BD = ', I2 )
99996 FORMAT( 'The matrix A on exit is ' )
99995 FORMAT( 50( 1X, F8.4 ) )
99994 FORMAT( 'The matrix Q on exit is ' )
99993 FORMAT( 'The vector ALPHAR is ' )
99992 FORMAT( 'The vector ALPHAI is ' )
99991 FORMAT( 'The vector BETA is ' )
99990 FORMAT( 'The vector SCAL is ' )
99989 FORMAT( 50( 1X, I8 ) )
99988 FORMAT( 'The factor ', I2, ' is ' )
99987 FORMAT( 'IWARN on exit from MB03BD = ', I2 )
      END
Program Data 
MB03BD EXAMPLE PROGRAM DATA
   S   C   I   3   3   2   1   3
  -1     1    -1
   2.0   0.0   1.0
   0.0  -2.0  -1.0
   0.0   0.0   3.0
   1.0   2.0   0.0
   4.0  -1.0   3.0
   0.0   3.0   1.0
   1.0   0.0   1.0
   0.0   4.0  -1.0
   0.0   0.0  -2.0
Program Results 
MB03BD EXAMPLE PROGRAM RESULTS
The matrix A on exit is 
The factor  1 is 
  -2.0599   0.6251  -0.5959
   0.0000   2.9774  -1.1479
   0.0000   0.0000   1.9566
The factor  2 is 
  -3.9705  -0.3216   2.9819
  -2.0077   2.2246  -1.9116
   0.0000   0.0000   1.8990
The factor  3 is 
   2.6946  -2.9508   0.5659
   0.0000   1.3385   0.0097
   0.0000   0.0000  -2.2180
The matrix Q on exit is 
The factor  1 is 
  -0.3331  -0.7427  -0.5809
   0.9394  -0.2084  -0.2723
   0.0812  -0.6364   0.7671
The factor  2 is 
   0.2841  -0.7723  -0.5683
   0.9515   0.1539   0.2664
  -0.1183  -0.6164   0.7785
The factor  3 is 
  -0.7883  -0.5567   0.2619
   0.6055  -0.6263   0.4911
  -0.1094   0.5457   0.8308
The vector ALPHAR is 
   0.3230   0.6459  -0.8752
The vector ALPHAI is 
   0.5694  -1.1387   0.0000
The vector BETA is 
   1.0000   1.0000   1.0000
The vector SCAL is 
        0       -1       -1
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03BE.html000077500000000000000000000053511201767322700160600ustar00rootroot00000000000000 MB03BE - SLICOT Library Routine Documentation

MB03BE

Applying 10 iterations of a real single shifted periodic QZ algorithm to a 2-by-2 matrix product

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply 10 iterations of a real single shifted periodic QZ
  algorithm to the 2-by-2 product of matrices stored in the array A.
Specification 
      SUBROUTINE MB03BE( K, AMAP, S, SINV, A, LDA1, LDA2 )
C     .. Scalar Arguments ..
      INTEGER           K, LDA1, LDA2, SINV
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*)
Arguments

Input/Output Parameters 

  K       (input)  INTEGER
          The number of factors.  K >= 1.

  AMAP    (input)  INTEGER array, dimension (K)
          The map for accessing the factors, i.e., if AMAP(I) = J,
          then the factor A_I is stored at the J-th position in A.

  S       (input)  INTEGER array, dimension (K)
          The signature array. Each entry of S must be 1 or -1.

  SINV    (input)  INTEGER
          Signature multiplier. Entries of S are virtually
          multiplied by SINV.

  A       (input/output)  DOUBLE PRECISION array, dimension
                          (LDA1,LDA2,K)
          On entry, the leading 2-by-2-by-K part of this array must
          contain a 2-by-2 product (implicitly represented by its K
          factors) in upper Hessenberg form.
          On exit, the leading 2-by-2-by-K part of this array
          contains the product after 10 iterations of a real shifted
          periodic QZ algorithm.

  LDA1    INTEGER
          The first leading dimension of the array A.  LDA1 >= 2.

  LDA2    INTEGER
          The second leading dimension of the array A.  LDA2 >= 2.
Method 
  Ten iterations of a real single shifted periodic QZ algorithm are
  applied to the 2-by-2 matrix product A.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03CD.html000077500000000000000000000175201201767322700160610ustar00rootroot00000000000000 MB03CD - SLICOT Library Routine Documentation

MB03CD

Exchanging eigenvalues of a real 2-by-2, 3-by-3 or 4-by-4 block upper triangular pencil (factored version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal matrices Q1, Q2, Q3 for a real 2-by-2,
  3-by-3, or 4-by-4 regular block upper triangular pencil

                 ( A11 A12 ) ( B11 B12 )     ( D11 D12 )
    aAB - bD = a (         ) (         ) - b (         ),        (1)
                 (  0  A22 ) (  0  B22 )     (  0  D22 )

  such that the pencil a(Q3' A Q2 )(Q2' B Q1 ) - b(Q3' D Q1) is
  still in block upper triangular form, but the eigenvalues in
  Spec(A11 B11, D11), Spec(A22 B22, D22) are exchanged, where
  Spec(X,Y) denotes the spectrum of the matrix pencil (X,Y).

  Optionally, to upper triangularize the real regular pencil in
  block lower triangular form

               ( A11  0  ) ( B11  0  )     ( D11  0  )
  aAB - bD = a (         ) (         ) - b (         ),          (2)
               ( A21 A22 ) ( B21 B22 )     ( D21 D22 )

  while keeping the eigenvalues in the same diagonal position.
Specification 
      SUBROUTINE MB03CD( UPLO, N1, N2, PREC, A, LDA, B, LDB, D, LDD, Q1,
     $                   LDQ1, Q2, LDQ2, Q3, LDQ3, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, LDD, LDQ1, LDQ2, LDQ3, LDWORK,
     $                   N1, N2
      DOUBLE PRECISION   PREC
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ),
     $                   Q3( LDQ3, * )
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies if the pencil is in lower or upper block
          triangular form on entry, as follows:
          = 'U': Upper block triangular, eigenvalues are exchanged
                 on exit;
          = 'L': Lower block triangular, eigenvalues are not
                 exchanged on exit.
Input/Output Parameters 
  N1      (input/output) INTEGER
          Size of the upper left block, N1 <= 2.
          If UPLO = 'U' and INFO = 0, or UPLO = 'L' and INFO <> 0,
          N1 and N2 are exchanged on exit; otherwise, N1 is
          unchanged on exit.

  N2      (input/output) INTEGER
          Size of the lower right block, N2 <= 2.
          If UPLO = 'U' and INFO = 0, or UPLO = 'L' and INFO <> 0,
          N1 and N2 are exchanged on exit; otherwise, N2 is
          unchanged on exit.

  PREC    (input) DOUBLE PRECISION
          The machine precision, (relative machine precision)*base.
          See the LAPACK Library routine DLAMCH.

  A       (input or input/output) DOUBLE PRECISION array, dimension
             (LDA, N1+N2)
          On entry, the leading (N1+N2)-by-(N1+N2) part of this
          array must contain the matrix A of the pencil aAB - bD.
          The (2,1) block, if UPLO = 'U', or the (1,2) block, if
          UPLO = 'L', need not be set to zero.
          On exit, if N1 = N2 = 1, this array contains the matrix
                            [  0 1 ]
          J' A J, where J = [ -1 0 ]; otherwise, this array is
          unchanged on exit.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= N1+N2.

  B       (input or input/output) DOUBLE PRECISION array, dimension
             (LDB, N1+N2)
          On entry, the leading (N1+N2)-by-(N1+N2) part of this
          array must contain the matrix B of the pencil aAB - bD.
          The (2,1) block, if UPLO = 'U', or the (1,2) block, if
          UPLO = 'L', need not be set to zero.
          On exit, if N1 = N2 = 1, this array contains the matrix
          J' B J; otherwise, this array is unchanged on exit.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N1+N2.

  D       (input/output) DOUBLE PRECISION array, dimension
             (LDD, N1+N2)
          On entry, the leading (N1+N2)-by-(N1+N2) part of this
          array must contain the matrix D of the pencil aAB - bD.
          On exit, if N1 = 2 or N2 = 2, the leading
          (N1+N2)-by-(N1+N2) part of this array contains the
          transformed matrix D in real Schur form. If N1 = 1 and
          N2 = 1, this array contains the matrix J' D J.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= N1+N2.

  Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N1+N2)
          The leading (N1+N2)-by-(N1+N2) part of this array contains
          the first orthogonal transformation matrix.

  LDQ1    INTEGER
          The leading dimension of the array Q1.  LDQ1 >= N1+N2.

  Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N1+N2)
          The leading (N1+N2)-by-(N1+N2) part of this array contains
          the second orthogonal transformation matrix.

  LDQ2    INTEGER
          The leading dimension of the array Q2.  LDQ2 >= N1+N2.

  Q3      (output) DOUBLE PRECISION array, dimension (LDQ3, N1+N2)
          The leading (N1+N2)-by-(N1+N2) part of this array contains
          the third orthogonal transformation matrix.

  LDQ3    INTEGER
          The leading dimension of the array Q3.  LDQ3 >= N1+N2.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          If N1+N2 = 2 then DWORK is not referenced.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If N1+N2 = 2, then LDWORK = 0; otherwise,
          LDWORK >= 16*N1 + 10*N2 + 23, UPLO = 'U';
          LDWORK >= 10*N1 + 16*N2 + 23, UPLO = 'L'.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          = 1: the QZ iteration failed in the LAPACK routine DGGEV;
          = 2: another error occured while executing a routine in
               DGGEV;
          = 3: the QZ iteration failed in the LAPACK routine DGGES;
          = 4: another error occured during execution of DGGES;
          = 5: reordering of aAB - bD in the LAPACK routine DTGSEN
               failed because the transformed matrix pencil aAB - bD
               would be too far from generalized Schur form;
               the problem is very ill-conditioned.
Method 
  The algorithm uses orthogonal transformations as described in [2]
  (page 21). The QZ algorithm is used for N1 = 2 or N2 = 2, but it
  always acts on an upper block triangular pencil.
References 
  [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
      Numerical computation of deflating subspaces of skew-
      Hamiltonian/Hamiltonian pencils.
      SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.

  [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
  The algorithm is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03DD.html000077500000000000000000000164041201767322700160620ustar00rootroot00000000000000 MB03DD - SLICOT Library Routine Documentation

MB03DD

Exchanging eigenvalues of a real 2-by-2, 3-by-3 or 4-by-4 block upper triangular pencil

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal matrices Q1 and Q2 for a real 2-by-2,
  3-by-3, or 4-by-4 regular block upper triangular pencil

                 ( A11 A12 )     ( B11 B12 )
    aA - bB =  a (         ) - b (         ),                    (1)
                 (  0  A22 )     (  0  B22 )

  such that the pencil a(Q2' A Q1) - b(Q2' B Q1) is still in block
  upper triangular form, but the eigenvalues in Spec(A11, B11),
  Spec(A22, B22) are exchanged, where Spec(X,Y) denotes the spectrum
  of the matrix pencil (X,Y).

  Optionally, to upper triangularize the real regular pencil in
  block lower triangular form

                ( A11  0  )     ( B11  0  )
    aA - bB = a (         ) - b (         ),                     (2)
                ( A21 A22 )     ( B21 B22 )

  while keeping the eigenvalues in the same diagonal position.
Specification 
      SUBROUTINE MB03DD( UPLO, N1, N2, PREC, A, LDA, B, LDB, Q1, LDQ1,
     $                   Q2, LDQ2, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, N1, N2
      DOUBLE PRECISION   PREC
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   Q1( LDQ1, * ), Q2( LDQ2, * )
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Specifies if the pencil is in lower or upper block
          triangular form on entry, as follows:
          = 'U': Upper block triangular, eigenvalues are exchanged
                 on exit;
          = 'T': Upper block triangular, B triangular, eigenvalues
                 are exchanged on exit;
          = 'L': Lower block triangular, eigenvalues are not
                 exchanged on exit.
Input/Output Parameters 
  N1      (input/output) INTEGER
          Size of the upper left block, N1 <= 2.
          If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L'
          and INFO <> 0, N1 and N2 are exchanged on exit; otherwise,
          N1 is unchanged on exit.

  N2      (input/output) INTEGER
          Size of the lower right block, N2 <= 2.
          If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L'
          and INFO <> 0, N1 and N2 are exchanged on exit; otherwise,
          N2 is unchanged on exit.

  PREC    (input) DOUBLE PRECISION
          The machine precision, (relative machine precision)*base.
          See the LAPACK Library routine DLAMCH.

  A       (input/output) DOUBLE PRECISION array, dimension
             (LDA, N1+N2)
          On entry, the leading (N1+N2)-by-(N1+N2) part of this
          array must contain the matrix A of the pencil aA - bB.
          On exit, if N1 = N2 = 1, this array is unchanged, if
          UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains
                                       [  0 1 ]
          the matrix J' A J, where J = [ -1 0 ]; otherwise, this
          array contains the transformed quasi-triangular matrix in
          generalized real Schur form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= N1+N2.

  B       (input/output) DOUBLE PRECISION array, dimension
             (LDB, N1+N2)
          On entry, the leading (N1+N2)-by-(N1+N2) part of this
          array must contain the matrix B of the pencil aA - bB.
          On exit, if N1 = N2 = 1, this array is unchanged, if
          UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains
          the matrix J' B J; otherwise, this array contains the
          transformed upper triangular matrix in generalized real
          Schur form.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N1+N2.

  Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N1+N2)
          The leading (N1+N2)-by-(N1+N2) part of this array contains
          the first orthogonal transformation matrix.

  LDQ1    INTEGER
          The leading dimension of the array Q1.  LDQ1 >= N1+N2.

  Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N1+N2)
          The leading (N1+N2)-by-(N1+N2) part of this array contains
          the second orthogonal transformation matrix.

  LDQ2    INTEGER
          The leading dimension of the array Q2.  LDQ2 >= N1+N2.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          If N1+N2 = 2 then DWORK is not referenced.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If N1+N2 = 2, then LDWORK = 0; otherwise,
          LDWORK >= 16*N1 + 10*N2 + 23, if UPLO = 'U';
          LDWORK >=  7*N1 +  7*N2 + 16, if UPLO = 'T';
          LDWORK >= 10*N1 + 16*N2 + 23, if UPLO = 'L'.
          For good performance LDWORK should be generally larger.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          = 1: the QZ iteration failed in the LAPACK routine DGGEV;
          = 2: another error occured while executing a routine in
               DGGEV;
          = 3: the QZ iteration failed in the LAPACK routine DGGES
               (if UPLO <> 'T') or DHGEQZ (if UPLO = 'T');
          = 4: another error occured during execution of DGGES or
               DHGEQZ;
          = 5: reordering of aA - bB in the LAPACK routine DTGSEN
               failed because the transformed matrix pencil aA - bB
               would be too far from generalized Schur form;
               the problem is very ill-conditioned.
Method 
  The algorithm uses orthogonal transformations as described in [2]
  (page 30). The QZ algorithm is used for N1 = 2 or N2 = 2, but it
  always acts on an upper block triangular pencil.
References 
  [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
      Numerical computation of deflating subspaces of skew-
      Hamiltonian/Hamiltonian pencils.
      SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.

  [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
  The algorithm is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03ED.html000077500000000000000000000136661201767322700160720ustar00rootroot00000000000000 MB03ED - SLICOT Library Routine Documentation

MB03ED

Reducing a real 2-by-2 or 4-by-4 block (anti-)diagonal skew-Hamiltonian/Hamiltonian pencil to generalized Schur form and moving eigenvalues with negative real parts to the top (factored version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal matrices Q1, Q2, Q3 for a real 2-by-2 or
  4-by-4 regular pencil

                 ( A11  0  ) ( B11  0  )     (  0  D12 )
    aAB - bD = a (         ) (         ) - b (         ),        (1)
                 (  0  A22 ) (  0  B22 )     ( D21  0  )

  such that Q3' A Q2 and Q2' B Q1 are upper triangular, Q3' D Q1 is
  upper quasi-triangular, and the eigenvalues with negative real
  parts (if there are any) are allocated on the top. The submatrices
  A11, A22, B11, B22 and D12 are upper triangular. If D21 is 2-by-2,
  then all other blocks are nonsingular and the product

     -1        -1    -1        -1
  A22   D21 B11   A11   D12 B22   has a pair of complex conjugate
  eigenvalues.
Specification 
      SUBROUTINE MB03ED( N, PREC, A, LDA, B, LDB, D, LDD, Q1, LDQ1, Q2,
     $                   LDQ2, Q3, LDQ3, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDD, LDQ1, LDQ2, LDQ3, LDWORK,
     $                   N
      DOUBLE PRECISION   PREC
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ),
     $                   Q3( LDQ3, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the input pencil, N = 2 or N = 4.

  PREC    (input) DOUBLE PRECISION
          The machine precision, (relative machine precision)*base.
          See the LAPACK Library routine DLAMCH.

  A       (input) DOUBLE PRECISION array, dimension (LDA, N)
          The leading N-by-N upper triangular part of this array
          must contain the upper triangular matrix A of the pencil
          aAB - bD. The strictly lower triangular part and the
          entries of the (1,2) block are not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= N.

  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
          The leading N-by-N upper triangular part of this array
          must contain the upper triangular matrix B of the pencil
          aAB - bD. The strictly lower triangular part and the
          entries of the (1,2) block are not referenced.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N.

  D       (input/output) DOUBLE PRECISION array, dimension (LDD, N)
          On entry, the leading N-by-N part of this array must
          contain the matrix D of the pencil aAB - bD.
          On exit, if N = 4, the leading N-by-N part of this array
          contains the transformed matrix D in real Schur form.
          If N = 2, this array is unchanged on exit.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= N.

  Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N)
          The leading N-by-N part of this array contains the first
          orthogonal transformation matrix.

  LDQ1    INTEGER
          The leading dimension of the array Q1.  LDQ1 >= N.

  Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
          The leading N-by-N part of this array contains the second
          orthogonal transformation matrix.

  LDQ2    INTEGER
          The leading dimension of the array Q2.  LDQ2 >= N.

  Q3      (output) DOUBLE PRECISION array, dimension (LDQ3, N)
          The leading N-by-N part of this array contains the third
          orthogonal transformation matrix.

  LDQ3    INTEGER
          The leading dimension of the array Q3.  LDQ3 >= N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          If N = 2, then DWORK is not referenced.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If N = 4, then LDWORK >= 79. For good performance LDWORK
          should be generally larger.
          If N = 2, then LDWORK >= 0.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          = 1: the QZ iteration failed in the LAPACK routine DGGES;
          = 2: another error occured during execution of DGGES.
Method 
  The algorithm uses orthogonal transformations as described on page
  20 in [2].
References 
  [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
      Numerical computation of deflating subspaces of skew-
      Hamiltonian/Hamiltonian pencils.
      SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.

  [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
  The algorithm is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03FD.html000077500000000000000000000126221201767322700160620ustar00rootroot00000000000000 MB03FD - SLICOT Library Routine Documentation

MB03FD

Reducing a real 2-by-2 or 4-by-4 block (anti-)diagonal skew-Hamiltonian/Hamiltonian pencil to generalized Schur form and moving eigenvalues with negative real parts to the top

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal matrices Q1 and Q2 for a real 2-by-2 or
  4-by-4 regular pencil

                ( A11  0  )     (  0  B12 )
    aA - bB = a (         ) - b (         ),                     (1)
                (  0  A22 )     ( B21  0  )

  such that Q2' A Q1 is upper triangular, Q2' B Q1 is upper quasi-
  triangular, and the eigenvalues with negative real parts (if there
  are any) are allocated on the top. The submatrices A11, A22, and
  B12 are upper triangular. If B21 is 2-by-2, then all the other
  blocks are nonsingular and the product

     -1        -1
  A11   B12 A22   B21 has a pair of complex conjugate eigenvalues.
Specification 
      SUBROUTINE MB03FD( N, PREC, A, LDA, B, LDB, Q1, LDQ1, Q2, LDQ2,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, N
      DOUBLE PRECISION   PREC
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   Q1( LDQ1, * ), Q2( LDQ2, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the input pencil, N = 2 or N = 4.

  PREC    (input) DOUBLE PRECISION
          The machine precision, (relative machine precision)*base.
          See the LAPACK Library routine DLAMCH.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A of the pencil aA - bB.
          If N = 2, the diagonal elements only are referenced.
          On exit, if N = 4, the leading N-by-N part of this array
          contains the transformed upper triangular matrix of the
          generalized real Schur form of the pencil aA - bB.
          If N = 2, this array is unchanged on exit.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= N.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
          On entry, the leading N-by-N part of this array must
          contain the matrix B of the pencil aA - bB.
          If N = 2, the anti-diagonal elements only are referenced.
          On exit, if N = 4, the leading N-by-N part of this array
          contains the transformed real Schur matrix of the
          generalized real Schur form of the pencil aA - bB.
          If N = 2, this array is unchanged on exit.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N.

  Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N)
          The leading N-by-N part of this array contains the first
          orthogonal transformation matrix.

  LDQ1    INTEGER
          The leading dimension of the array Q1.  LDQ1 >= N.

  Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
          The leading N-by-N part of this array contains the second
          orthogonal transformation matrix.

  LDQ2    INTEGER
          The leading dimension of the array Q2.  LDQ2 >= N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          If N = 2, then DWORK is not referenced.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If N = 4, then LDWORK >= 63. For good performance LDWORK
          should be generally larger.
          If N = 2, then LDWORK >= 0.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          = 1: the QZ iteration failed in the LAPACK routine DGGES;
          = 2: another error occured during execution of DGGES.
Method 
  The algorithm uses orthogonal transformations as described on page
  29 in [2].
References 
  [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
      Numerical computation of deflating subspaces of skew-
      Hamiltonian/Hamiltonian pencils.
      SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.

  [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
  The algorithm is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03GD.html000077500000000000000000000107711201767322700160660ustar00rootroot00000000000000 MB03GD - SLICOT Library Routine Documentation

MB03GD

Exchanging eigenvalues of a real 2-by-2 or 4-by-4 block upper triangular skew-Hamiltonian/Hamiltonian pencil (factored version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an orthogonal matrix Q and an orthogonal symplectic
  matrix U for a real regular 2-by-2 or 4-by-4 skew-Hamiltonian/
  Hamiltonian pencil a J B' J' B - b D with

        ( B11  B12 )      (  D11  D12  )
    B = (          ), D = (            ),
        (  0   B22 )      (   0  -D11' )

  such that J Q' J' D Q and U' B Q keep block triangular form, but
  the eigenvalues are reordered.
Specification 
      SUBROUTINE MB03GD( N, B, LDB, D, LDD, MACPAR, Q, LDQ, U, LDU,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDB, LDD, LDQ, LDU, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( LDD, * ), DWORK( * ),
     $                   MACPAR( * ), Q( LDQ, * ), U( LDU, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the pencil a J B' J' B - b D. N = 2 or N = 4.

  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
          The leading N-by-N part of this array must contain the
          non-trivial factor of the decomposition of the
          skew-Hamiltonian input matrix J B' J' B. The (2,1) block
          is not referenced.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N.

  D       (input) DOUBLE PRECISION array, dimension (LDD, N)
          The leading N/2-by-N part of this array must contain the
          first block row of the second matrix of a J B' J' B - b D.
          The matrix D has to be Hamiltonian. The strict lower
          triangle of the (1,2) block is not referenced.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= N/2.

  MACPAR  (input)  DOUBLE PRECISION array, dimension (2)
          Machine parameters:
          MACPAR(1)  (machine precision)*base, DLAMCH( 'P' );
          MACPAR(2)  safe minimum,             DLAMCH( 'S' ).
          This argument is not used for N = 2.

  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
          The leading N-by-N part of this array contains the
          orthogonal transformation matrix Q.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= N.

  U       (output) DOUBLE PRECISION array, dimension (LDU, N)
          The leading N-by-N part of this array contains the
          orthogonal symplectic transformation matrix U.

  LDU     INTEGER
          The leading dimension of the array U.  LDU >= N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          If N = 2 then DWORK is not referenced.

  LDWORK  INTEGER
          The length of the array DWORK.
          If N = 2 then LDWORK >= 0; if N = 4 then LDWORK >= 12.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          = 1: B11 or B22 is a (numerically) singular matrix.
Method 
  The algorithm uses orthogonal transformations as described on page
  22 in [1], but with an improved implementation.
References 
  [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
  The algorithm is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03HD.html000077500000000000000000000106471201767322700160710ustar00rootroot00000000000000 MB03HD - SLICOT Library Routine Documentation

MB03HD

Exchanging eigenvalues of a real 2-by-2 or 4-by-4 skew-Hamiltonian/Hamiltonian pencil in structured Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine an orthogonal matrix Q, for a real regular 2-by-2 or
  4-by-4 skew-Hamiltonian/Hamiltonian pencil

                  ( A11 A12  )     ( B11  B12  )
      aA - bB = a (        T ) - b (         T )
                  (  0  A11  )     (  0  -B11  )

                                          T  T
  in structured Schur form, such that  J Q  J  (aA - bB) Q  is still
  in structured Schur form but the eigenvalues are exchanged.
Specification 
      SUBROUTINE MB03HD( N, A, LDA, B, LDB, MACPAR, Q, LDQ, DWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDQ, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   MACPAR( * ), Q( LDQ, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the pencil aA - bB.  N = 2 or N = 4.

  A       (input) DOUBLE PRECISION array, dimension (LDA, N)
          If N = 4, the leading N/2-by-N upper trapezoidal part of
          this array must contain the first block row of the skew-
          Hamiltonian matrix A of the pencil aA - bB in structured
          Schur form. Only the entries (1,1), (1,2), (1,4), and
          (2,2) are referenced.
          If N = 2, this array is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= N/2.

  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
          The leading N/2-by-N part of this array must contain the
          first block row of the Hamiltonian matrix B of the
          pencil aA - bB in structured Schur form. The entry (2,3)
          is not referenced.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= N/2.

  MACPAR  (input)  DOUBLE PRECISION array, dimension (2)
          Machine parameters:
          MACPAR(1)  (machine precision)*base, DLAMCH( 'P' );
          MACPAR(2)  safe minimum,             DLAMCH( 'S' ).
          This argument is not used for N = 2.

  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
          The leading N-by-N part of this array contains the
          orthogonal transformation matrix Q.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (24)
          If N = 2, then DWORK is not referenced.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          = 1: the leading N/2-by-N/2 block of the matrix B is
               numerically singular.
Method 
  The algorithm uses orthogonal transformations as described on page
  31 in [2]. The structure is exploited.
References 
  [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
      Numerical computation of deflating subspaces of skew-
      Hamiltonian/Hamiltonian pencils.
      SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.

  [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
  The algorithm is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03ID.html000077500000000000000000000304261201767322700160670ustar00rootroot00000000000000 MB03ID - SLICOT Library Routine Documentation

MB03ID

Moving eigenvalues with negative real parts of a real skew-Hamiltonian/Hamiltonian pencil in structured Schur form to the leading subpencil (factored version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To move the eigenvalues with strictly negative real parts of an
  N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in
  structured Schur form, with

                       (  0  I  )      (  A  D  )      (  B  F  )
    S = J Z' J' Z, J = (        ), Z = (        ), H = (        ),
                       ( -I  0  )      (  0  C  )      (  0 -B' )

  to the leading principal subpencil, while keeping the triangular
  form. Above, A is upper triangular, B is upper quasi-triangular,
  and C is lower triangular.
  The matrices Z and H are transformed by an orthogonal symplectic
  matrix U and an orthogonal matrix Q such that

                    (  Aout  Dout  )
    Zout = U' Z Q = (              ), and
                    (    0   Cout  )
                                                                 (1)
                         (  Bout  Fout  )
    Hout = J Q' J' H Q = (              ),
                         (    0  -Bout' )

  where Aout, Bout and Cout remain in triangular form.
  Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q
  that fulfills (1) is computed.
  Optionally, if COMPU = 'I' or COMPU = 'U', the orthogonal
  symplectic matrix

        (  U1  U2  )
    U = (          )
        ( -U2  U1  )

  that fulfills (1) is computed.
Specification 
      SUBROUTINE MB03ID( COMPQ, COMPU, N, A, LDA, C, LDC, D, LDD, B,
     $                   LDB, F, LDF, Q, LDQ, U1, LDU1, U2, LDU2, NEIG,
     $                   IWORK, LIWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPU
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDF, LDQ, LDU1, LDU2,
     $                   LDWORK, LIWORK, N, NEIG
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK( *  ), F( LDF, * ),
     $                   Q( LDQ, * ), U1( LDU1, * ), U2( LDU2, * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          Specifies whether or not the orthogonal transformations
          should be accumulated in the array Q, as follows:
          = 'N':  Q is not computed;
          = 'I':  the array Q is initialized internally to the unit
                  matrix, and the orthogonal matrix Q is returned;
          = 'U':  the array Q contains an orthogonal matrix Q0 on
                  entry, and the matrix Q0*Q is returned, where Q
                  is the product of the orthogonal transformations
                  that are applied to the pencil aS - bH to reorder
                  the eigenvalues.

  COMPU   CHARACTER*1
          Specifies whether or not the orthogonal symplectic
          transformations should be accumulated in the arrays U1 and
          U2, as follows:
          = 'N':  U1 and U2 are not computed;
          = 'I':  the arrays U1 and U2 are initialized internally,
                  and the submatrices U1 and U2 defining the
                  orthogonal symplectic matrix U are returned;
          = 'U':  the arrays U1 and U2 contain the corresponding
                  submatrices of an orthogonal symplectic matrix U0
                  on entry, and the updated submatrices U1 and U2
                  of the matrix product U0*U are returned, where U
                  is the product of the orthogonal symplectic
                  transformations that are applied to the pencil
                  aS - bH to reorder the eigenvalues.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the pencil aS - bH.  N >= 0, even.

  A       (input/output) DOUBLE PRECISION array, dimension
                         (LDA, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the upper triangular matrix A. The elements of the
          strictly lower triangular part of this array are not used.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed matrix Aout.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1, N/2).

  C       (input/output) DOUBLE PRECISION array, dimension
                         (LDC, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the lower triangular matrix C. The elements of the
          strictly upper triangular part of this array are not used.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed matrix Cout.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1, N/2).

  D       (input/output) DOUBLE PRECISION array, dimension
                         (LDD, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the matrix D.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed matrix Dout.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1, N/2).

  B       (input/output) DOUBLE PRECISION array, dimension
                         (LDB, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the upper quasi-triangular matrix B.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed upper quasi-triangular part of
          the matrix Bout.
          The part below the first subdiagonal of this array is
          not referenced.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1, N/2).

  F       (input/output) DOUBLE PRECISION array, dimension
                         (LDF, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the upper triangular part of the symmetric matrix
          F.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed upper triangular part of the
          matrix Fout.
          The strictly lower triangular part of this array is not
          referenced, except for the element F(N/2,N/2-1), but its
          initial value is preserved.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= MAX(1, N/2).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
          On entry, if COMPQ = 'U', then the leading N-by-N part of
          this array must contain a given matrix Q0, and on exit,
          the leading N-by-N part of this array contains the product
          of the input matrix Q0 and the transformation matrix Q
          used to transform the matrices S and H.
          On exit, if COMPQ = 'I', then the leading N-by-N part of
          this array contains the orthogonal transformation matrix
          Q.
          If COMPQ = 'N' this array is not referenced.

  LDQ     INTEGER
          The leading dimension of of the array Q.
          LDQ >= 1,         if COMPQ = 'N';
          LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.

  U1      (input/output) DOUBLE PRECISION array, dimension
                         (LDU1, N/2)
          On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
          of this array must contain the upper left block of a
          given matrix U0, and on exit, the leading N/2-by-N/2 part
          of this array contains the updated upper left block U1 of
          the product of the input matrix U0 and the transformation
          matrix U used to transform the matrices S and H.
          On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
          of this array contains the upper left block U1 of the
          orthogonal symplectic transformation matrix U.
          If COMPU = 'N' this array is not referenced.

  LDU1    INTEGER
          The leading dimension of the array U1.
          LDU1 >= 1,           if COMPU = 'N';
          LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'.

  U2      (input/output) DOUBLE PRECISION array, dimension
                         (LDU2, N/2)
          On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
          of this array must contain the upper right block of a
          given matrix U0, and on exit, the leading N/2-by-N/2 part
          of this array contains the updated upper right block U2 of
          the product of the input matrix U0 and the transformation
          matrix U used to transform the matrices S and H.
          On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
          of this array contains the upper right block U2 of the
          orthogonal symplectic transformation matrix U.
          If COMPU = 'N' this array is not referenced.

  LDU2    INTEGER
          The leading dimension of the array U2.
          LDU2 >= 1,           if COMPU = 'N';
          LDU2 >= MAX(1, N/2), if COMPU = 'U' or COMPU = 'I'.

  NEIG    (output) INTEGER
          The number of eigenvalues in aS - bH with strictly
          negative real part.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)

  LIWORK  INTEGER
          The dimension of the array IWORK.
          LIWORK >= N+1.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If COMPQ = 'N',
             LDWORK >= MAX(2*N+48,171);
          if COMPQ = 'I' or COMPQ = 'U',
             LDWORK >= MAX(4*N+48,171).
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          < 0: if INFO = -i, the i-th argument had an illegal value;
          = 1: the periodic QZ algorithm did not converge in SLICOT
               Library routine MB03BB;
          = 2: an error occured during the execution of MB03CD;
          = 3: an error occured during the execution of MB03GD.
Method 
  The algorithm reorders the eigenvalues like the following scheme:

  Step 1: Reorder the eigenvalues in the subpencil aA - bB.
       I. Reorder the eigenvalues with negative real parts to the
          top.
      II. Reorder the eigenvalues with positive real parts to the
          bottom.

  Step 2: Reorder the remaining eigenvalues with negative real
          parts in the pencil aS - bH.
       I. Exchange the eigenvalues between the last diagonal block
          in aA - bB and the last diagonal block in aS - bH.
      II. Move the eigenvalues of the R-th block to the (MM+1)-th
          block, where R denotes the number of upper quasi-
          triangular blocks in aA - bB and MM denotes the current
          number of blocks in aA - bB with eigenvalues with negative
          real parts.

  The algorithm uses a sequence of orthogonal transformations as
  described on page 25 in [1]. To achieve those transformations the
  elementary subroutines MB03CD and MB03GD are called for the
  corresponding matrix structures.
References 
  [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
                                                            3
  The algorithm is numerically backward stable and needs O(N ) real
  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03JD.html000077500000000000000000000216361201767322700160730ustar00rootroot00000000000000 MB03JD - SLICOT Library Routine Documentation

MB03JD

Moving eigenvalues with negative real parts of a real skew-Hamiltonian/Hamiltonian pencil in structured Schur form to the leading subpencil

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To move the eigenvalues with strictly negative real parts of an
  N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in
  structured Schur form,

        (  A  D  )      (  B  F  )
    S = (        ), H = (        ),
        (  0  A' )      (  0 -B' )

  with A upper triangular and B upper quasi-triangular, to the
  leading principal subpencil, while keeping the triangular form:

           (  Aout  Dout  )         (  Bout  Fout  )
    Sout = (              ), Hout = (              ), where
           (    0   Aout' )         (  0    -Bout' )

  Aout is upper triangular and Bout is upper quasi-triangular.
  Optionally, if COMPQ = 'I' or COMPQ = 'U', an orthogonal matrix Q
  is determined such that the pencil

                                                  (  0  I  )
    J Q' J' (aS - bH) Q = aSout - bHout, with J = (        ),
                                                  ( -I  0  )

  keeps the triangular form, but all eigenvalues with strictly
  negative real part are in the leading principal subpencil.
Specification 
      SUBROUTINE MB03JD( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q,
     $                   LDQ, NEIG, IWORK, LIWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      INTEGER            INFO, LDA, LDB, LDD, LDF, LDQ, LDWORK, LIWORK,
     $                   N, NEIG
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   DWORK( * ),  F( LDF, * ), Q( LDQ, * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          Specifies whether or not the orthogonal transformations
          should be accumulated in the array Q, as follows:
          = 'N':  Q is not computed;
          = 'I':  the array Q is initialized internally to the unit
                  matrix, and the orthogonal matrix Q is returned;
          = 'U':  the array Q contains an orthogonal matrix Q0 on
                  entry, and the matrix Q0*Q is returned, where Q
                  is the product of the orthogonal transformations
                  that are applied to the pencil aS - bH to reorder
                  the eigenvalues.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the pencil aS - bH.  N >= 0, even.

  A       (input/output) DOUBLE PRECISION array, dimension
                         (LDA, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the upper triangular matrix A. The elements of the
          strictly lower triangular part of this array are not used.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed matrix Aout.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1, N/2).

  D       (input/output) DOUBLE PRECISION array, dimension
                        (LDD, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the upper triangular part of the skew-symmetric
          matrix D. The diagonal need not be set to zero.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed upper triangular part of the
          matrix Dout.
          The strictly lower triangular part of this array is
          not referenced, except for the element D(N/2,N/2-1), but
          its initial value is preserved.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1, N/2).

  B       (input/output) DOUBLE PRECISION array, dimension
                         (LDB, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the upper quasi-triangular matrix B.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed upper quasi-triangular part of
          the matrix Bout.
          The part below the first subdiagonal of this array is
          not referenced.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1, N/2).

  F       (input/output) DOUBLE PRECISION array, dimension
                        (LDF, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the upper triangular part of the symmetric matrix
          F.
          On exit, the leading  N/2-by-N/2 part of this array
          contains the transformed upper triangular part of the
          matrix Fout.
          The strictly lower triangular part of this array is not
          referenced, except for the element F(N/2,N/2-1), but its
          initial value is preserved.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= MAX(1, N/2).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
          On entry, if COMPQ = 'U', then the leading N-by-N part of
          this array must contain a given matrix Q0, and on exit,
          the leading N-by-N part of this array contains the product
          of the input matrix Q0 and the transformation matrix Q
          used to transform the matrices S and H.
          On exit, if COMPQ = 'I', then the leading N-by-N part of
          this array contains the orthogonal transformation matrix
          Q.
          If COMPQ = 'N' this array is not referenced.

  LDQ     INTEGER
          The leading dimension of of the array Q.
          LDQ >= 1,         if COMPQ = 'N';
          LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.

  NEIG    (output) INTEGER
          The number of eigenvalues in aS - bH with strictly
          negative real part.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)

  LIWORK  INTEGER
          The dimension of the array IWORK.
          LIWORK >= N+1.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If COMPQ = 'N',
             LDWORK >= MAX(2*N+32,108);
          if COMPQ = 'I' or COMPQ = 'U',
             LDWORK >= MAX(4*N+32,108).
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          < 0: if INFO = -i, the i-th argument had an illegal value;
          = 1: error occured during execution of MB03DD;
          = 2: error occured during execution of MB03HD.
Method 
  The algorithm reorders the eigenvalues like the following scheme:

  Step 1: Reorder the eigenvalues in the subpencil aA - bB.
       I. Reorder the eigenvalues with negative real parts to the
          top.
      II. Reorder the eigenvalues with positive real parts to the
          bottom.

  Step 2: Reorder the remaining eigenvalues with negative real
          parts in the pencil aS - bH.
       I. Exchange the eigenvalues between the last diagonal block
          in aA - bB and the last diagonal block in aS - bH.
      II. Move the eigenvalues of the R-th block to the (MM+1)-th
          block, where R denotes the number of upper quasi-
          triangular blocks in aA - bB and MM denotes the current
          number of blocks in aA - bB with eigenvalues with negative
          real parts.

  The algorithm uses a sequence of orthogonal transformations as
  described on page 33 in [1]. To achieve those transformations the
  elementary subroutines MB03DD and MB03HD are called for the
  corresponding matrix structures.
References 
  [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
                                                            3
  The algorithm is numerically backward stable and needs O(N ) real
  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03KA.html000077500000000000000000000244111201767322700160630ustar00rootroot00000000000000 MB03KA - SLICOT Library Routine Documentation

MB03KA

Moving diagonal blocks at a specified position in a formal matrix product to another position

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reorder the diagonal blocks of the formal matrix product

     T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1),             (1)

  of length K, in the generalized periodic Schur form

           [  T11_k  T12_k  T13_k  ]
     T_k = [    0    T22_k  T23_k  ],    k = 1, ..., K,          (2)
           [    0      0    T33_k  ]

  where

  - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or
    NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced
    infinite eigenvalues,
  - the submatrices T22_k are NC-by-NC and contain core eigenvalues,
    which are generically neither zero nor infinite,
  - the submatrices T33_k contain dimension-induced zero
    eigenvalues,

  such that the block with starting row index IFST in (1) is moved
  to row index ILST. The indices refer to the T22_k submatrices.

  Optionally, the transformation matrices Q_1,...,Q_K from the
  reduction into generalized periodic Schur form are updated with
  respect to the performed reordering.
Specification 
      SUBROUTINE MB03KA( COMPQ, WHICHQ, WS, K, NC, KSCHUR, IFST, ILST,
     $                   N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      LOGICAL            WS
      INTEGER            IFST, ILST, INFO, K, KSCHUR, LDWORK, NC
C     .. Array Arguments ..
      INTEGER            IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ),
     $                   LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * )
      DOUBLE PRECISION   DWORK( * ), Q( * ), T( * ), TOL( * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          = 'N': do not compute any of the matrices Q_k;
          = 'U': each coefficient of Q must contain an orthogonal
                 matrix Q1_k on entry, and the products Q1_k*Q_k are
                 returned, where Q_k, k = 1, ..., K, performed the
                 reordering;
          = 'W': the computation of each Q_k is specified
                 individually in the array WHICHQ.

  WHICHQ  INTEGER array, dimension (K)
          If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k
          as follows:
          = 0:   do not compute Q_k;
          > 0:   the kth coefficient of Q must contain an orthogonal
                 matrix Q1_k on entry, and the product Q1_k*Q_k is
                 returned.
          This array is not referenced if COMPQ <> 'W'.

  WS      LOGICAL
          = .FALSE. : do not perform the strong stability tests;
          = .TRUE.  : perform the strong stability tests; often,
                      this is not needed, and omitting them can save
                      some computations.
Input/Output Parameters 
  K       (input) INTEGER
          The period of the periodic matrix sequences T and Q (the
          number of factors in the matrix product).  K >= 2.
          (For K = 1, a standard eigenvalue reordering problem is
          obtained.)

  NC      (input) INTEGER
          The number of core eigenvalues.  0 <= NC <= min(N).

  KSCHUR  (input) INTEGER
          The index for which the matrix T22_kschur is upper quasi-
          triangular. All other T22 matrices are upper triangular.

  IFST    (input/output) INTEGER
  ILST    (input/output) INTEGER
          Specify the reordering of the diagonal blocks, as follows:
          The block with starting row index IFST in (1) is moved to
          row index ILST by a sequence of direct swaps between adjacent
          blocks in the product.
          On exit, if IFST pointed on entry to the second row of a
          2-by-2 block in the product, it is changed to point to the
          first row; ILST always points to the first row of the block
          in its final position in the product (which may differ from
          its input value by +1 or -1).
          1 <= IFST <= NC, 1 <= ILST <= NC.

  N       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          dimensions of the factors of the formal matrix product T,
          such that the k-th coefficient T_k is an N(k+1)-by-N(k)
          matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix,
          if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1).

  NI      (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          dimensions of the factors of the matrix sequence T11_k.
          N(k) >= NI(k) + NC >= 0.

  S       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          signatures (exponents) of the factors in the K-periodic
          matrix sequence. Each entry in S must be either 1 or -1;
          the value S(k) = -1 corresponds to using the inverse of
          the factor T_k.

  T       (input/output) DOUBLE PRECISION array, dimension (*)
          On entry, this array must contain at position IXT(k) the
          matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1,
          or at least N(k)-by-N(k+1), if S(k) = -1, in periodic
          Schur form.
          On exit, the matrices T_k are overwritten by the reordered
          periodic Schur form.

  LDT     INTEGER array, dimension (K)
          The leading dimensions of the matrices T_k in the one-
          dimensional array T.
          LDT(k) >= max(1,N(k+1)),  if S(k) =  1,
          LDT(k) >= max(1,N(k)),    if S(k) = -1.

  IXT     INTEGER array, dimension (K)
          Start indices of the matrices T_k in the one-dimensional
          array T.

  Q       (input/output) DOUBLE PRECISION array, dimension (*)
          On entry, this array must contain at position IXQ(k) a
          matrix Q_k of size at least N(k)-by-N(k), provided that
          COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0.
          On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0,
          Q_k is post-multiplied with the orthogonal matrix that
          performed the reordering.
          This array is not referenced if COMPQ = 'N'.

  LDQ     INTEGER array, dimension (K)
          The leading dimensions of the matrices Q_k in the one-
          dimensional array Q.
          LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and
                                                    WHICHQ(k) > 0;
          This array is not referenced if COMPQ = 'N'.

  IXQ     INTEGER array, dimension (K)
          Start indices of the matrices Q_k in the one-dimensional
          array Q.
          This array is not referenced if COMPQ = 'N'.
Tolerances 
  TOL     DOUBLE PRECISION array, dimension (3)
          This array contains tolerance parameters. The weak and
          strong stability tests use a threshold computed by the
          formula  MAX( c*EPS*NRM, SMLNUM ),  where c is a constant,
          NRM is the Frobenius norm of the current matrix formed by
          concatenating K pairs of adjacent diagonal blocks of sizes
          1 and/or 2 in the T22_k submatrices from (2), which are
          swapped, and EPS and SMLNUM are the machine precision and
          safe minimum divided by EPS, respectively (see LAPACK
          Library routine DLAMCH). The norm NRM is computed by this
          routine; the other values are stored in the array TOL.
          TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM,
          respectively. TOL(1) should normally be at least 10.
Workspace 
  IWORK   INTEGER array, dimension (4*K)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 10*K + MN, if all blocks between IFST and ILST
                               have order 1;
          LDWORK >= 25*K + MN, if there is at least a block of
                               order 2, but no adjacent blocks of
                               order 2 can appear between IFST and
                               ILST during reordering;
          LDWORK >= MAX(42*K + MN, 80*K - 48), if at least a pair of
                               adjacent blocks of order 2 can appear
                               between IFST and ILST during
                               reordering;
          where MN = MXN, if MXN > 10, and MN = 0, otherwise, with
          MXN = MAX(N(k),k=1,...,K).

          If LDWORK = -1  a workspace query is assumed; the
          routine only calculates the optimal size of the DWORK
          array, returns this value as the first entry of the DWORK
          array, and no error message is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -21, the LDWORK argument was too small;
          = 1:  the reordering of T failed because some eigenvalues
                are too close to separate (the problem is very ill-
                conditioned); T may have been partially reordered.
                The returned value of ILST is the index where this
                was detected.
Method 
  An adaptation of the LAPACK Library routine DTGEXC is used.
Numerical Aspects 
  The implemented method is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03KB.html000077500000000000000000000236321201767322700160700ustar00rootroot00000000000000 MB03KB - SLICOT Library Routine Documentation

MB03KB

Swapping pairs of adjacent diagonal blocks of sizes 1 and/or 2 in a formal matrix product

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reorder the diagonal blocks of the formal matrix product

     T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1)              (1)

  of length K in the generalized periodic Schur form

           [  T11_k  T12_k  T13_k  ]
     T_k = [    0    T22_k  T23_k  ],    k = 1, ..., K,          (2)
           [    0      0    T33_k  ]

  where

  - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or
    NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced
    infinite eigenvalues,
  - the submatrices T22_k are NC-by-NC and contain core eigenvalues,
    which are generically neither zero nor infinite,
  - the submatrices T33_k contain dimension-induced zero
    eigenvalues,

  such that pairs of adjacent diagonal blocks of sizes 1 and/or 2 in
  the product (1) are swapped.

  Optionally, the transformation matrices Q_1,...,Q_K from the
  reduction into generalized periodic Schur form are updated with
  respect to the performed reordering.
Specification 
      SUBROUTINE MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, J1, N1, N2,
     $                   N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      LOGICAL            WS
      INTEGER            INFO, J1, K, KSCHUR, LDWORK, N1, N2, NC
C     .. Array Arguments ..
      INTEGER            IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ),
     $                   LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * )
      DOUBLE PRECISION   DWORK( * ), Q( * ), T( * ), TOL( * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          = 'N': do not compute any of the matrices Q_k;
          = 'U': each coefficient of Q must contain an orthogonal
                 matrix Q1_k on entry, and the products Q1_k*Q_k are
                 returned, where Q_k, k = 1, ..., K, performed the
                 reordering;
          = 'W': the computation of each Q_k is specified
                 individually in the array WHICHQ.

  WHICHQ  INTEGER array, dimension (K)
          If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k
          as follows:
          = 0:   do not compute Q_k;
          > 0:   the kth coefficient of Q must contain an orthogonal
                 matrix Q1_k on entry, and the product Q1_k*Q_k is
                 returned.
          This array is not referenced if COMPQ <> 'W'.

  WS      LOGICAL
          = .FALSE. : do not perform the strong stability tests;
          = .TRUE.  : perform the strong stability tests; often,
                      this is not needed, and omitting them can save
                      some computations.
Input/Output Parameters 
  K       (input) INTEGER
          The period of the periodic matrix sequences T and Q (the
          number of factors in the matrix product).  K >= 2.
          (For K = 1, a standard eigenvalue reordering problem is
          obtained.)

  NC      (input) INTEGER
          The number of core eigenvalues.  0 <= NC <= min(N).

  KSCHUR  (input) INTEGER
          The index for which the matrix T22_kschur is upper quasi-
          triangular.

  J1      (input) INTEGER
          The index of the first row and column of the first block
          to swap in T22_k.
          1 <= J1 <= NC-N1-N2+1.

  N1      (input) INTEGER
          The order of the first block to swap.   N1 = 0, 1 or 2.

  N2      (input) INTEGER
          The order of the second block to swap.  N2 = 0, 1 or 2.

  N       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          dimensions of the factors of the formal matrix product T,
          such that the k-th coefficient T_k is an N(k+1)-by-N(k)
          matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix,
          if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1).

  NI      (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          dimensions of the factors of the matrix sequence T11_k.
          N(k) >= NI(k) + NC >= 0.

  S       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          signatures (exponents) of the factors in the K-periodic
          matrix sequence. Each entry in S must be either 1 or -1;
          the value S(k) = -1 corresponds to using the inverse of
          the factor T_k.

  T       (input/output) DOUBLE PRECISION array, dimension (*)
          On entry, this array must contain at position IXT(k) the
          matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1,
          or at least N(k)-by-N(k+1), if S(k) = -1, in periodic
          Schur form.
          On exit, the matrices T_k are overwritten by the reordered
          periodic Schur form.

  LDT     INTEGER array, dimension (K)
          The leading dimensions of the matrices T_k in the one-
          dimensional array T.
          LDT(k) >= max(1,N(k+1)),  if S(k) =  1,
          LDT(k) >= max(1,N(k)),    if S(k) = -1.

  IXT     INTEGER array, dimension (K)
          Start indices of the matrices T_k in the one-dimensional
          array T.

  Q       (input/output) DOUBLE PRECISION array, dimension (*)
          On entry, this array must contain at position IXQ(k) a
          matrix Q_k of size at least N(k)-by-N(k), provided that
          COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0.
          On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0,
          Q_k is post-multiplied with the orthogonal matrix that
          performed the reordering.
          This array is not referenced if COMPQ = 'N'.

  LDQ     INTEGER array, dimension (K)
          The leading dimensions of the matrices Q_k in the one-
          dimensional array Q.  LDQ(k) >= 1, and
          LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and
                                                    WHICHQ(k) > 0;
          This array is not referenced if COMPQ = 'N'.

  IXQ     INTEGER array, dimension (K)
          Start indices of the matrices Q_k in the one-dimensional
          array Q.
          This array is not referenced if COMPQ = 'N'.
Tolerances 
  TOL     DOUBLE PRECISION array, dimension (3)
          This array contains tolerance parameters. The weak and
          strong stability tests use a threshold computed by the
          formula  MAX( c*EPS*NRM, SMLNUM ),  where c is a constant,
          NRM is the Frobenius norm of the matrix formed by
          concatenating K pairs of adjacent diagonal blocks of sizes
          1 and/or 2 in the T22_k submatrices from (2), which are
          swapped, and EPS and SMLNUM are the machine precision and
          safe minimum divided by EPS, respectively (see LAPACK
          Library routine DLAMCH). The norm NRM is computed by this
          routine; the other values are stored in the array TOL.
          TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM,
          respectively. TOL(1) should normally be at least 10.
Workspace 
  IWORK   INTEGER array, dimension (4*K)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 10*K + MN,                 if N1 = 1, N2 = 1;
          LDWORK >= 25*K + MN,                 if N1 = 1, N2 = 2;
          LDWORK >= MAX(23*K + MN, 25*K - 12), if N1 = 2, N2 = 1;
          LDWORK >= MAX(42*K + MN, 80*K - 48), if N1 = 2, N2 = 2;
          where MN = MXN, if MXN > 10, and MN = 0, otherwise, with
          MXN = MAX(N(k),k=1,...,K).

          If LDWORK = -1  a workspace query is assumed; the
          routine only calculates the optimal size of the DWORK
          array, returns this value as the first entry of the DWORK
          array, and no error message is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -22, then LDWORK is too small; appropriate
                value for LDWORK is returned in DWORK(1); the other
                arguments are not tested, for efficiency;
          = 1:  the swap was rejected from stability reasons; the
                blocks are not swapped and T and Q are unchanged.
Method 
  The algorithm described in [1] is used. Both weak and strong
  stability tests are performed.
References 
  [1] Granat, R., Kagstrom, B. and Kressner, D.
      Computing periodic deflating subspaces associated with a
      specified set of eigenvalues.
      BIT Numerical Mathematics, vol. 47, 763-791, 2007.
Numerical Aspects 
  The implemented method is numerically backward stable.
                               3
  The algorithm requires 0(K NC ) floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03KC.html000077500000000000000000000107641201767322700160730ustar00rootroot00000000000000 MB03KC - SLICOT Library Routine Documentation

MB03KC

Reducing a 2-by-2 formal matrix product to periodic Hessenberg-triangular form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce a 2-by-2 general, formal matrix product A of length K,

     A_K^s(K) * A_K-1^s(K-1) * ... * A_1^s(1),

  to the periodic Hessenberg-triangular form using a K-periodic
  sequence of elementary reflectors (Householder matrices). The
  matrices A_k, k = 1, ..., K, are stored in the N-by-N-by-K array A
  starting in the R-th row and column, and N can be 3 or 4.

  Each elementary reflector H_k is represented as

     H_k = I - tau_k * v_k * v_k',                               (1)

  where I is the 2-by-2 identity, tau_k is a real scalar, and v_k is
  a vector of length 2, k = 1,...,K, and it is constructed such that
  the following holds for k = 1,...,K:

         H_{k+1} * A_k * H_k = T_k, if s(k) = 1,
                                                                 (2)
         H_k * A_k * H_{k+1} = T_k, if s(k) = -1,

  with H_{K+1} = H_1 and all T_k upper triangular except for
  T_{khess} which is full. Clearly,

     T_K^s(K) *...* T_1^s(1) = H_1 * A_K^s(K) *...* A_1^s(1) * H_1.

  The reflectors are suitably applied to the whole, extended N-by-N
  matrices Ae_k, not only to the submatrices A_k, k = 1, ..., K.
Specification 
      SUBROUTINE MB03KC( K, KHESS, N, R, S, A, LDA, V, TAU )
C     .. Scalar Arguments ..
      INTEGER            K, KHESS, LDA, N, R
C     .. Array Arguments ..
      INTEGER            S( * )
      DOUBLE PRECISION   A( * ), TAU( * ), V( * )
Arguments

Input/Output Parameters 

  K       (input) INTEGER
          The number of matrices in the sequence A_k.  K >= 2.

  KHESS   (input) INTEGER
          The index for which the returned matrix A_khess should be
          in the Hessenberg form on output.  1 <= KHESS <= K.

  N       (input) INTEGER
          The order of the extended matrices.  N = 3 or N = 4.

  R       (input) INTEGER
          The starting row and column index for the
          2-by-2 submatrices.  R = 1, or R = N-1.

  S       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          signatures of the factors. Each entry in S must be either
          1 or -1; the value S(k) = -1 corresponds to using the
          inverse of the factor A_k.

  A       (input/output) DOUBLE PRECISION array, dimension (*)
          On entry, this array must contain at position IXA(k) =
          (k-1)*N*LDA+1 the N-by-N matrix Ae_k stored with leading
          dimension LDA.
          On exit, this array contains at position IXA(k) the
          N-by-N matrix Te_k stored with leading dimension LDA.

  LDA     INTEGER
          Leading dimension of the matrices Ae_k and Te_k in the
          one-dimensional array A.  LDA >= N.

  V       (output) DOUBLE PRECISION array, dimension (2*K)
          On exit, this array contains the K vectors v_k,
          k = 1,...,K, defining the elementary reflectors H_k as
          in (1). The k-th reflector is stored in V(2*k-1:2*k).

  TAU     (output) DOUBLE PRECISION array, dimension (K)
          On exit, this array contains the K values of tau_k,
          k = 1,...,K, defining the elementary reflectors H_k
          as in (1).
Method 
  A K-periodic sequence of elementary reflectors (Householder
  matrices) is used. The computations start for k = khess with the
  left reflector in (1), which is the identity matrix.
Numerical Aspects 
  The implemented method is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03KD.html000077500000000000000000000467171201767322700161030ustar00rootroot00000000000000 MB03KD - SLICOT Library Routine Documentation

MB03KD

Reordering the diagonal blocks of a formal matrix product using periodic QZ algorithm

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reorder the diagonal blocks of the formal matrix product

     T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1),             (1)

  of length K, in the generalized periodic Schur form,

           [  T11_k  T12_k  T13_k  ]
     T_k = [    0    T22_k  T23_k  ],    k = 1, ..., K,          (2)
           [    0      0    T33_k  ]

  where

  - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or
    NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced
    infinite eigenvalues,
  - the submatrices T22_k are NC-by-NC and contain core eigenvalues,
    which are generically neither zero nor infinite,
  - the submatrices T33_k contain dimension-induced zero
    eigenvalues,

  such that the M selected eigenvalues pointed to by the logical
  vector SELECT end up in the leading part of the matrix sequence
  T22_k.

  Given that N(k) = N(k+1) for all k where S(k) = -1, the T11_k are
  void and the first M columns of the updated orthogonal
  transformation matrix sequence Q_1, ..., Q_K span a periodic
  deflating subspace corresponding to the same eigenvalues.
Specification 
      SUBROUTINE MB03KD( COMPQ, WHICHQ, STRONG, K, NC, KSCHUR, N, NI, S,
     $                   SELECT, T, LDT, IXT, Q, LDQ, IXQ, M, TOL,
     $                   IWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, STRONG
      INTEGER            INFO, K, KSCHUR, LDWORK, M, NC
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ),
     $                   LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * )
      DOUBLE PRECISION   DWORK( * ), Q( * ), T( * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          Specifies whether to compute the orthogonal transformation
          matrices Q_k, as follows:
          = 'N': do not compute any of the matrices Q_k;
          = 'I': each coefficient of Q is initialized internally to
                 the identity matrix, and the orthogonal matrices
                 Q_k are returned, where Q_k, k = 1, ..., K,
                 performed the reordering;
          = 'U': each coefficient of Q must contain an orthogonal
                 matrix Q1_k on entry, and the products Q1_k*Q_k are
                 returned;
          = 'W': the computation of each Q_k is specified
                 individually in the array WHICHQ.

  WHICHQ  INTEGER array, dimension (K)
          If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k
          as follows:
          = 0:   do not compute Q_k;
          = 1:   the kth coefficient of Q is initialized to the
                 identity matrix, and the orthogonal matrix Q_k is
                 returned;
          = 2:   the kth coefficient of Q must contain an orthogonal
                 matrix Q1_k on entry, and the product Q1_k*Q_k is
                 returned.
          This array is not referenced if COMPQ <> 'W'.

  STRONG  CHARACTER*1
          Specifies whether to perform the strong stability tests,
          as follows:
          = 'N': do not perform the strong stability tests;
          = 'S': perform the strong stability tests; often, this is
                 not needed, and omitting them can save some
                 computations.
Input/Output Parameters 
  K       (input) INTEGER
          The period of the periodic matrix sequences T and Q (the
          number of factors in the matrix product).  K >= 2.
          (For K = 1, a standard eigenvalue reordering problem is
          obtained.)

  NC      (input) INTEGER
          The number of core eigenvalues.  0 <= NC <= min(N).

  KSCHUR  (input) INTEGER
          The index for which the matrix T22_kschur is upper quasi-
          triangular. All other T22 matrices are upper triangular.

  N       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          dimensions of the factors of the formal matrix product T,
          such that the k-th coefficient T_k is an N(k+1)-by-N(k)
          matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix,
          if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1).

  NI      (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          dimensions of the factors of the matrix sequence T11_k.
          N(k) >= NI(k) + NC >= 0.

  S       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          signatures (exponents) of the factors in the K-periodic
          matrix sequence. Each entry in S must be either 1 or -1;
          the value S(k) = -1 corresponds to using the inverse of
          the factor T_k.

  SELECT  (input) LOGICAL array, dimension (NC)
          SELECT specifies the eigenvalues in the selected cluster.
          To select a real eigenvalue w(j), SELECT(j) must be set to
          .TRUE.. To select a complex conjugate pair of eigenvalues
          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
          either SELECT(j) or SELECT(j+1) or both must be set to
          .TRUE.; a complex conjugate pair of eigenvalues must be
          either both included in the cluster or both excluded.

  T       (input/output) DOUBLE PRECISION array, dimension (*)
          On entry, this array must contain at position IXT(k) the
          matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1,
          or at least N(k)-by-N(k+1), if S(k) = -1, in periodic
          Schur form.
          On exit, the matrices T_k are overwritten by the reordered
          periodic Schur form.

  LDT     INTEGER array, dimension (K)
          The leading dimensions of the matrices T_k in the one-
          dimensional array T.
          LDT(k) >= max(1,N(k+1)),  if S(k) =  1,
          LDT(k) >= max(1,N(k)),    if S(k) = -1.

  IXT     INTEGER array, dimension (K)
          Start indices of the matrices T_k in the one-dimensional
          array T.

  Q       (input/output) DOUBLE PRECISION array, dimension (*)
          On entry, this array must contain at position IXQ(k) a
          matrix Q_k of size at least N(k)-by-N(k), provided that
          COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) = 2.
          On exit, if COMPQ = 'I' or COMPQ = 'W' and WHICHQ(k) = 1,
          Q_k contains the orthogonal matrix that performed the
          reordering. If COMPQ = 'U', or COMPQ = 'W' and
          WHICHQ(k) = 2, Q_k is post-multiplied with the orthogonal
          matrix that performed the reordering.
          This array is not referenced if COMPQ = 'N'.

  LDQ     INTEGER array, dimension (K)
          The leading dimensions of the matrices Q_k in the one-
          dimensional array Q.
          LDQ(k) >= max(1,N(k)), if COMPQ = 'I', or COMPQ = 'U', or
                                    COMPQ = 'W' and WHICHQ(k) > 0;
          This array is not referenced if COMPQ = 'N'.

  IXQ     INTEGER array, dimension (K)
          Start indices of the matrices Q_k in the one-dimensional
          array Q.
          This array is not referenced if COMPQ = 'N'.

  M       (output) INTEGER
          The number of selected core eigenvalues which were
          reordered to the top of T22_k.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance parameter c. The weak and strong stability
          tests performed for checking the reordering use a
          threshold computed by the formula  MAX(c*EPS*NRM, SMLNUM),
          where NRM is the varying Frobenius norm of the matrices
          formed by concatenating K pairs of adjacent diagonal
          blocks of sizes 1 and/or 2 in the T22_k submatrices from
          (2), which are swapped, and EPS and SMLNUM are the machine
          precision and safe minimum divided by EPS, respectively
          (see LAPACK Library routine DLAMCH). The value c should
          normally be at least 10.
Workspace 
  IWORK   INTEGER array, dimension (4*K)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 10*K + MN, if all blocks involved in reordering
                               have order 1;
          LDWORK >= 25*K + MN, if there is at least a block of
                               order 2, but no adjacent blocks of
                               order 2 are involved in reordering;
          LDWORK >= MAX(42*K + MN, 80*K - 48), if there is at least
                               a pair of adjacent blocks of order 2
                               involved in reordering;
          where MN = MXN, if MXN > 10, and MN = 0, otherwise, with
          MXN = MAX(N(k),k=1,...,K).

          If LDWORK = -1  a workspace query is assumed; the
          routine only calculates the optimal size of the DWORK
          array, returns this value as the first entry of the DWORK
          array, and no error message is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reordering of T failed because some eigenvalues
                are too close to separate (the problem is very ill-
                conditioned); T may have been partially reordered.
Method 
  An adaptation of the LAPACK Library routine DTGSEN is used.
Numerical Aspects 
  The implemented method is numerically backward stable.
Further Comments 
  None
Example

Program Text 

*     MB03KD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            KMAX, NMAX
      PARAMETER          ( KMAX = 6, NMAX = 50 )
      INTEGER            LDA1, LDA2, LDQ1, LDQ2, LDWORK, LIWORK
      PARAMETER          ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX,
     $                     LDQ2 = NMAX,
     $                     LDWORK = MAX( KMAX + MAX( 2*NMAX, 8*KMAX ),
     $                                   42*KMAX + NMAX, 80*KMAX - 48 ),
     $                     LIWORK = 4*KMAX )
      DOUBLE PRECISION   HUND, ZERO
      PARAMETER          ( HUND = 1.0D2, ZERO = 0.0D0 )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ, DEFL, JOB, STRONG
      INTEGER            H, I, IHI, ILO, INFO, IWARN, J, K, L, M, N, P
      DOUBLE PRECISION   TOL
*
*     .. Local Arrays ..
      LOGICAL            SELECT( NMAX )
      INTEGER            IWORK( LIWORK ), IXQ( KMAX ), IXT( KMAX ),
     $                   LDQ( KMAX ), LDT( KMAX ), ND( KMAX ),
     $                   NI( KMAX ), QIND( KMAX ), S( KMAX ),
     $                   SCAL( NMAX )
      DOUBLE PRECISION   A( LDA1, LDA2, KMAX ), ALPHAI( NMAX ),
     $                   ALPHAR( NMAX ), BETA( NMAX ), DWORK( LDWORK),
     $                   Q( LDQ1, LDQ2, KMAX ), QK( NMAX*NMAX*KMAX ),
     $                   T( NMAX*NMAX*KMAX )
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           DLACPY, MB03BD, MB03KD
*
*     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) JOB, DEFL, COMPQ, STRONG, K, N, H, ILO, IHI
      IF( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         TOL = HUND
         READ( NIN, FMT = * ) ( S( I ), I = 1, K )
         READ( NIN, FMT = * ) ( ( ( A( I, J, L ), J = 1, N ),
     $                                I = 1, N ), L = 1, K )
         IF( LSAME( COMPQ, 'U' ) )
     $      READ( NIN, FMT = * ) ( ( ( Q( I, J, L ), J = 1, N ),
     $                                   I = 1, N ), L = 1, K )
         IF( LSAME( COMPQ, 'P' ) ) THEN
            READ( NIN, FMT = * ) ( QIND( I ), I = 1, K )
            DO 10 L = 1, K
               IF( QIND( L ).GT.0 )
     $            READ( NIN, FMT = * ) ( ( Q( I, J, QIND( L ) ),
     $                                    J = 1, N ), I = 1, N )
   10       CONTINUE
         END IF
         IF( LSAME( JOB, 'E' ) )
     $      JOB = 'S'
*        Compute the eigenvalues and the transformed matrices.
         CALL MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, A,
     $                LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, BETA,
     $                SCAL, IWORK, LIWORK, DWORK, LDWORK, IWARN, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE IF( IWARN.EQ.0 ) THEN
*           Prepare the data for calling MB03KD, which uses different
*           data structures and reverse ordering of the factors.
            DO 20 L = 1, K
               ND(  L ) = MAX( 1, N )
               NI(  L ) = 0
               LDT( L ) = MAX( 1, N )
               IXT( L ) = ( L - 1 )*LDT( L )*N + 1
               LDQ( L ) = MAX( 1, N )
               IXQ( L ) = IXT( L )
               IF( L.LE.INT( K/2 ) ) THEN
                  I = S( K - L + 1 )
                  S( K - L + 1 ) = S( L )
                  S( L ) = I
               END IF
   20       CONTINUE
            DO 30 L = 1, K
               CALL DLACPY( 'Full', N, N, A( 1, 1, K-L+1 ), LDA1,
     $                      T( IXT( L ) ), LDT( L ) )
   30       CONTINUE
            IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN
               COMPQ = 'U'
               DO 40 L = 1, K
                  CALL DLACPY( 'Full', N, N, Q( 1, 1, K-L+1 ), LDQ1,
     $                         QK( IXQ( L ) ), LDQ( L ) )
   40          CONTINUE
            ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
               COMPQ = 'W'
               DO 50 L = 1, K
                  IF( QIND( L ).LT.0 )
     $                QIND( L ) = 2
                  P = QIND( L )
                  IF( P.NE.0 )
     $               CALL DLACPY( 'Full', N, N, Q( 1, 1, K-P+1 ), LDQ1,
     $                            QK( IXQ( P ) ), LDQ( P ) )
   50          CONTINUE
            END IF
*           Select eigenvalues with negative real part.
            DO 60 I = 1, N
               SELECT( I ) = ALPHAR( I ).LT.ZERO
   60       CONTINUE
            WRITE( NOUT, FMT = 99996 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, N )
            WRITE( NOUT, FMT = 99994 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, N )
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99995 ) (   BETA( I ), I = 1, N )
            WRITE( NOUT, FMT = 99992 )
            WRITE( NOUT, FMT = 99991 ) (   SCAL( I ), I = 1, N )
*           Compute the transformed matrices, after reordering the
*           eigenvalues.
            CALL MB03KD( COMPQ, QIND, STRONG, K, N, H, ND, NI, S,
     $                   SELECT, T, LDT, IXT, QK, LDQ, IXQ, M, TOL,
     $                   IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               WRITE( NOUT, FMT = 99990 ) INFO
            ELSE
               WRITE( NOUT, FMT = 99989 )
               DO 80 L = 1, K
                  P = K - L + 1
                  WRITE( NOUT, FMT = 99988 ) L
                  DO 70 I = 1, N
                     WRITE( NOUT, FMT = 99995 )
     $                    ( T( IXT( P ) + I - 1 + ( J - 1 )*LDT( P ) ),
     $                       J = 1, N )
   70             CONTINUE
   80          CONTINUE
               IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN
                  WRITE( NOUT, FMT = 99987 )
                  DO 100 L = 1, K
                     P = K - L + 1
                     WRITE( NOUT, FMT = 99988 ) L
                     DO 90 I = 1, N
                        WRITE( NOUT, FMT = 99995 )
     $                       ( QK( IXQ( P ) + I - 1 +
     $                           ( J - 1 )*LDQ( P ) ), J = 1, N )
   90                CONTINUE
  100             CONTINUE
               ELSE IF( LSAME( COMPQ, 'W' ) ) THEN
                  WRITE( NOUT, FMT = 99987 )
                  DO 120 L = 1, K
                     IF( QIND( L ).GT.0 ) THEN
                        P = K - QIND( L ) + 1
                        WRITE( NOUT, FMT = 99988 ) QIND( L )
                        DO 110 I = 1, N
                           WRITE( NOUT, FMT = 99995 )
     $                          ( QK( IXQ( P ) + I - 1 +
     $                              ( J - 1 )*LDQ( P ) ), J = 1, N )
  110                   CONTINUE
                     END IF
  120             CONTINUE
               END IF
            END IF
         ELSE
            WRITE( NOUT, FMT = 99979 ) IWARN
         END IF
      END IF
      STOP
*
99999 FORMAT( 'MB03KD EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT( 'INFO on exit from MB03BD = ', I2 )
99996 FORMAT( 'The vector ALPHAR is ' )
99995 FORMAT( 50( 1X, F8.4 ) )
99994 FORMAT( 'The vector ALPHAI is ' )
99993 FORMAT( 'The vector BETA is ' )
99992 FORMAT( 'The vector SCAL is ' )
99991 FORMAT( 50( 1X, I5 ) )
99990 FORMAT( 'INFO on exit from MB03KD = ', I2 )
99989 FORMAT( 'The matrix A on exit is ' )
99988 FORMAT( 'The factor ', I2, ' is ' )
99987 FORMAT( 'The matrix Q on exit is ' )
99986 FORMAT( 'LDT', 3I5 )
99985 FORMAT( 'IXT', 3I5 )
99984 FORMAT( 'LDQ', 3I5 )
99983 FORMAT( 'IXQ', 3I5 )
99982 FORMAT( 'ND' , 3I5 )
99981 FORMAT( 'NI' , 3I5)
99980 FORMAT( 'SELECT', 3L5 )
99979 FORMAT( 'IWARN on exit from MB03BD = ', I2 )
      END
Program Data 
MB03KD EXAMPLE PROGRAM DATA
   S   C   I   N   3   3   2   1   3
  -1     1    -1
   2.0   0.0   1.0
   0.0  -2.0  -1.0
   0.0   0.0   3.0
   1.0   2.0   0.0
   4.0  -1.0   3.0
   0.0   3.0   1.0
   1.0   0.0   1.0
   0.0   4.0  -1.0
   0.0   0.0  -2.0
Program Results 
MB03KD EXAMPLE PROGRAM RESULTS
The vector ALPHAR is 
   0.3230   0.6459  -0.8752
The vector ALPHAI is 
   0.5694  -1.1387   0.0000
The vector BETA is 
   1.0000   1.0000   1.0000
The vector SCAL is 
     0    -1    -1
The matrix A on exit is 
The factor  1 is 
   2.5997  -0.1320  -1.6847
   0.0000   1.9725  -0.1377
   0.0000   0.0000   2.3402
The factor  2 is 
  -2.0990  -1.1625   2.5251
   0.0000   3.1870  -0.3812
   0.0000  -3.6737  -2.2513
The factor  3 is 
   1.8451   0.9652  -1.2422
   0.0000   1.3270   2.1642
   0.0000   0.0000  -3.2674
The matrix Q on exit is 
The factor  1 is 
   0.1648  -0.3771  -0.9114
  -0.0376  -0.9258   0.3762
   0.9856   0.0277   0.1668
The factor  2 is 
   0.5907   0.3477   0.7281
  -0.7640   0.5311   0.3662
  -0.2594  -0.7726   0.5794
The factor  3 is 
   0.6685  -0.7431   0.0303
   0.4239   0.3472  -0.8365
   0.6111   0.5720   0.5471
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03KE.html000077500000000000000000000144721201767322700160750ustar00rootroot00000000000000 MB03KE - SLICOT Library Routine Documentation

MB03KE

Solving periodic Sylvester-like equations with matrices of order at most 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve small periodic Sylvester-like equations (PSLE)

   op(A(i))*X( i ) + isgn*X(i+1)*op(B(i)) = -scale*C(i), S(i) =  1,
   op(A(i))*X(i+1) + isgn*X( i )*op(B(i)) = -scale*C(i), S(i) = -1.

  i = 1, ..., K, where op(A) means A or A**T, for the K-periodic
  matrix sequence X(i) = X(i+K), where A, B and C are K-periodic
  matrix sequences and A and B are in periodic real Schur form. The
  matrices A(i) are M-by-M and B(i) are N-by-N, with 1 <= M, N <= 2.
Specification 
      SUBROUTINE MB03KE( TRANA, TRANB, ISGN, K, M, N, PREC, SMIN, S, A,
     $                   B, C, SCALE, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      LOGICAL            TRANA, TRANB
      INTEGER            INFO, ISGN, K, LDWORK, M, N
      DOUBLE PRECISION   PREC, SCALE, SMIN
C     .. Array Arguments ..
      INTEGER            S( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), DWORK( * )
Arguments

Mode Parameters 

  TRANA   LOGICAL
          Specifies the form of op(A) to be used, as follows:
          = .FALSE.:  op(A) = A,
          = .TRUE. :  op(A) = A**T.

  TRANB   LOGICAL
          Specifies the form of op(B) to be used, as follows:
          = .FALSE.:  op(B) = B,
          = .TRUE. :  op(B) = B**T.

  ISGN    INTEGER
          Specifies which sign variant of the equations to solve.
          ISGN = 1 or ISGN = -1.
Input/Output Parameters 
  K       (input) INTEGER
          The period of the periodic matrix sequences A, B, C and X.
          K >= 2. (For K = 1, a standard Sylvester equation is
          obtained.)

  M       (input) INTEGER
          The order of the matrices A(i) and the number of rows of
          the matrices C(i) and X(i), i = 1, ..., K.  1 <= M <= 2.

  N       (input) INTEGER
          The order of the matrices B(i) and the number of columns
          of the matrices C(i) and X(i), i = 1, ..., K.
          1 <= N <= 2.

  PREC    (input) DOUBLE PRECISION
          The relative machine precision. See the LAPACK Library
          routine DLAMCH.

  SMIN    (input) DOUBLE PRECISION
          The machine safe minimum divided by PREC.

  S       (input) INTEGER array, dimension (K)
          The leading K elements of this array must contain the
          signatures (exponents) of the factors in the K-periodic
          matrix sequences for A and B. Each entry in S must be
          either 1 or -1. Notice that it is assumed that the same
          exponents are tied to both A and B on reduction to the
          periodic Schur form.

  A       (input) DOUBLE PRECISION array, dimension (M*M*K)
          On entry, this array must contain the M-by-M matrices
          A(i), for i = 1, ..., K, stored with the leading dimension
          M. Matrix A(i) is stored starting at position M*M*(i-1)+1.

  B       (input) DOUBLE PRECISION array, dimension (N*N*K)
          On entry, this array must contain the N-by-N matrices
          B(i), for i = 1, ..., K, stored with the leading dimension
          N. Matrix B(i) is stored starting at position N*N*(i-1)+1.

  C       (input/output) DOUBLE PRECISION array, dimension (M*N*K)
          On entry, this array must contain the M-by-N matrices
          C(i), for i = 1, ..., K, stored with the leading dimension
          M. Matrix C(i) is stored starting at position M*N*(i-1)+1.
          On exit, the matrices C(i) are overwritten by the solution
          sequence X(i).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          avoid overflow in X.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
          On exit, if INFO = -21, DWORK(1) returns the minimum value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= (4*K-3) * (M*N)**2 + K * M*N.

          If LDWORK = -1  a workspace query is assumed; the
          routine only calculates the optimal size of the DWORK
          array, returns this value as the first entry of the DWORK
          array, and no error message is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -21, then LDWORK is too small; appropriate
                value for LDWORK is returned in DWORK(1); the other
                arguments are not tested, for efficiency;
          = 1:  the solution would overflow with scale = 1, so
                SCALE was set less than 1. This is a warning, not
                an error.
Method 
  A version of the algorithm described in [1] is used. The routine
  uses a sparse Kronecker product representation Z of the PSLE and
  solves for X(i) from an associated linear system Z*x = c using
  structured (overlapping) variants of QR factorization and backward
  substitution.
References 
  [1] Granat, R., Kagstrom, B. and Kressner, D.
      Computing periodic deflating subspaces associated with a
      specified set of eigenvalues.
      BIT Numerical Mathematics, vol. 47, 763-791, 2007.
Numerical Aspects 
  The implemented method is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03LD.html000077500000000000000000000440201201767322700160650ustar00rootroot00000000000000 MB03LD - SLICOT Library Routine Documentation

MB03LD

Eigenvalues and right deflating subspace of a real skew-Hamiltonian/Hamiltonian pencil

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the relevant eigenvalues of a real N-by-N skew-
  Hamiltonian/Hamiltonian pencil aS - bH, with

        (  A  D  )         (  B  F  )
    S = (        ) and H = (        ),                           (1)
        (  E  A' )         (  G -B' )

  where the notation M' denotes the transpose of the matrix M.
  Optionally, if COMPQ = 'C', an orthogonal basis of the right
  deflating subspace of aS - bH corresponding to the eigenvalues
  with strictly negative real part is computed.
Specification 
      SUBROUTINE MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                   LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA,
     $                   BWORK, IWORK, LIWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, ORTH
      INTEGER            INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK,
     $                   LIWORK, N, NEIG
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), DE( LDDE, * ),
     $                   DWORK( * ), FG( LDFG, * ), Q( LDQ, * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          Specifies whether to compute the right deflating subspace
          corresponding to the strictly negative eigenvalues of
          aS - bH.
          = 'N':  do not compute the deflating subspace;
          = 'C':  compute the deflating subspace and store it in the
                  leading subarray of Q.

  ORTH    CHARACTER*1
          If COMPQ = 'C', specifies the technique for computing the
          orthogonal basis of the deflating subspace, as follows:
          = 'Q':  QR factorization (the fastest technique);
          = 'P':  QR factorization with column pivoting;
          = 'S':  singular value decomposition.
          If COMPQ = 'N', the ORTH value is not used.
          Usually, ORTH = 'Q' gives acceptable results, but badly
          scaled or ill-conditioned problems might need to set
          ORTH = 'P' or even ORTH = 'S'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the pencil aS - bH.  N has to be even.

  A       (input/output) DOUBLE PRECISION array, dimension
                         (LDA, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the matrix A.
          On exit, the leading N/2-by-N/2 part of this array
          contains the upper triangular matrix Aout (see METHOD).

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1, N/2).

  DE      (input/output) DOUBLE PRECISION array, dimension
                         (LDDE, N/2+1)
          On entry, the leading N/2-by-N/2 lower triangular part of
          this array must contain the lower triangular part of the
          skew-symmetric matrix E, and the N/2-by-N/2 upper
          triangular part of the submatrix in the columns 2 to N/2+1
          of this array must contain the upper triangular part of the
          skew-symmetric matrix D.
          The entries on the diagonal and the first superdiagonal of
          this array need not be set, but are assumed to be zero.
          On exit, the leading N/2-by-N/2 lower triangular part and
          the first superdiagonal contains the transpose of the
          upper quasi-triangular matrix C2out (see METHOD), and the
          (N/2-1)-by-(N/2-1) upper triangular part of the submatrix
          in the columns 3 to N/2+1 of this array contains the
          strictly upper triangular part of the skew-symmetric
          matrix Dout (see METHOD), without the main diagonal, which
          is zero.

  LDDE    INTEGER
          The leading dimension of the array DE.
          LDDE >= MAX(1, N/2).

  B       (input/output) DOUBLE PRECISION array, dimension
                         (LDB, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the matrix B.
          On exit, the leading N/2-by-N/2 part of this array
          contains the upper triangular matrix C1out (see METHOD).

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1, N/2).

  FG      (input/output) DOUBLE PRECISION array, dimension
                         (LDFG, N/2+1)
          On entry, the leading N/2-by-N/2 lower triangular part of
          this array must contain the lower triangular part of the
          symmetric matrix G, and the N/2-by-N/2 upper triangular
          part of the submatrix in the columns 2 to N/2+1 of this
          array must contain the upper triangular part of the
          symmetric matrix F.
          On exit, the leading N/2-by-N/2 part of the submatrix in
          the columns 2 to N/2+1 of this array contains the matrix
          Vout (see METHOD).

  LDFG    INTEGER
          The leading dimension of the array FG.
          LDFG >= MAX(1, N/2).

  NEIG    (output) INTEGER
          If COMPQ = 'C', the number of eigenvalues in aS - bH with
          strictly negative real part.

  Q       (output) DOUBLE PRECISION array, dimension (LDQ, 2*N)
          On exit, if COMPQ = 'C', the leading N-by-NEIG part of
          this array contains an orthogonal basis of the right
          deflating subspace corresponding to the eigenvalues of
          aA - bB with strictly negative real part. The remaining
          part of this array is used as workspace.
          If COMPQ = 'N', this array is not referenced.

  LDQ     INTEGER
          The leading dimension of the array Q.
          LDQ >= 1,           if COMPQ = 'N';
          LDQ >= MAX(1, 2*N), if COMPQ = 'C'.

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
          The real parts of each scalar alpha defining an eigenvalue
          of the pencil aS - bH.

  ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
          The imaginary parts of each scalar alpha defining an
          eigenvalue of the pencil aS - bH.
          If ALPHAI(j) is zero, then the j-th eigenvalue is real.

  BETA    (output) DOUBLE PRECISION array, dimension (N/2)
          The scalars beta that define the eigenvalues of the pencil
          aS - bH.
          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
          beta = BETA(j) represent the j-th eigenvalue of the pencil
          aS - bT, in the form lambda = alpha/beta. Since lambda may
          overflow, the ratios should not, in general, be computed.
          Due to the skew-Hamiltonian/Hamiltonian structure of the
          pencil, for every eigenvalue lambda, -lambda is also an
          eigenvalue, and thus it has only to be saved once in
          ALPHAR, ALPHAI and BETA.
          Specifically, only eigenvalues with imaginary parts
          greater than or equal to zero are stored; their conjugate
          eigenvalues are not stored. If imaginary parts are zero
          (i.e., for real eigenvalues), only positive eigenvalues
          are stored.
Workspace 
  BWORK   LOGICAL array, dimension (N/2)

  IWORK   INTEGER array, dimension (LIWORK)
          On exit, if INFO = -20, IWORK(1) returns the minimum value
          of LIWORK.

  LIWORK  INTEGER
          The dimension of the array IWORK.
          LIWORK >= MAX( N/2 + 32, 2*N + 1 ).

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
          On exit, if INFO = -22, DWORK(1) returns the minimum value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 3*(N/2)**2 + 2*N**2 + MAX( N, 32 ),
                                                     if COMPQ = 'N';
          LDWORK >= 8*N**2 + MAX( 8*N + 32, N/2 + 168, 272 ),
                                                     if COMPQ = 'C'.
          For good performance LDWORK should be generally larger.

          If LDWORK = -1  a workspace query is assumed; the
          routine only calculates the optimal size of the DWORK
          array, returns this value as the first entry of the DWORK
          array, and no error message is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          < 0: if INFO = -i, the i-th argument had an illegal value;
          = 1: periodic QZ iteration failed in the SLICOT Library
               routines MB04BD or MB04HD (QZ iteration did not
               converge or computation of the shifts failed);
          = 2: standard QZ iteration failed in the SLICOT Library
               routines MB04HD or MB03DD (called by MB03JD);
          = 3: a numerically singular matrix was found in the SLICOT
               Library routine MB03HD (called by MB03JD).
Method 
  First, the decompositions of S and H are computed via orthogonal
  transformations Q1 and Q2 as follows:

                    (  Aout  Dout  )
    Q1' S J Q1 J' = (              ),
                    (   0    Aout' )

                    (  Bout  Fout  )
    J' Q2' J S Q2 = (              ) =: T,                       (2)
                    (   0    Bout' )

               (  C1out  Vout  )            (  0  I  )
    Q1' H Q2 = (               ), where J = (        ),
               (  0     C2out' )            ( -I  0  )

  and Aout, Bout, C1out are upper triangular, C2out is upper quasi-
  triangular and Dout and Fout are skew-symmetric.

  Then, orthogonal matrices Q3 and Q4 are found, for the extended
  matrices

         (  Aout   0  )          (    0   C1out )
    Se = (            ) and He = (              ),
         (   0   Bout )          ( -C2out   0   )

  such that S11 := Q4' Se Q3 is upper triangular and
  H11 := Q4' He Q3 is upper quasi-triangular. The following matrices
  are computed:

               (  Dout   0  )                   (   0   Vout )
    S12 := Q4' (            ) Q4 and H12 := Q4' (            ) Q4.
               (   0   Fout )                   ( Vout'   0  )

  Then, an orthogonal matrix Q is found such that the eigenvalues
  with strictly negative real parts of the pencil

      (  S11  S12  )     (  H11  H12  )
    a (            ) - b (            )
      (   0   S11' )     (   0  -H11' )

  are moved to the top of this pencil.

  Finally, an orthogonal basis of the right deflating subspace
  corresponding to the eigenvalues with strictly negative real part
  is computed. See also page 12 in [1] for more details.
References 
  [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
                                                            3
  The algorithm is numerically backward stable and needs O(N )
  floating point operations.
Further Comments 
  This routine does not perform any scaling of the matrices. Scaling
  might sometimes be useful, and it should be done externally.
Example

Program Text 

*     MB03LD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            NMAX
      PARAMETER          ( NMAX = 50 )
      INTEGER            LDA, LDB, LDDE, LDFG, LDQ, LDWORK, LIWORK
      PARAMETER          (  LDA = NMAX/2, LDB = NMAX/2, LDDE = NMAX/2,
     $                     LDFG = NMAX/2, LDQ = 2*NMAX,
     $                     LDWORK = 8*NMAX*NMAX +
     $                              MAX( 8*NMAX + 32, NMAX/2 + 168,
     $                                   272 ),
     $                     LIWORK = MAX( NMAX/2 + 32, 2*NMAX + 1 ) )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ, ORTH
      INTEGER            I, INFO, J, M, N, NEIG
*
*     .. Local Arrays ..
      LOGICAL            BWORK( NMAX/2 )
      INTEGER            IWORK( LIWORK )
      DOUBLE PRECISION   A( LDA, NMAX/2 ),  ALPHAI( NMAX/2 ),
     $                   ALPHAR( NMAX/2 ),  B( LDB, NMAX/2 ),
     $                   BETA( NMAX/2 ),  DE( LDDE, NMAX/2+1 ),
     $                   DWORK( LDWORK ), FG( LDFG, NMAX/2+1 ),
     $                   Q( LDQ, 2*NMAX )
*
*     .. External Subroutines ..
      EXTERNAL           MB03LD
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) COMPQ, ORTH, N
      IF( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         M = N/2
         READ( NIN, FMT = * ) ( (  A( I, J ), J = 1, M   ), I = 1, M )
         READ( NIN, FMT = * ) ( ( DE( I, J ), J = 1, M+1 ), I = 1, M )
         READ( NIN, FMT = * ) ( (  B( I, J ), J = 1, M   ), I = 1, M )
         READ( NIN, FMT = * ) ( ( FG( I, J ), J = 1, M+1 ), I = 1, M )
*        Compute the eigenvalues and an orthogonal basis of the right
*        deflating subspace of a real skew-Hamiltonian/Hamiltonian
*        pencil, corresponding to the eigenvalues with strictly negative
*        real part.
         CALL MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, BWORK,
     $                IWORK, LIWORK, DWORK, LDWORK, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE
            WRITE( NOUT, FMT = 99996 )
            DO 10 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( A( I, J ), J = 1, M )
   10       CONTINUE
            WRITE( NOUT, FMT = 99994 )
            DO 20 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( DE( I, J ), J = 1, M+1 )
   20       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            DO 30 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( B( I, J ), J = 1, M )
   30       CONTINUE
            WRITE( NOUT, FMT = 99992 )
            DO 40 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( FG( I, J ), J = 2, M+1 )
   40       CONTINUE
            WRITE( NOUT, FMT = 99991 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M )
            WRITE( NOUT, FMT = 99990 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M )
            WRITE( NOUT, FMT = 99989 )
            WRITE( NOUT, FMT = 99995 ) (   BETA( I ), I = 1, M )
            WRITE( NOUT, FMT = 99988 )
            DO 50 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( Q( I, J ), J = 1, NEIG )
   50       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT( 'MB03LD EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT( 'INFO on exit from MB03LD = ', I2 )
99996 FORMAT( 'The matrix A on exit is ' )
99995 FORMAT( 50( 1X, F8.4 ) )
99994 FORMAT( 'The matrix DE on exit is ' )
99993 FORMAT( 'The matrix C1 on exit is ' )
99992 FORMAT( 'The matrix V on exit is ' )
99991 FORMAT( 'The vector ALPHAR is ' )
99990 FORMAT( 'The vector ALPHAI is ' )
99989 FORMAT( 'The vector BETA is ' )
99988 FORMAT( 'The matrix Q is ' )
      END
Program Data 
MB03LD EXAMPLE PROGRAM DATA
   C   Q   8
   3.1472   1.3236   4.5751   4.5717
   4.0579  -4.0246   4.6489  -0.1462
  -3.7301  -2.2150  -3.4239   3.0028
   4.1338   0.4688   4.7059  -3.5811
   0.0000   0.0000  -1.5510  -4.5974  -2.5127
   3.5071   0.0000   0.0000   1.5961   2.4490  
  -3.1428   2.5648   0.0000   0.0000  -0.0596 
   3.0340   2.4892  -1.1604   0.0000   0.0000
   0.6882  -3.3782  -3.3435   1.8921
  -0.3061   2.9428   1.0198   2.4815
  -4.8810  -1.8878  -2.3703  -0.4946
  -1.6288   0.2853   1.5408  -4.1618
  -2.4013  -2.7102   0.3834  -3.9335   3.1730
  -3.1815  -2.3620   4.9613   4.6190   3.6869
   3.6929   0.7970   0.4986  -4.9537  -4.1556
   3.5303   1.2206  -1.4905   0.1325  -1.0022
Program Results 
MB03LD EXAMPLE PROGRAM RESULTS
The matrix A on exit is 
  -4.7460   4.1855   3.2696  -0.2244
   0.0000   6.4157   2.8287   1.4553
   0.0000   0.0000   7.4626   1.5726
   0.0000   0.0000   0.0000   8.8702
The matrix DE on exit is 
  -5.4562   2.5550  -1.3137  -6.3615  -0.8940
  -2.1348  -7.9616   0.0000   1.0704  -0.0659
   4.9694   1.1516   4.8504   0.0000  -0.6922
  -2.2744   3.4912   0.5046   4.4394   0.0000
The matrix C1 on exit is 
   6.9525  -4.9881   2.3661   4.2188
   0.0000   8.5009   0.7182   5.5533
   0.0000   0.0000  -4.6650  -2.8177
   0.0000   0.0000   0.0000   1.5124
The matrix V on exit is 
   0.9136   4.1106  -0.0079   3.5789
  -1.1553  -1.4785  -1.5155  -0.8018
  -2.2167   4.8029   1.3645   2.5202
  -1.0994  -0.6144   0.3970   2.0730
The vector ALPHAR is 
   0.8314  -1.1758   0.8131   0.0000
The vector ALPHAI is 
   0.4372   0.6183   0.0000   0.9164
The vector BETA is 
   0.7071   1.0000   1.4142   2.8284
The matrix Q is 
  -0.1065   0.5967  -0.2995
   0.2424  -0.1606   0.6881
   0.4045  -0.3593  -0.1505
   0.4501  -0.0188   0.0691
   0.2261  -0.0852  -0.0435
   0.0830   0.5528   0.3520
   0.0895  -0.2247  -0.4917
  -0.7055  -0.3540   0.2045

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03MD.html000077500000000000000000000272751201767322700161030ustar00rootroot00000000000000 MB03MD - SLICOT Library Routine Documentation

MB03MD

Upper bound for L singular values of a bidiagonal matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an upper bound THETA using a bisection method such that
  the bidiagonal matrix

           |q(1) e(1)  0    ...   0   |
           | 0   q(2) e(2)        .   |
       J = | .                    .   |
           | .                  e(N-1)|
           | 0   ...        ...  q(N) |

  has precisely L singular values less than or equal to THETA plus
  a given tolerance TOL.

  This routine is mainly intended to be called only by other SLICOT
  routines.
Specification 
      SUBROUTINE MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL,
     $                   IWARN, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, IWARN, L, N
      DOUBLE PRECISION  PIVMIN, RELTOL, THETA, TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  E(*), E2(*), Q(*), Q2(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the bidiagonal matrix J.  N >= 0.

  L       (input/output) INTEGER
          On entry, L must contain the number of singular values
          of J which must be less than or equal to the upper bound
          computed by the routine.  0 <= L <= N.
          On exit, L may be increased if the L-th smallest singular
          value of J has multiplicity greater than 1. In this case,
          L is increased by the number of singular values of J which
          are larger than its L-th smallest one and approach the
          L-th smallest singular value of J within a distance less
          than TOL.
          If L has been increased, then the routine returns with
          IWARN set to 1.

  THETA   (input/output) DOUBLE PRECISION
          On entry, THETA must contain an initial estimate for the
          upper bound to be computed. If THETA < 0.0 on entry, then
          one of the following default values is used.
          If L = 0, THETA is set to 0.0 irrespective of the input
          value of THETA; if L = 1, then THETA is taken as
          MIN(ABS(Q(i))), for i = 1,2,...,N; otherwise, THETA is
          taken as ABS(Q(N-L+1)).
          On exit, THETA contains the computed upper bound such that
          the bidiagonal matrix J has precisely L singular values
          less than or equal to THETA + TOL.

  Q       (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the diagonal elements q(1),
          q(2),...,q(N) of the bidiagonal matrix J. That is,
          Q(i) = J(i,i) for i = 1,2,...,N.

  E       (input) DOUBLE PRECISION array, dimension (N-1)
          This array must contain the superdiagonal elements
          e(1),e(2),...,e(N-1) of the bidiagonal matrix J. That is,
          E(k) = J(k,k+1) for k = 1,2,...,N-1.

  Q2      (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the squares of the diagonal
          elements q(1),q(2),...,q(N) of the bidiagonal matrix J.
          That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N.

  E2      (input) DOUBLE PRECISION array, dimension (N-1)
          This array must contain the squares of the superdiagonal
          elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J.
          That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1.

  PIVMIN  (input) DOUBLE PRECISION
          The minimum absolute value of a "pivot" in the Sturm
          sequence loop.
          PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ),
          where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at
          least the smallest number that can divide one without
          overflow (see LAPACK Library routine DLAMCH).
          Note that this condition is not checked by the routine.
Tolerances 
  TOL     DOUBLE PRECISION
          This parameter defines the multiplicity of singular values
          by considering all singular values within an interval of
          length TOL as coinciding. TOL is used in checking how many
          singular values are less than or equal to THETA. Also in
          computing an appropriate upper bound THETA by a bisection
          method, TOL is used as a stopping criterion defining the
          minimum (absolute) subinterval width.  TOL >= 0.

  RELTOL  DOUBLE PRECISION
          This parameter specifies the minimum relative width of an
          interval. When an interval is narrower than TOL, or than
          RELTOL times the larger (in magnitude) endpoint, then it
          is considered to be sufficiently small and bisection has
          converged.
          RELTOL >= BASE * EPS, where BASE is machine radix and EPS
          is machine precision (see LAPACK Library routine DLAMCH).
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warnings;
          = 1:  if the value of L has been increased as the L-th
                smallest singular value of J coincides with the
                (L+1)-th smallest one.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Let s(i), i = 1,2,...,N, be the N non-negative singular values of
  the bidiagonal matrix J arranged so that s(1) >= ... >= s(N) >= 0.
  The routine then computes an upper bound T such that s(N-L) > T >=
  s(N-L+1) as follows (see [2]).
  First, if the initial estimate of THETA is not specified by the
  user then the routine initialises THETA to be an estimate which
  is close to the requested value of THETA if s(N-L) >> s(N-L+1).
  Second, a bisection method (see [1, 8.5]) is used which generates
  a sequence of shrinking intervals [Y,Z] such that either THETA in
  [Y,Z] was found (so that J has L singular values less than or
  equal to THETA), or

     (number of s(i) <= Y) < L < (number of s(i) <= Z).

  This bisection method is applied to an associated 2N-by-2N
  symmetric tridiagonal matrix T" whose eigenvalues (see [1]) are
  given by s(1),s(2),...,s(N),-s(1),-s(2),...,-s(N). One of the
  starting values for the bisection method is the initial value of
  THETA. If this value is an upper bound, then the initial lower
  bound is set to zero, else the initial upper bound is computed
  from the Gershgorin Circle Theorem [1, Theorem 7.2-1], applied to
  T". The computation of the "number of s(i) <= Y (or Z)" is
  achieved by calling SLICOT Library routine MB03ND, which applies
  Sylvester's Law of Inertia or equivalently Sturm sequences
  [1, 8.5] to the associated matrix T". If

     Z - Y <= MAX( TOL, PIVMIN, RELTOL*MAX( ABS( Y ), ABS( Z ) ) )

  at some stage of the bisection method, then at least two singular
  values of J lie in the interval [Y,Z] within a distance less than
  TOL from each other. In this case, s(N-L) and s(N-L+1) are assumed
  to coincide, the upper bound T is set to the value of Z, the value
  of L is increased and IWARN is set to 1.
References 
  [1] Golub, G.H. and Van Loan, C.F.
      Matrix Computations.
      The Johns Hopkins University Press, Baltimore, Maryland, 1983.

  [2] Van Huffel, S. and Vandewalle, J.
      The Partial Total Least Squares Algorithm.
      J. Comput. and Appl. Math., 21, pp. 333-341, 1988.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MB03MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION PIVMIN, RELTOL, SAFMIN, THETA, TOL
      INTEGER          I, INFO, IWARN, L, N
*     .. Local Arrays ..
      DOUBLE PRECISION E(NMAX-1), E2(NMAX-1), Q(NMAX), Q2(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH
*     .. External Subroutines ..
      EXTERNAL         MB03MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, THETA, L, TOL, RELTOL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE IF ( L.LT.0 .OR. L.GT.N ) THEN
         WRITE ( NOUT, FMT = 99990 ) L
      ELSE
         READ ( NIN, FMT = * ) ( Q(I), I = 1,N )
         READ ( NIN, FMT = * ) ( E(I), I = 1,N-1 )
*        Print out the bidiagonal matrix J.
         WRITE ( NOUT, FMT = 99997 )
         DO 20 I = 1, N - 1
            WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I)
   20    CONTINUE
         WRITE ( NOUT, FMT = 99995 ) N, N, Q(N)
*        Compute Q**2, E**2, and PIVMIN.
         Q2(N) = Q(N)**2
         PIVMIN = Q2(N)
         DO 40 I = 1, N - 1
            Q2(I) = Q(I)**2
            E2(I) = E(I)**2
            PIVMIN = MAX( PIVMIN, Q2(I), E2(I) )
   40    CONTINUE
         SAFMIN = DLAMCH( 'Safe minimum' )
         PIVMIN = MAX( PIVMIN*SAFMIN, SAFMIN )
         TOL = MAX( TOL, ZERO )
         IF ( RELTOL.LE.ZERO )
     $      RELTOL = DLAMCH( 'Base' )*DLAMCH( 'Epsilon' )
*        Compute an upper bound THETA such that J has 3 singular values
*        < =  THETA.
         CALL MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL,
     $                IWARN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99994 ) IWARN
            WRITE ( NOUT, FMT = 99993 ) THETA
            WRITE ( NOUT, FMT = 99992 ) L
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB03MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03MD = ',I2)
99997 FORMAT (' The Bidiagonal Matrix J is',/)
99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99995 FORMAT (' (',I1,',',I1,') = ',F7.4)
99994 FORMAT (' IWARN on exit from MB03MD = ',I2,/)
99993 FORMAT (/' The computed value of THETA is ',F7.4)
99992 FORMAT (/' J has ',I2,' singular values < =  THETA')
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' L is out of range.',/' L = ',I5)
      END
Program Data 
 MB03MD EXAMPLE PROGRAM DATA
   5     -3.0     3     0.0     0.0
   1.0  2.0  3.0  4.0  5.0
   2.0  3.0  4.0  5.0
Program Results 
 MB03MD EXAMPLE PROGRAM RESULTS

 The Bidiagonal Matrix J is

 (1,1) =  1.0000   (1,2) =  2.0000
 (2,2) =  2.0000   (2,3) =  3.0000
 (3,3) =  3.0000   (3,4) =  4.0000
 (4,4) =  4.0000   (4,5) =  5.0000
 (5,5) =  5.0000

 The computed value of THETA is  4.7500

 J has  3 singular values < =  THETA

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03ND.html000077500000000000000000000214171201767322700160740ustar00rootroot00000000000000 MB03ND - SLICOT Library Routine Documentation

MB03ND

Number of singular values of a bidiagonal matrix less than a bound

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find the number of singular values of the bidiagonal matrix

           |q(1) e(1)  .    ...    0   |
           | 0   q(2) e(2)         .   |
       J = | .                     .   |
           | .                   e(N-1)|
           | 0   ...     ...   0  q(N) |

  which are less than or equal to a given bound THETA.

  This routine is intended to be called only by other SLICOT
  routines.
Specification 
      INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, N
      DOUBLE PRECISION  PIVMIN, THETA
C     .. Array Arguments ..
      DOUBLE PRECISION  E2(*), Q2(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the bidiagonal matrix J.  N >= 0.

  THETA   (input) DOUBLE PRECISION
          Given bound.
          Note: If THETA < 0.0 on entry, then MB03ND is set to 0
                as the singular values of J are non-negative.

  Q2      (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the squares of the diagonal
          elements q(1),q(2),...,q(N) of the bidiagonal matrix J.
          That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N.

  E2      (input) DOUBLE PRECISION array, dimension (N-1)
          This array must contain the squares of the superdiagonal
          elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J.
          That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1.

  PIVMIN  (input) DOUBLE PRECISION
          The minimum absolute value of a "pivot" in the Sturm
          sequence loop.
          PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ),
          where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at
          least the smallest number that can divide one without
          overflow (see LAPACK Library routine DLAMCH).
          Note that this condition is not checked by the routine.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The computation of the number of singular values s(i) of J which
  are less than or equal to THETA is based on applying Sylvester's
  Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the
  unreduced symmetric tridiagonal matrices associated with J as
  follows. Let T be the following 2N-by-2N symmetric matrix
  associated with J:

            | 0   J'|
       T =  |       |.
            | J   0 |

  (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2),
  ...,-s(N)). Then, by permuting the rows and columns of T into the
  order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally
  similar to the tridiagonal matrix T" with zeros on its diagonal
  and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals
  [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero,
  Sylvester's Law of Inertia may be applied directly to T".
  Otherwise, T" is block diagonal and each diagonal block (which is
  then unreduced) must be analysed separately by applying
  Sylvester's Law of Inertia.
References 
  [1] Parlett, B.N.
      The Symmetric Eigenvalue Problem.
      Prentice Hall, Englewood Cliffs, New Jersey, 1980.

  [2] Demmel, J. and Kahan, W.
      Computing Small Singular Values of Bidiagonal Matrices with
      Guaranteed High Relative Accuracy.
      Technical Report, Courant Inst., New York, March 1988.

  [3] Van Huffel, S. and Vandewalle, J.
      The Partial Total Least-Squares Algorithm.
      J. Comput. and Appl. Math., 21, pp. 333-341, 1988.

  [4] Golub, G.H. and Kahan, W.
      Calculating the Singular Values and Pseudo-inverse of a
      Matrix.
      SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965.

  [5] Demmel, J.W., Dhillon, I. and Ren, H.
      On the Correctness of Parallel Bisection in Floating Point.
      Computer Science Division Technical Report UCB//CSD-94-805,
      University of California, Berkeley, CA 94720, March 1994.
Numerical Aspects 
  The singular values s(i) could also be obtained with the use of
  the symmetric tridiagonal matrix T = J'J, whose eigenvalues are
  the squared singular values of J [4,p.213]. However, the method
  actually used by the routine is more accurate and equally
  efficient (see [2]).

  To avoid overflow, matrix J should be scaled so that its largest
  element is no greater than  overflow**(1/2) * underflow**(1/4)
  in absolute value (and not much smaller than that, for maximal
  accuracy).

  With respect to accuracy the following condition holds (see [2]):

  If the established value is denoted by p, then at least p
  singular values of J are less than or equal to
  THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values
  are less than or equal to
  THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS).
Further Comments 
  None
Example

Program Text 

*     MB03ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION PIVMIN, SAFMIN, THETA
      INTEGER          I, INFO, N, NUMSV
*     .. Local Arrays ..
      DOUBLE PRECISION E(NMAX-1), E2(NMAX-1), Q(NMAX), Q2(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH
*     .. External Functions ..
      INTEGER          MB03ND
      EXTERNAL         MB03ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, THETA
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( Q(I), I = 1,N )
         READ ( NIN, FMT = * ) ( E(I), I = 1,N-1 )
*        Print out the bidiagonal matrix J.
         WRITE ( NOUT, FMT = 99997 )
         DO 20 I = 1, N - 1
            WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I)
   20    CONTINUE
         WRITE ( NOUT, FMT = 99995 ) N, N, Q(N)
*        Compute Q**2, E**2, and PIVMIN.
         Q2(N) = Q(N)**2
         PIVMIN = Q2(N)
         DO 40 I = 1, N - 1
            Q2(I) = Q(I)**2
            E2(I) = E(I)**2
            PIVMIN = MAX( PIVMIN, Q2(I), E2(I) )
   40    CONTINUE
         SAFMIN = DLAMCH( 'Safe minimum' )
         PIVMIN = MAX( PIVMIN*SAFMIN, SAFMIN )
*        Compute the number of singular values of J < =  THETA.
         NUMSV = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99994 ) NUMSV, THETA
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB03ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03ND = ',I2)
99997 FORMAT (' The Bidiagonal Matrix J is',/)
99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99995 FORMAT (' (',I1,',',I1,') = ',F7.4)
99994 FORMAT (/' J has ',I2,' singular values < =  ',F7.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB03ND EXAMPLE PROGRAM DATA
   5     5.0     0.0     0.0
   1.0  2.0  3.0  4.0  5.0
   2.0  3.0  4.0  5.0
Program Results 
 MB03ND EXAMPLE PROGRAM RESULTS

 The Bidiagonal Matrix J is

 (1,1) =  1.0000   (1,2) =  2.0000
 (2,2) =  2.0000   (2,3) =  3.0000
 (3,3) =  3.0000   (3,4) =  4.0000
 (4,4) =  4.0000   (4,5) =  5.0000
 (5,5) =  5.0000

 J has  3 singular values < =   5.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03NY.html000077500000000000000000000074261201767322700161250ustar00rootroot00000000000000 MB03NY - SLICOT Library Routine Documentation

MB03NY

Computing the smallest singular value of A - jwI

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the smallest singular value of A - jwI.
Specification 
      DOUBLE PRECISION FUNCTION MB03NY( N, OMEGA, A, LDA, S, DWORK,
     $                                  LDWORK, CWORK, LCWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER                INFO, LCWORK, LDA, LDWORK, N
      DOUBLE PRECISION       OMEGA
C     .. Array Arguments ..
      DOUBLE PRECISION       A(LDA,*), DWORK(*), S(*)
      COMPLEX*16             CWORK(*)
Function Value 
  MB03NY  DOUBLE PRECISION
          The smallest singular value of A - jwI (if INFO = 0).
          If N = 0, the function value is set to zero.
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the the matrix A.  N >= 0.

  OMEGA   (input) DOUBLE PRECISION
          The constant factor of A - jwI.

  A       (input/workspace) DOUBLE PRECISION array, dimension
          (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, if OMEGA = 0, the contents of this array are
          destroyed. Otherwise, this array is unchanged.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  S       (output) DOUBLE PRECISION array, dimension (N)
          The singular values of A - jwI in decreasing order.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX( 1, 5*N ).
          For optimum performance LDWORK should be larger.

  CWORK   COMPLEX*16 array, dimension (LCWORK)
          On exit, if INFO = 0 and OMEGA <> 0, CWORK(1) returns the
          optimal value of LCWORK.
          If OMEGA is zero, this array is not referenced.

  LCWORK  INTEGER
          The length of the array CWORK.
          LCWORK >= 1,                 if OMEGA =  0;
          LCWORK >= MAX( 1, N*N+3*N ), if OMEGA <> 0.
          For optimum performance LCWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 2:  The SVD algorithm (in either LAPACK Library routine
                DGESVD or ZGESVD) fails to converge; this error is
                very rare.
Method 
  This procedure simply constructs the matrix A - jwI, and calls
  ZGESVD if w is not zero, or DGESVD if w = 0.
Further Comments 
  This routine is not very efficient because it computes all
  singular values, but it is very accurate. The routine is intended
  to be called only from the SLICOT Library routine AB13FD.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03OD.html000077500000000000000000000244711201767322700161000ustar00rootroot00000000000000 MB03OD - SLICOT Library Routine Documentation

MB03OD

Matrix rank determination by incremental condition estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute (optionally) a rank-revealing QR factorization of a
  real general M-by-N matrix  A,  which may be rank-deficient,
  and estimate its effective rank using incremental condition
  estimation.

  The routine uses a QR factorization with column pivoting:
     A * P = Q * R,  where  R = [ R11 R12 ],
                                [  0  R22 ]
  with R11 defined as the largest leading submatrix whose estimated
  condition number is less than 1/RCOND.  The order of R11, RANK,
  is the effective rank of A.

  MB03OD  does not perform any scaling of the matrix A.
Specification 
      SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU,
     $                   RANK, SVAL, DWORK, LDWORK, INFO )
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( * )
Arguments

Mode Parameters 

  JOBQR   CHARACTER*1
          = 'Q':  Perform a QR factorization with column pivoting;
          = 'N':  Do not perform the QR factorization (but assume
                  that it has been done outside).
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension
          ( LDA, N )
          On entry with JOBQR = 'Q', the leading M by N part of this
          array must contain the given matrix A.
          On exit with JOBQR = 'Q', the leading min(M,N) by N upper
          triangular part of A contains the triangular factor R,
          and the elements below the diagonal, with the array TAU,
          represent the orthogonal matrix Q as a product of
          min(M,N) elementary reflectors.
          On entry and on exit with JOBQR = 'N', the leading
          min(M,N) by N upper triangular part of A contains the
          triangular factor R, as determined by the QR factorization
          with pivoting.  The elements below the diagonal of A are
          not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  JPVT    (input/output) INTEGER array, dimension ( N )
          On entry with JOBQR = 'Q', if JPVT(i) <> 0, the i-th
          column of A is an initial column, otherwise it is a free
          column. Before the QR factorization of A, all initial
          columns are permuted to the leading positions; only the
          remaining free columns are moved as a result of column
          pivoting during the factorization.  For rank determination
          it is preferable that all columns be free.
          On exit with JOBQR = 'Q', if JPVT(i) = k, then the i-th
          column of A*P was the k-th column of A.
          Array JPVT is not referenced when JOBQR = 'N'.

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of A, which
          is defined as the order of the largest leading triangular
          submatrix R11 in the QR factorization with pivoting of A,
          whose estimated condition number is less than 1/RCOND.
          RCOND >= 0.
          NOTE that when SVLMAX > 0, the estimated rank could be
          less than that defined above (see SVLMAX).

  SVLMAX  (input) DOUBLE PRECISION
          If A is a submatrix of another matrix B, and the rank
          decision should be related to that matrix, then SVLMAX
          should be an estimate of the largest singular value of B
          (for instance, the Frobenius norm of B).  If this is not
          the case, the input value SVLMAX = 0 should work.
          SVLMAX >= 0.

  TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
          On exit with JOBQR = 'Q', the leading min(M,N) elements of
          TAU contain the scalar factors of the elementary
          reflectors.
          Array TAU is not referenced when JOBQR = 'N'.

  RANK    (output) INTEGER
          The effective (estimated) rank of A, i.e. the order of
          the submatrix R11.

  SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
          The estimates of some of the singular values of the
          triangular factor R:
          SVAL(1): largest singular value of R(1:RANK,1:RANK);
          SVAL(2): smallest singular value of R(1:RANK,1:RANK);
          SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
                   if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
                   otherwise.
          If the triangular factorization is a rank-revealing one
          (which will be the case if the leading columns were well-
          conditioned), then SVAL(1) will also be an estimate for
          the largest singular value of A, and SVAL(2) and SVAL(3)
          will be estimates for the RANK-th and (RANK+1)-st singular
          values of A, respectively.
          By examining these values, one can confirm that the rank
          is well defined with respect to the chosen value of RCOND.
          The ratio SVAL(1)/SVAL(2) is an estimate of the condition
          number of R(1:RANK,1:RANK).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
          On exit, if  INFO = 0,  DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 3*N + 1,                 if JOBQR = 'Q';
          LDWORK >= max( 1, 2*min( M, N ) ), if JOBQR = 'N'.
          For good performance when JOBQR = 'Q', LDWORK should be
          larger. Specifically, LDWORK >= 2*N + ( N + 1 )*NB, where
          NB is the optimal block size for the LAPACK Library
          routine DGEQP3.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes or uses a QR factorization with column
  pivoting of A,  A * P = Q * R,  with  R  defined above, and then
  finds the largest leading submatrix whose estimated condition
  number is less than 1/RCOND, taking the possible positive value of
  SVLMAX into account.  This is performed using the LAPACK
  incremental condition estimation scheme and a slightly modified
  rank decision test.
Further Comments 
  None
Example

Program Text 

*     MB03OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 10, MMAX = 10 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
      INTEGER          LDTAU
      PARAMETER        ( LDTAU = MIN(MMAX,NMAX) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX + 1 )
*     .. Local Scalars ..
      CHARACTER*1      JOBQR
      INTEGER          I, INFO, J, M, N, RANK
      DOUBLE PRECISION RCOND, SVAL(3), SVLMAX
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU)
      INTEGER          JPVT(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB03OD
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, JOBQR, RCOND, SVLMAX
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
*           QR with column pivoting.
            DO 10 I = 1, N
               JPVT(I) = 0
   10       CONTINUE
            CALL MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU,
     $                   RANK, SVAL, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99995 ) RANK
               WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,N )
               WRITE ( NOUT, FMT = 99993 ) ( SVAL(I), I = 1,3 )
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03OD = ',I2)
99995 FORMAT (' The rank is ',I5)
99994 FORMAT (' Column permutations are ',/(20(I3,2X)))
99993 FORMAT (' SVAL vector is ',/(20(1X,F10.4)))
99972 FORMAT (/' N is out of range.',/' N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 MB03OD EXAMPLE PROGRAM DATA
   6     5     Q  5.D-16     0.0
   1.    2.    6.    3.    5.
  -2.   -1.   -1.    0.   -2.
   5.    5.    1.    5.    1.
  -2.   -1.   -1.    0.   -2.
   4.    8.    4.   20.    4.
  -2.   -1.   -1.    0.   -2.
Program Results 
 MB03OD EXAMPLE PROGRAM RESULTS

 The rank is     4
 Column permutations are 
  4    3    1    5    2
 SVAL vector is 
    22.7257     1.4330     0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03OY.html000077500000000000000000000164131201767322700161220ustar00rootroot00000000000000 MB03OY - SLICOT Library Routine Documentation

MB03OY

Matrix rank determination by incremental condition estimation, during the pivoted QR factorization process

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a rank-revealing QR factorization of a real general
  M-by-N matrix  A,  which may be rank-deficient, and estimate its
  effective rank using incremental condition estimation.

  The routine uses a truncated QR factorization with column pivoting
                                [ R11 R12 ]
     A * P = Q * R,  where  R = [         ],
                                [  0  R22 ]
  with R11 defined as the largest leading upper triangular submatrix
  whose estimated condition number is less than 1/RCOND.  The order
  of R11, RANK, is the effective rank of A.  Condition estimation is
  performed during the QR factorization process.  Matrix R22 is full
  (but of small norm), or empty.

  MB03OY  does not perform any scaling of the matrix A.
Specification 
      SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                   TAU, DWORK, INFO )
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( * )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension
          ( LDA, N )
          On entry, the leading M-by-N part of this array must
          contain the given matrix A.
          On exit, the leading RANK-by-RANK upper triangular part
          of A contains the triangular factor R11, and the elements
          below the diagonal in the first  RANK  columns, with the
          array TAU, represent the orthogonal matrix Q as a product
          of  RANK  elementary reflectors.
          The remaining  N-RANK  columns contain the result of the
          QR factorization process used.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of A, which
          is defined as the order of the largest leading triangular
          submatrix R11 in the QR factorization with pivoting of A,
          whose estimated condition number is less than 1/RCOND.
          0 <= RCOND <= 1.
          NOTE that when SVLMAX > 0, the estimated rank could be
          less than that defined above (see SVLMAX).

  SVLMAX  (input) DOUBLE PRECISION
          If A is a submatrix of another matrix B, and the rank
          decision should be related to that matrix, then SVLMAX
          should be an estimate of the largest singular value of B
          (for instance, the Frobenius norm of B).  If this is not
          the case, the input value SVLMAX = 0 should work.
          SVLMAX >= 0.

  RANK    (output) INTEGER
          The effective (estimated) rank of A, i.e., the order of
          the submatrix R11.

  SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
          The estimates of some of the singular values of the
          triangular factor R:
          SVAL(1): largest singular value of R(1:RANK,1:RANK);
          SVAL(2): smallest singular value of R(1:RANK,1:RANK);
          SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
                   if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
                   otherwise.
          If the triangular factorization is a rank-revealing one
          (which will be the case if the leading columns were well-
          conditioned), then SVAL(1) will also be an estimate for
          the largest singular value of A, and SVAL(2) and SVAL(3)
          will be estimates for the RANK-th and (RANK+1)-st singular
          values of A, respectively.
          By examining these values, one can confirm that the rank
          is well defined with respect to the chosen value of RCOND.
          The ratio SVAL(1)/SVAL(2) is an estimate of the condition
          number of R(1:RANK,1:RANK).

  JPVT    (output) INTEGER array, dimension ( N )
          If JPVT(i) = k, then the i-th column of A*P was the k-th
          column of A.

  TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
          The leading  RANK  elements of TAU contain the scalar
          factors of the elementary reflectors.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension ( 3*N-1 )
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a truncated QR factorization with column
  pivoting of A,  A * P = Q * R,  with  R  defined above, and,
  during this process, finds the largest leading submatrix whose
  estimated condition number is less than 1/RCOND, taking the
  possible positive value of SVLMAX into account.  This is performed
  using the LAPACK incremental condition estimation scheme and a
  slightly modified rank decision test.  The factorization process
  stops when  RANK  has been determined.

  The matrix Q is represented as a product of elementary reflectors

     Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n).

  Each H(i) has the form

     H = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
  A(i+1:m,i), and tau in TAU(i).

  The matrix P is represented in jpvt as follows: If
     jpvt(j) = i
  then the jth column of P is the ith canonical unit vector.
References 
  [1] Bischof, C.H. and P. Tang.
      Generalizing Incremental Condition Estimation.
      LAPACK Working Notes 32, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-132,
      May 1991.

  [2] Bischof, C.H. and P. Tang.
      Robust Incremental Condition Estimation.
      LAPACK Working Notes 33, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-133,
      May 1991.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03PD.html000077500000000000000000000265561201767322700161070ustar00rootroot00000000000000 MB03PD - SLICOT Library Routine Documentation

MB03PD

Matrix rank determination by incremental condition estimation (row pivoting)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute (optionally) a rank-revealing RQ factorization of a
  real general M-by-N matrix  A,  which may be rank-deficient,
  and estimate its effective rank using incremental condition
  estimation.

  The routine uses an RQ factorization with row pivoting:
     P * A = R * Q,  where  R = [ R11 R12 ],
                                [  0  R22 ]
  with R22 defined as the largest trailing submatrix whose estimated
  condition number is less than 1/RCOND.  The order of R22, RANK,
  is the effective rank of A.

  MB03PD  does not perform any scaling of the matrix A.
Specification 
      SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU,
     $                   RANK, SVAL, DWORK, INFO )
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( * )
Arguments

Mode Parameters 

  JOBRQ   CHARACTER*1
          = 'R':  Perform an RQ factorization with row pivoting;
          = 'N':  Do not perform the RQ factorization (but assume
                  that it has been done outside).
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension
          ( LDA, N )
          On entry with JOBRQ = 'R', the leading M-by-N part of this
          array must contain the given matrix A.
          On exit with JOBRQ = 'R',
          if M <= N, the upper triangle of the subarray
          A(1:M,N-M+1:N) contains the M-by-M upper triangular
          matrix R;
          if M >= N, the elements on and above the (M-N)-th
          subdiagonal contain the M-by-N upper trapezoidal matrix R;
          the remaining elements, with the array TAU, represent the
          orthogonal matrix Q as a product of min(M,N) elementary
          reflectors (see METHOD).
          On entry and on exit with JOBRQ = 'N',
          if M <= N, the upper triangle of the subarray
          A(1:M,N-M+1:N) must contain the M-by-M upper triangular
          matrix R;
          if M >= N, the elements on and above the (M-N)-th
          subdiagonal must contain the M-by-N upper trapezoidal
          matrix R;
          the remaining elements are not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  JPVT    (input/output) INTEGER array, dimension ( M )
          On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row
          of A is a final row, otherwise it is a free row. Before
          the RQ factorization of A, all final rows are permuted
          to the trailing positions; only the remaining free rows
          are moved as a result of row pivoting during the
          factorization.  For rank determination it is preferable
          that all rows be free.
          On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th
          row of P*A was the k-th row of A.
          Array JPVT is not referenced when JOBRQ = 'N'.

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of A, which
          is defined as the order of the largest trailing triangular
          submatrix R22 in the RQ factorization with pivoting of A,
          whose estimated condition number is less than 1/RCOND.
          RCOND >= 0.
          NOTE that when SVLMAX > 0, the estimated rank could be
          less than that defined above (see SVLMAX).

  SVLMAX  (input) DOUBLE PRECISION
          If A is a submatrix of another matrix B, and the rank
          decision should be related to that matrix, then SVLMAX
          should be an estimate of the largest singular value of B
          (for instance, the Frobenius norm of B).  If this is not
          the case, the input value SVLMAX = 0 should work.
          SVLMAX >= 0.

  TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
          On exit with JOBRQ = 'R', the leading min(M,N) elements of
          TAU contain the scalar factors of the elementary
          reflectors.
          Array TAU is not referenced when JOBRQ = 'N'.

  RANK    (output) INTEGER
          The effective (estimated) rank of A, i.e. the order of
          the submatrix R22.

  SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
          The estimates of some of the singular values of the
          triangular factor R:
          SVAL(1): largest singular value of
                   R(M-RANK+1:M,N-RANK+1:N);
          SVAL(2): smallest singular value of
                   R(M-RANK+1:M,N-RANK+1:N);
          SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N),
                   if RANK < MIN( M, N ), or of
                   R(M-RANK+1:M,N-RANK+1:N), otherwise.
          If the triangular factorization is a rank-revealing one
          (which will be the case if the trailing rows were well-
          conditioned), then SVAL(1) will also be an estimate for
          the largest singular value of A, and SVAL(2) and SVAL(3)
          will be estimates for the RANK-th and (RANK+1)-st singular
          values of A, respectively.
          By examining these values, one can confirm that the rank
          is well defined with respect to the chosen value of RCOND.
          The ratio SVAL(1)/SVAL(2) is an estimate of the condition
          number of R(M-RANK+1:M,N-RANK+1:N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
          where LDWORK = max( 1, 3*M ),           if JOBRQ = 'R';
                LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = 'N'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes or uses an RQ factorization with row
  pivoting of A,  P * A = R * Q,  with  R  defined above, and then
  finds the largest trailing submatrix whose estimated condition
  number is less than 1/RCOND, taking the possible positive value of
  SVLMAX into account.  This is performed using an adaptation of the
  LAPACK incremental condition estimation scheme and a slightly
  modified rank decision test.

  The matrix Q is represented as a product of elementary reflectors

     Q = H(1) H(2) . . . H(k), where k = min(m,n).

  Each H(i) has the form

     H = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit
  in A(m-k+i,1:n-k+i-1), and tau in TAU(i).

  The matrix P is represented in jpvt as follows: If
     jpvt(j) = i
  then the jth row of P is the ith canonical unit vector.
References 
  [1] Bischof, C.H. and P. Tang.
      Generalizing Incremental Condition Estimation.
      LAPACK Working Notes 32, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-132,
      May 1991.

  [2] Bischof, C.H. and P. Tang.
      Robust Incremental Condition Estimation.
      LAPACK Working Notes 33, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-133,
      May 1991.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

*     MB03PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 10, MMAX = 10 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
      INTEGER          LDTAU
      PARAMETER        ( LDTAU = MIN(MMAX,NMAX) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*MMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOBRQ
      INTEGER          I, INFO, J, M, N, RANK
      DOUBLE PRECISION RCOND, SVAL(3), SVLMAX
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU)
      INTEGER          JPVT(MMAX)
*     .. External Subroutines ..
      EXTERNAL         MB03PD
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, JOBRQ, RCOND, SVLMAX
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
*           RQ with row pivoting.
            DO 10 I = 1, M
               JPVT(I) = 0
   10       CONTINUE
            CALL MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU,
     $                   RANK, SVAL, DWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99995 ) RANK
               WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,M )
               WRITE ( NOUT, FMT = 99993 ) ( SVAL(I), I = 1,3 )
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03PD = ',I2)
99995 FORMAT (' The rank is ',I5)
99994 FORMAT (' Row permutations are ',/(20(I3,2X)))
99993 FORMAT (' SVAL vector is ',/(20(1X,F10.4)))
99972 FORMAT (/' N is out of range.',/' N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 MB03PD EXAMPLE PROGRAM DATA
   6     5     R  5.D-16     0.0
   1.    2.    6.    3.    5.
  -2.   -1.   -1.    0.   -2.
   5.    5.    1.    5.    1.
  -2.   -1.   -1.    0.   -2.
   4.    8.    4.   20.    4.
  -2.   -1.   -1.    0.   -2.
Program Results 
 MB03PD EXAMPLE PROGRAM RESULTS

 The rank is     4
 Row permutations are 
  2    4    6    3    1    5
 SVAL vector is 
    24.5744     0.9580     0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03PY.html000077500000000000000000000166131201767322700161250ustar00rootroot00000000000000 MB03PY - SLICOT Library Routine Documentation

MB03PY

Matrix rank determination by incremental condition estimation, during the pivoted RQ factorization process (row pivoting)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a rank-revealing RQ factorization of a real general
  M-by-N matrix  A,  which may be rank-deficient, and estimate its
  effective rank using incremental condition estimation.

  The routine uses a truncated RQ factorization with row pivoting:
                                [ R11 R12 ]
     P * A = R * Q,  where  R = [         ],
                                [  0  R22 ]
  with R22 defined as the largest trailing upper triangular
  submatrix whose estimated condition number is less than 1/RCOND.
  The order of R22, RANK, is the effective rank of A.  Condition
  estimation is performed during the RQ factorization process.
  Matrix R11 is full (but of small norm), or empty.

  MB03PY  does not perform any scaling of the matrix A.
Specification 
      SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                   TAU, DWORK, INFO )
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( * )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension
          ( LDA, N )
          On entry, the leading M-by-N part of this array must
          contain the given matrix A.
          On exit, the upper triangle of the subarray
          A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper
          triangular matrix R22;  the remaining elements in the last
          RANK  rows, with the array TAU, represent the orthogonal
          matrix Q as a product of  RANK  elementary reflectors
          (see METHOD).  The first  M-RANK  rows contain the result
          of the RQ factorization process used.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of A, which
          is defined as the order of the largest trailing triangular
          submatrix R22 in the RQ factorization with pivoting of A,
          whose estimated condition number is less than 1/RCOND.
          0 <= RCOND <= 1.
          NOTE that when SVLMAX > 0, the estimated rank could be
          less than that defined above (see SVLMAX).

  SVLMAX  (input) DOUBLE PRECISION
          If A is a submatrix of another matrix B, and the rank
          decision should be related to that matrix, then SVLMAX
          should be an estimate of the largest singular value of B
          (for instance, the Frobenius norm of B).  If this is not
          the case, the input value SVLMAX = 0 should work.
          SVLMAX >= 0.

  RANK    (output) INTEGER
          The effective (estimated) rank of A, i.e., the order of
          the submatrix R22.

  SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
          The estimates of some of the singular values of the
          triangular factor R:
          SVAL(1): largest singular value of
                   R(M-RANK+1:M,N-RANK+1:N);
          SVAL(2): smallest singular value of
                   R(M-RANK+1:M,N-RANK+1:N);
          SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N),
                   if RANK < MIN( M, N ), or of
                   R(M-RANK+1:M,N-RANK+1:N), otherwise.
          If the triangular factorization is a rank-revealing one
          (which will be the case if the trailing rows were well-
          conditioned), then SVAL(1) will also be an estimate for
          the largest singular value of A, and SVAL(2) and SVAL(3)
          will be estimates for the RANK-th and (RANK+1)-st singular
          values of A, respectively.
          By examining these values, one can confirm that the rank
          is well defined with respect to the chosen value of RCOND.
          The ratio SVAL(1)/SVAL(2) is an estimate of the condition
          number of R(M-RANK+1:M,N-RANK+1:N).

  JPVT    (output) INTEGER array, dimension ( M )
          If JPVT(i) = k, then the i-th row of P*A was the k-th row
          of A.

  TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
          The trailing  RANK  elements of TAU contain the scalar
          factors of the elementary reflectors.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension ( 3*M-1 )
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a truncated RQ factorization with row
  pivoting of A,  P * A = R * Q,  with  R  defined above, and,
  during this process, finds the largest trailing submatrix whose
  estimated condition number is less than 1/RCOND, taking the
  possible positive value of SVLMAX into account.  This is performed
  using an adaptation of the LAPACK incremental condition estimation
  scheme and a slightly modified rank decision test.  The
  factorization process stops when  RANK  has been determined.

  The matrix Q is represented as a product of elementary reflectors

     Q = H(k-rank+1) H(k-rank+2) . . . H(k), where k = min(m,n).

  Each H(i) has the form

     H = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit
  in A(m-k+i,1:n-k+i-1), and tau in TAU(i).

  The matrix P is represented in jpvt as follows: If
     jpvt(j) = i
  then the jth row of P is the ith canonical unit vector.
References 
  [1] Bischof, C.H. and P. Tang.
      Generalizing Incremental Condition Estimation.
      LAPACK Working Notes 32, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-132,
      May 1991.

  [2] Bischof, C.H. and P. Tang.
      Robust Incremental Condition Estimation.
      LAPACK Working Notes 33, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-133,
      May 1991.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03QD.html000077500000000000000000000265571201767322700161110ustar00rootroot00000000000000 MB03QD - SLICOT Library Routine Documentation

MB03QD

Reordering the diagonal blocks of a principal submatrix of an upper quasi-triangular matrix to have eigenvalues in a specified domain

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reorder the diagonal blocks of a principal submatrix of an
  upper quasi-triangular matrix A together with their eigenvalues by
  constructing an orthogonal similarity transformation UT.
  After reordering, the leading block of the selected submatrix of A
  has eigenvalues in a suitably defined domain of interest, usually
  related to stability/instability in a continuous- or discrete-time
  sense.
Specification 
      SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA,
     $                   A, LDA, U, LDU, NDIM, DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the spectrum separation to be
          performed as follows:
          = 'C':  continuous-time sense;
          = 'D':  discrete-time sense.

  STDOM   CHARACTER*1
          Specifies whether the domain of interest is of stability
          type (left part of complex plane or inside of a circle)
          or of instability type (right part of complex plane or
          outside of a circle) as follows:
          = 'S':  stability type domain;
          = 'U':  instability type domain.

  JOBU    CHARACTER*1
          Indicates how the performed orthogonal transformations UT
          are accumulated, as follows:
          = 'I':  U is initialized to the unit matrix and the matrix
                  UT is returned in U;
          = 'U':  the given matrix U is updated and the matrix U*UT
                  is returned in U.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and U.  N >= 1.

  NLOW,   (input) INTEGER
  NSUP    NLOW and NSUP specify the boundary indices for the rows
          and columns of the principal submatrix of A whose diagonal
          blocks are to be reordered.  1 <= NLOW <= NSUP <= N.

  ALPHA   (input) DOUBLE PRECISION
          The boundary of the domain of interest for the eigenvalues
          of A. If DICO = 'C', ALPHA is the boundary value for the
          real parts of eigenvalues, while for DICO = 'D',
          ALPHA >= 0 represents the boundary value for the moduli of
          eigenvalues.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain a matrix in a real Schur form whose 1-by-1 and
          2-by-2 diagonal blocks between positions NLOW and NSUP
          are to be reordered.
          On exit, the leading N-by-N part contains the ordered
          real Schur matrix UT' * A * UT with the elements below the
          first subdiagonal set to zero.
          The leading NDIM-by-NDIM part of the principal submatrix
          D = A(NLOW:NSUP,NLOW:NSUP) has eigenvalues in the domain
          of interest and the trailing part of this submatrix has
          eigenvalues outside the domain of interest.
          The domain of interest for lambda(D), the eigenvalues of
          D, is defined by the parameters ALPHA, DICO and STDOM as
          follows:
            For DICO = 'C':
               Real(lambda(D)) < ALPHA if STDOM = 'S';
               Real(lambda(D)) > ALPHA if STDOM = 'U'.
            For DICO = 'D':
               Abs(lambda(D)) < ALPHA if STDOM = 'S';
               Abs(lambda(D)) > ALPHA if STDOM = 'U'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
          On entry with JOBU = 'U', the leading N-by-N part of this
          array must contain a transformation matrix (e.g. from a
          previous call to this routine).
          On exit, if JOBU = 'U', the leading N-by-N part of this
          array contains the product of the input matrix U and the
          orthogonal matrix UT used to reorder the diagonal blocks
          of A.
          On exit, if JOBU = 'I', the leading N-by-N part of this
          array contains the matrix UT of the performed orthogonal
          transformations.
          Array U need not be set on entry if JOBU = 'I'.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= N.

  NDIM    (output) INTEGER
          The number of eigenvalues of the selected principal
          submatrix lying inside the domain of interest.
          If NLOW = 1, NDIM is also the dimension of the invariant
          subspace corresponding to the eigenvalues of the leading
          NDIM-by-NDIM submatrix. In this case, if U is the
          orthogonal transformation matrix used to compute and
          reorder the real Schur form of A, its first NDIM columns
          form an orthonormal basis for the above invariant
          subspace.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  A(NLOW,NLOW-1) is nonzero, i.e. A(NLOW,NLOW) is not
                the leading element of a 1-by-1 or 2-by-2 diagonal
                block of A, or A(NSUP+1,NSUP) is nonzero, i.e.
                A(NSUP,NSUP) is not the bottom element of a 1-by-1
                or 2-by-2 diagonal block of A;
          = 2:  two adjacent blocks are too close to swap (the
                problem is very ill-conditioned).
Method 
  Given an upper quasi-triangular matrix A with 1-by-1 or 2-by-2
  diagonal blocks, the routine reorders its diagonal blocks along
  with its eigenvalues by performing an orthogonal similarity
  transformation UT' * A * UT. The column transformation UT is also
  performed on the given (initial) transformation U (resulted from
  a possible previous step or initialized as the identity matrix).
  After reordering, the eigenvalues inside the region specified by
  the parameters ALPHA, DICO and STDOM appear at the top of
  the selected diagonal block between positions NLOW and NSUP.
  In other words, lambda(A(NLOW:NSUP,NLOW:NSUP)) are ordered such
  that lambda(A(NLOW:NLOW+NDIM-1,NLOW:NLOW+NDIM-1)) are inside and
  lambda(A(NLOW+NDIM:NSUP,NLOW+NDIM:NSUP)) are outside the domain
  of interest. If NLOW = 1, the first NDIM columns of U*UT span the
  corresponding invariant subspace of A.
References 
  [1] Stewart, G.W.
      HQR3 and EXCHQZ: FORTRAN subroutines for calculating and
      ordering the eigenvalues of a real upper Hessenberg matrix.
      ACM TOMS, 2, pp. 275-280, 1976.
Numerical Aspects 
                                      3
  The algorithm requires less than 4*N  operations.
Further Comments 
  None
Example

Program Text 

*     MB03QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 10 )
      INTEGER          LDA, LDU
      PARAMETER        ( LDA = NMAX, LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      DICO, JOBU, STDOM
      INTEGER          I, INFO, J, N, NDIM, NLOW, NSUP
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), U(LDU,NMAX),
     $                 WI(NMAX), WR(NMAX)
      LOGICAL          BWORK(NMAX)
*     .. External Functions ..
      LOGICAL          SELECT
*     .. External Subroutines ..
      EXTERNAL         DGEES, MB03QD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NLOW, NSUP, ALPHA, DICO, STDOM, JOBU
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Compute Schur form, eigenvalues and Schur vectors.
         CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, NDIM,
     $               WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
*           Block reordering.
            CALL MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA,
     $                   A, LDA, U, LDU, NDIM, DWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99996 ) NDIM
               WRITE ( NOUT, FMT = 99994 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N )
   20          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DGEES  = ',I2)
99997 FORMAT (' INFO on exit from MB03QD = ',I2)
99996 FORMAT (' The number of eigenvalues in the domain is ',I5)
99995 FORMAT (8X,20(1X,F8.4))
99994 FORMAT (/' The ordered Schur form matrix is ')
99993 FORMAT (/' The transformation matrix is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB03QD EXAMPLE PROGRAM DATA
   4     1     4      0.0      C      S      U
  -1.0  37.0 -12.0 -12.0
  -1.0 -10.0   0.0   4.0
   2.0  -4.0   7.0  -6.0
   2.0   2.0   7.0  -9.0
Program Results 
 MB03QD EXAMPLE PROGRAM RESULTS

 The number of eigenvalues in the domain is     4

 The ordered Schur form matrix is 
          -3.1300 -26.5066  27.2262 -16.2009
           0.9070  -3.1300  13.6254   8.9206
           0.0000   0.0000  -3.3700   0.3419
           0.0000   0.0000  -1.7879  -3.3700

 The transformation matrix is 
           0.9611   0.1784   0.2064  -0.0440
          -0.1468  -0.2704   0.8116  -0.4965
          -0.2224   0.7675   0.4555   0.3924
          -0.0733   0.5531  -0.3018  -0.7730

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03QX.html000077500000000000000000000041571201767322700161250ustar00rootroot00000000000000 MB03QX - SLICOT Library Routine Documentation

MB03QX

Eigenvalues of an upper quasi-triangular matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of an upper quasi-triangular matrix.
Specification 
      SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDT, N
C     .. Array Arguments ..
      DOUBLE PRECISION T(LDT, *), WI(*), WR(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix T.  N >= 0.

  T       (input) DOUBLE PRECISION array, dimension(LDT,N)
          The upper quasi-triangular matrix T.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= max(1,N).

  WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
          The real and imaginary parts, respectively, of the
          eigenvalues of T. The eigenvalues are stored in the same
          order as on the diagonal of T. If T(i:i+1,i:i+1) is a
          2-by-2 diagonal block with complex conjugated eigenvalues
          then WI(i) > 0 and WI(i+1) = -WI(i).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03QY.html000077500000000000000000000102071201767322700161170ustar00rootroot00000000000000 MB03QY - SLICOT Library Routine Documentation

MB03QY

Transformation to the Schur canonical form of a selected 2-by-2 diagonal block of an upper quasi-triangular matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of a selected 2-by-2 diagonal block
  of an upper quasi-triangular matrix, to reduce the selected block
  to the standard form and to split the block in the case of real
  eigenvalues by constructing an orthogonal transformation UT.
  This transformation is applied to A (by similarity) and to
  another matrix U from the right.
Specification 
      SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO )
C     .. Scalar Arguments ..
      INTEGER          INFO, L, LDA, LDU, N
      DOUBLE PRECISION E1, E2
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), U(LDU,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrices A and UT.  N >= 2.

  L       (input) INTEGER
          Specifies the position of the block.  1 <= L < N.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the upper quasi-triangular matrix A whose
          selected 2-by-2 diagonal block is to be processed.
          On exit, the leading N-by-N part of this array contains
          the upper quasi-triangular matrix A after its selected
          block has been splitt and/or put in the LAPACK standard
          form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
          On entry, the leading N-by-N part of this array must
          contain a transformation matrix U.
          On exit, the leading N-by-N part of this array contains
          U*UT, where UT is the transformation matrix used to
          split and/or standardize the selected block.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= N.

  E1, E2  (output) DOUBLE PRECISION
          E1 and E2 contain either the real eigenvalues or the real
          and positive imaginary parts, respectively, of the complex
          eigenvalues of the selected 2-by-2 diagonal block of A.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Let A1 = ( A(L,L)    A(L,L+1)   )
           ( A(L+1,L)  A(L+1,L+1) )
  be the specified 2-by-2 diagonal block of matrix A.
  If the eigenvalues of A1 are complex, then they are computed and
  stored in E1 and E2, where the real part is stored in E1 and the
  positive imaginary part in E2. The 2-by-2 block is reduced if
  necessary to the standard form, such that A(L,L) = A(L+1,L+1), and
  A(L,L+1) and A(L+1,L) have oposite signs. If the eigenvalues are
  real, the 2-by-2 block is reduced to an upper triangular form such
  that ABS(A(L,L)) >= ABS(A(L+1,L+1)).
  In both cases, an orthogonal rotation U1' is constructed such that
  U1'*A1*U1 has the appropriate form. Let UT be an extension of U1
  to an N-by-N orthogonal matrix, using identity submatrices. Then A
  is replaced by UT'*A*UT and the contents of array U is U * UT.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03RD.html000077500000000000000000000366101201767322700161010ustar00rootroot00000000000000 MB03RD - SLICOT Library Routine Documentation

MB03RD

Reduction of a real Schur form matrix to a block-diagonal form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce a matrix A in real Schur form to a block-diagonal form
  using well-conditioned non-orthogonal similarity transformations.
  The condition numbers of the transformations used for reduction
  are roughly bounded by PMAX*PMAX, where PMAX is a given value.
  The transformations are optionally postmultiplied in a given
  matrix X. The real Schur form is optionally ordered, so that
  clustered eigenvalues are grouped in the same block.
Specification 
      SUBROUTINE MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS,
     $                   BLSIZE, WR, WI, TOL, DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOBX    CHARACTER*1
          Specifies whether or not the transformations are
          accumulated, as follows:
          = 'N':  The transformations are not accumulated;
          = 'U':  The transformations are accumulated in X (the
                  given matrix X is updated).

  SORT    CHARACTER*1
          Specifies whether or not the diagonal blocks of the real
          Schur form are reordered, as follows:
          = 'N':  The diagonal blocks are not reordered;
          = 'S':  The diagonal blocks are reordered before each
                  step of reduction, so that clustered eigenvalues
                  appear in the same block;
          = 'C':  The diagonal blocks are not reordered, but the
                  "closest-neighbour" strategy is used instead of
                  the standard "closest to the mean" strategy
                  (see METHOD);
          = 'B':  The diagonal blocks are reordered before each
                  step of reduction, and the "closest-neighbour"
                  strategy is used (see METHOD).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and X.  N >= 0.

  PMAX    (input) DOUBLE PRECISION
          An upper bound for the infinity norm of elementary
          submatrices of the individual transformations used for
          reduction (see METHOD).  PMAX >= 1.0D0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A to be block-diagonalized, in real
          Schur form.
          On exit, the leading N-by-N part of this array contains
          the computed block-diagonal matrix, in real Schur
          canonical form. The non-diagonal blocks are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, if JOBX = 'U', the leading N-by-N part of this
          array must contain a given matrix X.
          On exit, if JOBX = 'U', the leading N-by-N part of this
          array contains the product of the given matrix X and the
          transformation matrix that reduced A to block-diagonal
          form. The transformation matrix is itself a product of
          non-orthogonal similarity transformations having elements
          with magnitude less than or equal to PMAX.
          If JOBX = 'N', this array is not referenced.

  LDX     INTEGER
          The leading dimension of array X.
          LDX >= 1,        if JOBX = 'N';
          LDX >= MAX(1,N), if JOBX = 'U'.

  NBLCKS  (output) INTEGER
          The number of diagonal blocks of the matrix A.

  BLSIZE  (output) INTEGER array, dimension (N)
          The first NBLCKS elements of this array contain the orders
          of the resulting diagonal blocks of the matrix A.

  WR,     (output) DOUBLE PRECISION arrays, dimension (N)
  WI      These arrays contain the real and imaginary parts,
          respectively, of the eigenvalues of the matrix A.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in the ordering of the diagonal
          blocks of the real Schur form matrix.
          If the user sets TOL > 0, then the given value of TOL is
          used as an absolute tolerance: a block i and a temporarily
          fixed block 1 (the first block of the current trailing
          submatrix to be reduced) are considered to belong to the
          same cluster if their eigenvalues satisfy

            | lambda_1 - lambda_i | <= TOL.

          If the user sets TOL < 0, then the given value of TOL is
          used as a relative tolerance: a block i and a temporarily
          fixed block 1 are considered to belong to the same cluster
          if their eigenvalues satisfy, for j = 1, ..., N,

            | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |.

          If the user sets TOL = 0, then an implicitly computed,
          default tolerance, defined by TOL = SQRT( SQRT( EPS ) )
          is used instead, as a relative tolerance, where EPS is
          the machine precision (see LAPACK Library routine DLAMCH).
          If SORT = 'N' or 'C', this parameter is not referenced.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Consider first that SORT = 'N'. Let

         ( A    A   )
         (  11   12 )
     A = (          ),
         ( 0    A   )
         (       22 )

  be the given matrix in real Schur form, where initially A   is the
                                                           11
  first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is
  made to compute a transformation matrix X of the form

         ( I   P )
     X = (       )                                               (1)
         ( 0   I )

  (partitioned as A), so that

              ( A     0  )
      -1      (  11      )
     X  A X = (          ),
              ( 0    A   )
              (       22 )

  and the elements of P do not exceed the value PMAX in magnitude.
  An adaptation of the standard method for solving Sylvester
  equations [1], which controls the magnitude of the individual
  elements of the computed solution [2], is used to obtain matrix P.
  When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of
  A  , whose eigenvalue(s) is (are) the closest to the mean of those
   22
  of A   is selected, and moved by orthogonal similarity
      11
  transformations in the leading position of A  ; the moved diagonal
                                              22
  block is then added to the block A  , increasing its order by 1
                                    11
  (or 2). Another attempt is made to compute a suitable
  transformation matrix X with the new definitions of the blocks A
                                                                  11
  and A  . After a successful transformation matrix X has been
       22
  obtained, it postmultiplies the current transformation matrix
  (if JOBX = 'U'), and the whole procedure is repeated for the
  matrix A  .
          22

  When SORT = 'S', the diagonal blocks of the real Schur form are
  reordered before each step of the reduction, so that each cluster
  of eigenvalues, defined as specified in the definition of TOL,
  appears in adjacent blocks. The blocks for each cluster are merged
  together, and the procedure described above is applied to the
  larger blocks. Using the option SORT = 'S' will usually provide
  better efficiency than the standard option (SORT = 'N'), proposed
  in [2], because there could be no or few unsuccessful attempts
  to compute individual transformation matrices X of the form (1).
  However, the resulting dimensions of the blocks are usually
  larger; this could make subsequent calculations less efficient.

  When SORT = 'C' or 'B', the procedure is similar to that for
  SORT = 'N' or 'S', respectively, but the block of A   whose
                                                     22
  eigenvalue(s) is (are) the closest to those of A   (not to their
                                                  11
  mean) is selected and moved to the leading position of A  . This
                                                          22
  is called the "closest-neighbour" strategy.
References 
  [1] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Bavely, C. and Stewart, G.W.
      An Algorithm for Computing Reducing Subspaces by Block
      Diagonalization.
      SIAM J. Numer. Anal., 16, pp. 359-367, 1979.

  [3] Demmel, J.
      The Condition Number of Equivalence Transformations that
      Block Diagonalize Matrix Pencils.
      SIAM J. Numer. Anal., 20, pp. 599-610, 1983.
Numerical Aspects 
                                    3                     4
  The algorithm usually requires 0(N ) operations, but 0(N ) are
  possible in the worst case, when all diagonal blocks in the real
  Schur form of A are 1-by-1, and the matrix cannot be diagonalized
  by well-conditioned transformations.
Further Comments 
  The individual non-orthogonal transformation matrices used in the
  reduction of A to a block-diagonal form have condition numbers
  of the order PMAX*PMAX. This does not guarantee that their product
  is well-conditioned enough. The routine can be easily modified to
  provide estimates for the condition numbers of the clusters of
  eigenvalues.
Example

Program Text 

*     MB03RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 10 )
      INTEGER          LDA, LDX
      PARAMETER        ( LDA = NMAX, LDX = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOBX, SORT
      INTEGER          I, INFO, J, N, NBLCKS, SDIM
      DOUBLE PRECISION PMAX, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), WI(NMAX), WR(NMAX),
     $                 X(LDX,NMAX)
      INTEGER          BLSIZE(NMAX)
      LOGICAL          BWORK(NMAX)
*     .. External Functions ..
      LOGICAL          SELECT
*     .. External Subroutines ..
      EXTERNAL         DGEES, MB03RD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, PMAX, TOL, JOBX, SORT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Compute Schur form, eigenvalues and Schur vectors.
         CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, SDIM,
     $               WR, WI, X, LDX, DWORK, LDWORK, BWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
*           Block-diagonalization.
            CALL MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS,
     $                   BLSIZE, WR, WI, TOL, DWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99995 ) NBLCKS
               WRITE ( NOUT, FMT = 99994 ) ( BLSIZE(I), I = 1,NBLCKS )
               WRITE ( NOUT, FMT = 99993 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99992 ) ( A(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99991 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99992 ) ( X(I,J), J = 1,N )
   20          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DGEES  = ',I2)
99997 FORMAT (' INFO on exit from MB03RD = ',I2)
99995 FORMAT (' The number of blocks is ',I5)
99994 FORMAT (' The orders of blocks are ',/(20(I3,2X)))
99993 FORMAT (' The block-diagonal matrix is ')
99992 FORMAT (8X,20(1X,F8.4))
99991 FORMAT (' The transformation matrix is ')
99972 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB03RD EXAMPLE PROGRAM DATA
   8   1.D03   1.D-2     U     S
   1.   -1.    1.    2.    3.    1.    2.    3.
   1.    1.    3.    4.    2.    3.    4.    2.
   0.    0.    1.   -1.    1.    5.    4.    1.
   0.    0.    0.    1.   -1.    3.    1.    2.
   0.    0.    0.    1.    1.    2.    3.   -1.
   0.    0.    0.    0.    0.    1.    5.    1.
   0.    0.    0.    0.    0.    0.    0.99999999   -0.99999999
   0.    0.    0.    0.    0.    0.    0.99999999    0.99999999
Program Results 
 MB03RD EXAMPLE PROGRAM RESULTS

 The number of blocks is     2
 The orders of blocks are 
  6    2
 The block-diagonal matrix is 
           1.0000  -1.0000  -1.2247  -0.7071  -3.4186   1.4577   0.0000   0.0000
           1.0000   1.0000   0.0000   1.4142  -5.1390   3.1637   0.0000   0.0000
           0.0000   0.0000   1.0000  -1.7321  -0.0016   2.0701   0.0000   0.0000
           0.0000   0.0000   0.5774   1.0000   0.7516   1.1379   0.0000   0.0000
           0.0000   0.0000   0.0000   0.0000   1.0000  -5.8606   0.0000   0.0000
           0.0000   0.0000   0.0000   0.0000   0.1706   1.0000   0.0000   0.0000
           0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000  -0.8850
           0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000
 The transformation matrix is 
           1.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.9045   0.1957
           0.0000   1.0000   0.0000   0.0000   0.0000   0.0000  -0.3015   0.9755
           0.0000   0.0000   0.8165   0.0000  -0.5768  -0.0156  -0.3015   0.0148
           0.0000   0.0000  -0.4082   0.7071  -0.5768  -0.0156   0.0000  -0.0534
           0.0000   0.0000  -0.4082  -0.7071  -0.5768  -0.0156   0.0000   0.0801
           0.0000   0.0000   0.0000   0.0000  -0.0276   0.9805   0.0000   0.0267
           0.0000   0.0000   0.0000   0.0000   0.0332  -0.0066   0.0000   0.0000
           0.0000   0.0000   0.0000   0.0000   0.0011   0.1948   0.0000   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03RX.html000077500000000000000000000135101201767322700161170ustar00rootroot00000000000000 MB03RX - SLICOT Library Routine Documentation

MB03RX

Reordering the diagonal blocks of a principal submatrix of a real Schur form matrix (the last block is moved in the leading position)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reorder the diagonal blocks of the principal submatrix between
  the indices KL and KU (KU >= KL) of a real Schur form matrix A
  together with their eigenvalues, using orthogonal similarity
  transformations, such that the block specified by KU is moved in
  the position KL. The transformations are optionally postmultiplied
  in a given matrix X.
Specification 
      SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI,
     $                   DWORK )
C     .. Scalar Arguments ..
      CHARACTER         JOBV
      INTEGER           KL, KU, LDA, LDX, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*)
Arguments

Mode Parameters 

  JOBV    CHARACTER*1
          Specifies whether or not the transformations are
          accumulated, as follows:
          = 'N':  The transformations are not accumulated;
          = 'V':  The transformations are accumulated in X (the
                  given matrix X is updated).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and X.  N >= 0.

  KL      (input) INTEGER
          The lower boundary index for the rows and columns of the
          principal submatrix of A whose diagonal blocks are to be
          reordered, and also the target position for the block to
          be moved.  1 <= KL <= KU <= N.

  KU      (input/output) INTEGER
          On entry, KU specifies the upper boundary index for the
          rows and columns of the principal submatrix of A whose
          diagonal blocks are to be reordered, and also the original
          position for the block to be moved.  1 <= KL <= KU <= N.
          On exit, KU specifies the upper boundary index for the
          rows and columns of the principal submatrix of A whose
          diagonal blocks have been reordered. The given value will
          be increased by 1 if the moved block was 2-by-2 and it has
          been replaced by two 1-by-1 blocks. Otherwise, its input
          value is preserved.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A in real Schur canonical form.
          On exit, the leading N-by-N part of this array contains
          the ordered real Schur canonical form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, if JOBV = 'V', the leading N-by-N part of this
          array must contain a given matrix X.
          On exit, if JOBV = 'V', the leading N-by-N part of this
          array contains the product of the given matrix X and the
          transformation matrix that performed the reordering of A.
          If JOBV = 'N', this array is not referenced.

  LDX     INTEGER
          The leading dimension of array X.
          LDX >= 1,        if JOBV = 'N';
          LDX >= MAX(1,N), if JOBV = 'V'.

  WR,     (input/output) DOUBLE PRECISION arrays, dimension (N)
  WI      On entry, these arrays must contain the real and imaginary
          parts, respectively, of the eigenvalues of the matrix A.
          On exit, these arrays contain the real and imaginary
          parts, respectively, of the eigenvalues of the matrix A,
          possibly reordered.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Method 
  An attempt is made to move the block in the position (KU,KU) to
  the position (KL,KL) by a sequence of orthogonal similarity
  transformations, each swapping two consecutive blocks. The
  standard algorithm [1], [2] usually succeeds to perform this
  reordering. A failure of this algorithm means that two consecutive
  blocks (one of them being the desired block possibly moved) are
  too close to swap. In such a case, the leading block of the two
  is tried to be moved in the position (KL,KL) and the procedure is
  repeated.
References 
  [1] Stewart, G.W.
      HQR3 and EXCHQZ: FORTRAN subroutines for calculating and
      ordering the eigenvalues of a real upper Hessenberg matrix.
      ACM TOMS, 2, pp. 275-280, 1976.

  [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is numerically stable. If some eigenvalues are
  ill-conditioned, their returned values could differ much from
  their input values.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03RY.html000077500000000000000000000133761201767322700161320ustar00rootroot00000000000000 MB03RY - SLICOT Library Routine Documentation

MB03RY

Solution of a Sylvester equation -AX + XB = C, with A and B in real Schur form, aborting the computations when the norm of X is too large

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the Sylvester equation -AX + XB = C, where A and B are
  M-by-M and N-by-N matrices, respectively, in real Schur form.

  This routine is intended to be called only by SLICOT Library
  routine MB03RD. For efficiency purposes, the computations are
  aborted when the infinity norm of an elementary submatrix of X is
  greater than a given value PMAX.
Specification 
      SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, M, N
      DOUBLE PRECISION  PMAX
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The order of the matrix A and the number of rows of the
          matrices C and X.  M >= 0.

  N       (input) INTEGER
          The order of the matrix B and the number of columns of the
          matrices C and X.  N >= 0.

  PMAX    (input) DOUBLE PRECISION
          An upper bound for the infinity norm of an elementary
          submatrix of X (see METHOD).

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain the
          matrix A of the Sylvester equation, in real Schur form.
          The elements below the real Schur form are not referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
          The leading N-by-N part of this array must contain the
          matrix B of the Sylvester equation, in real Schur form.
          The elements below the real Schur form are not referenced.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix C of the Sylvester equation.
          On exit, if INFO = 0, the leading M-by-N part of this
          array contains the solution matrix X of the Sylvester
          equation, and each elementary submatrix of X (see METHOD)
          has the infinity norm less than or equal to PMAX.
          On exit, if INFO = 1, the solution matrix X has not been
          computed completely, because an elementary submatrix of X
          had the infinity norm greater than PMAX. Part of the
          matrix C has possibly been overwritten with the
          corresponding part of X.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  an elementary submatrix of X had the infinity norm
                greater than the given value PMAX.
Method 
  The routine uses an adaptation of the standard method for solving
  Sylvester equations [1], which controls the magnitude of the
  individual elements of the computed solution [2]. The equation
  -AX + XB = C can be rewritten as
                              p            l-1
    -A  X   + X  B   = C   + sum  A  X   - sum  X  B
      kk kl    kl ll    kl  i=k+1  ki il   j=1   kj jl

  for l = 1:q, and k = p:-1:1, where A  , B  , C  , and X  , are
                                      kk   ll   kl       kl
  block submatrices defined by the partitioning induced by the Schur
  form of A and B, and p and q are the numbers of the diagonal
  blocks of A and B, respectively. So, the elementary submatrices of
  X are found block column by block column, starting from the
  bottom. If any such elementary submatrix has the infinity norm
  greater than the given value PMAX, the calculations are ended.
References 
  [1] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Bavely, C. and Stewart, G.W.
      An Algorithm for Computing Reducing Subspaces by Block
      Diagonalization.
      SIAM J. Numer. Anal., 16, pp. 359-367, 1979.
Numerical Aspects 
                            2      2
  The algorithm requires 0(M N + MN ) operations.
Further Comments 
  Let

         ( A   C )       ( I   X )
     M = (       ),  Y = (       ).
         ( 0   B )       ( 0   I )

  Then

      -1      ( A   0 )
     Y  M Y = (       ),
              ( 0   B )

  hence Y is an non-orthogonal transformation matrix which performs
  the reduction of M to a block-diagonal form. Bounding a norm of
  X is equivalent to setting an upper bound to the condition number
  of the transformation matrix Y.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03SD.html000077500000000000000000000226231201767322700161010ustar00rootroot00000000000000 MB03SD - SLICOT Library Routine Documentation

MB03SD

Eigenvalues of a square-reduced Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of an N-by-N square-reduced Hamiltonian
  matrix

             ( A'   G'  )
      H'  =  (        T ).                                       (1)
             ( Q'  -A'  )

  Here, A' is an N-by-N matrix, and G' and Q' are symmetric N-by-N
  matrices.  It is assumed without a check that H' is square-
  reduced, i.e., that

        2    ( A''   G'' )
      H'  =  (         T )    with A'' upper Hessenberg.         (2)
             ( 0    A''  )

                         T                2
  (Equivalently, Q'A'- A' Q' = 0, A'' = A' + G'Q', and for i > j+1,
   A''(i,j) = 0.)  Ordinarily, H' is the output from SLICOT Library
  routine MB04ZD. The eigenvalues of H' are computed as the square
  roots of the eigenvalues of A''.
Specification 
      SUBROUTINE MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDQG, LDWORK, N
      CHARACTER         JOBSCL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), QG(LDQG,*), WI(*), WR(*)
Arguments

Mode Parameters 

  JOBSCL  CHARACTER*1
          Specifies whether or not balancing operations should
          be performed by the LAPACK subroutine DGEBAL on the
          Hessenberg matrix A'' in (2), as follows:
          = 'N':  do not use balancing;
          = 'S':  do scaling in order to equilibrate the rows
                  and columns of A''.
          See LAPACK subroutine DGEBAL and Section METHOD below.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, G, and Q.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          upper left block A' of the square-reduced Hamiltonian
          matrix H' in (1), as produced by SLICOT Library routine
          MB04ZD.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  QG      (input) DOUBLE PRECISION array, dimension (LDQG,N+1)
          The leading N-by-N lower triangular part of this array
          must contain the lower triangle of the lower left
          symmetric block Q' of the square-reduced Hamiltonian
          matrix H' in (1), and the N-by-N upper triangular part of
          the submatrix in the columns 2 to N+1 of this array must
          contain the upper triangle of the upper right symmetric
          block G' of the square-reduced Hamiltonian matrix H'
          in (1), as produced by SLICOT Library routine MB04ZD.
          So, if i >= j, then Q'(i,j) is stored in QG(i,j) and
          G'(i,j) is stored in QG(j,i+1).

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= MAX(1,N).

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          The arrays WR and WI contain the real and imaginary parts,
          respectively, of the N eigenvalues of H' with non-negative
          real part.  The remaining N eigenvalues are the negatives
          of these eigenvalues.
          Eigenvalues are stored in WR and WI in decreasing order of
          magnitude of the real parts, i.e., WR(I) >= WR(I+1).
          (In particular, an eigenvalue closest to the imaginary
           axis is WR(N)+WI(N)i.)
          In addition, eigenvalues with zero real part are sorted in
          decreasing order of magnitude of imaginary parts.  Note
          that non-real eigenvalues with non-zero real part appear
          in complex conjugate pairs, but eigenvalues with zero real
          part do not, in general, appear in complex conjugate
          pairs.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= MAX(1,N*(N+1)).
          For good performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, then the i-th argument had an illegal
                value;
          > 0:  if INFO =  i, i <= N, then LAPACK subroutine DHSEQR
                failed to converge while computing the i-th
                eigenvalue.
Method 
  The routine forms the upper Hessenberg matrix A'' in (2) and calls
  LAPACK subroutines to calculate its eigenvalues.  The eigenvalues
  of H' are the square roots of the eigenvalues of A''.
References 
  [1] Van Loan, C. F.
      A Symplectic Method for Approximating All the Eigenvalues of
      a Hamiltonian Matrix.
      Linear Algebra and its Applications, 61, pp. 233-251, 1984.

  [2] Byers, R.
      Hamiltonian and Symplectic Algorithms for the Algebraic
      Riccati Equation.
      Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983.

  [3] Benner, P., Byers, R., and Barth, E.
      Fortran 77 Subroutines for Computing the Eigenvalues of
      Hamiltonian Matrices. I: The Square-Reduced Method.
      ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000.
Numerical Aspects 
  The algorithm requires (32/3)*N**3 + O(N**2) floating point
  operations.
  Eigenvalues computed by this subroutine are exact eigenvalues
  of a perturbed Hamiltonian matrix  H' + E  where

              || E || <= c sqrt(eps) || H' ||,

  c is a modest constant depending on the dimension N and eps is the
  machine precision. Moreover, if the norm of H' and an eigenvalue
  are of roughly the same magnitude, the computed eigenvalue is
  essentially as accurate as the computed eigenvalue obtained by
  traditional methods. See [1] or [2].
Further Comments 
  None
Example

Program Text 

*     MB03SD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDQG
      PARAMETER        ( LDA = NMAX, LDQG = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( NMAX+1 ) )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      CHARACTER*1      JOBSCL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), QG(LDQG,NMAX+1),
     $                 WI(NMAX), WR(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB03SD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
*     NOTE: input must define a square-reduced Hamiltonian matrix.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOBSCL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99998 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J),    J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J),   I = J,N ), J = 1,N )
*        Compute the eigenvalues.
         CALL MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK,
     $                LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99997 ) INFO
         ELSE
*           Show the computed eigenvalues.
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99995 )  WR(I), ' + (',  WI(I), ')i'
10          CONTINUE
            DO 20 I = N, 1, -1
               WRITE ( NOUT, FMT = 99995 ) -WR(I), ' + (', -WI(I), ')i'
20          CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB03SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' N is out of range.',/' N = ',I5)
99997 FORMAT (' INFO on exit from MB03SD = ',I2)
99996 FORMAT (/' The eigenvalues are ')
99995 FORMAT (1X,F8.4,A,F8.4,A)
      END
Program Data 
MB03SD EXAMPLE PROGRAM DATA
 3 S
  2.0  0.0  0.0
  0.0  1.0  2.0
  0.0 -1.0  3.0
  1.0  0.0  0.0  2.0  3.0  4.0
 -2.0  0.0  0.0  0.0  0.0  0.0
Program Results 
 MB03SD EXAMPLE PROGRAM RESULTS


 The eigenvalues are 
   2.0000 + (  1.0000)i
   2.0000 + ( -1.0000)i
   1.4142 + (  0.0000)i
  -1.4142 + (  0.0000)i
  -2.0000 + (  1.0000)i
  -2.0000 + ( -1.0000)i

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03TD.html000077500000000000000000000374551201767322700161130ustar00rootroot00000000000000 MB03TD - SLICOT Library Routine Documentation

MB03TD

Reordering the diagonal blocks of a matrix in (skew-)Hamiltonian Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reorder a matrix X in skew-Hamiltonian Schur form:

                [  A   G  ]          T
          X  =  [       T ],   G = -G,
                [  0   A  ]

  or in Hamiltonian Schur form:

                [  A   G  ]          T
          X  =  [       T ],   G =  G,
                [  0  -A  ]

  where A is in upper quasi-triangular form, so that a selected
  cluster of eigenvalues appears in the leading diagonal blocks
  of the matrix A (in X) and the leading columns of [ U1; -U2 ] form
  an orthonormal basis for the corresponding right invariant
  subspace.

  If X is skew-Hamiltonian, then each eigenvalue appears twice; one
  copy corresponds to the j-th diagonal element and the other to the
  (n+j)-th diagonal element of X. The logical array LOWER controls
  which copy is to be reordered to the leading part of A.

  If X is Hamiltonian then the eigenvalues appear in pairs
  (lambda,-lambda); lambda corresponds to the j-th diagonal
  element and -lambda to the (n+j)-th diagonal element of X.
  The logical array LOWER controls whether lambda or -lambda is to
  be reordered to the leading part of A.

  The matrix A must be in Schur canonical form (as returned by the
  LAPACK routine DHSEQR), that is, block upper triangular with
  1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
  its diagonal elements equal and its off-diagonal elements of
  opposite sign.
Specification 
      SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG,
     $                   U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  TYP     CHARACTER*1
          Specifies the type of the input matrix X:
          = 'S': X is skew-Hamiltonian;
          = 'H': X is Hamiltonian.

  COMPU   CHARACTER*1
          = 'U': update the matrices U1 and U2 containing the
                 Schur vectors;
          = 'N': do not update U1 and U2.

  SELECT  (input/output) LOGICAL array, dimension (N)
          SELECT specifies the eigenvalues in the selected cluster.
          To select a real eigenvalue w(j), SELECT(j) must be set
          to .TRUE.. To select a complex conjugate pair of
          eigenvalues w(j) and w(j+1), corresponding to a 2-by-2
          diagonal block, both SELECT(j) and SELECT(j+1) must be set
          to .TRUE.; a complex conjugate pair of eigenvalues must be
          either both included in the cluster or both excluded.

  LOWER   (input/output) LOGICAL array, dimension (N)
          LOWER controls which copy of a selected eigenvalue is
          included in the cluster. If SELECT(j) is set to .TRUE.
          for a real eigenvalue w(j); then LOWER(j) must be set to
          .TRUE. if the eigenvalue corresponding to the (n+j)-th
          diagonal element of X is to be reordered to the leading
          part; and LOWER(j) must be set to .FALSE. if the
          eigenvalue corresponding to the j-th diagonal element of
          X is to be reordered to the leading part. Similarly, for
          a complex conjugate pair of eigenvalues w(j) and w(j+1),
          both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the
          eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1)
          diagonal block of X are to be reordered to the leading
          part.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the upper quasi-triangular matrix A in Schur
          canonical form.
          On exit, the leading N-by-N part of this array contains
          the reordered matrix A, again in Schur canonical form,
          with the selected eigenvalues in the diagonal blocks.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, if TYP = 'S', the leading N-by-N part of this
          array must contain the strictly upper triangular part of
          the skew-symmetric matrix G. The rest of this array is not
          referenced.
          On entry, if TYP = 'H', the leading N-by-N part of this
          array must contain the upper triangular part of the
          symmetric matrix G. The rest of this array is not
          referenced.
          On exit, if TYP = 'S', the leading N-by-N part of this
          array contains the strictly upper triangular part of the
          skew-symmetric matrix G, updated by the orthogonal
          symplectic transformation which reorders X.
          On exit, if TYP = 'H', the leading N-by-N part of this
          array contains the upper triangular part of the symmetric
          matrix G, updated by the orthogonal symplectic
          transformation which reorders X.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,N).

  U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
          On entry, if COMPU = 'U', the leading N-by-N part of this
          array must contain U1, the (1,1) block of an orthogonal
          symplectic matrix U = [ U1, U2; -U2, U1 ].
          On exit, if COMPU = 'U', the leading N-by-N part of this
          array contains the (1,1) block of the matrix U,
          postmultiplied by the orthogonal symplectic transformation
          which reorders X. The leading M columns of U form an
          orthonormal basis for the specified invariant subspace.
          If COMPU = 'N', this array is not referenced.

  LDU1    INTEGER
          The leading dimension of the array U1.
          LDU1 >= MAX(1,N),  if COMPU = 'U';
          LDU1 >= 1,         otherwise.

  U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
          On entry, if COMPU = 'U', the leading N-by-N part of this
          array must contain U2, the (1,2) block of an orthogonal
          symplectic matrix U = [ U1, U2; -U2, U1 ].
          On exit, if COMPU = 'U', the leading N-by-N part of this
          array contains the (1,2) block of the matrix U,
          postmultiplied by the orthogonal symplectic transformation
          which reorders X.
          If COMPU = 'N', this array is not referenced.

  LDU2    INTEGER
          The leading dimension of the array U2.
          LDU2 >= MAX(1,N),  if COMPU = 'U';
          LDU2 >= 1,         otherwise.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          The real and imaginary parts, respectively, of the
          reordered eigenvalues of A. The eigenvalues are stored
          in the same order as on the diagonal of A, with
          WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal
          block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an
          eigenvalue is sufficiently ill-conditioned, then its value
          may differ significantly from its value before reordering.

  M       (output) INTEGER
          The dimension of the specified invariant subspace.
          0 <= M <= N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -18,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
          = 1:  reordering of X failed because some eigenvalue pairs
                are too close to separate (the problem is very
                ill-conditioned); X may have been partially
                reordered, and WR and WI contain the eigenvalues in
                the same order as in X.
References 
  [1] Bai, Z. and Demmel, J.W.
      On Swapping Diagonal Blocks in Real Schur Form.
      Linear Algebra Appl., 186, pp. 73-95, 1993.

  [2] Benner, P., Kressner, D., and Mehrmann, V.
      Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory,
      Algorithms and Applications. Techn. Report, TU Berlin, 2003.
Further Comments 
  None
Example

Program Text 

*     MB03TD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDG, LDRES, LDU1, LDU2, LDWORK
      PARAMETER        ( LDA  = NMAX, LDG  = NMAX, LDRES  = NMAX,
     $                   LDU1 = NMAX, LDU2 = NMAX, LDWORK = 8*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      COMPU, TYP
      INTEGER          I, INFO, J, N, M
*     .. Local Arrays ..
      LOGICAL          LOWER(NMAX), SELECT(NMAX)
      DOUBLE PRECISION A(LDA, NMAX), DWORK(LDWORK), G(LDG, NMAX),
     $                 RES(LDRES,NMAX), U1(LDU1,NMAX), U2(LDU2,NMAX),
     $                 WR(NMAX), WI(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION MA02JD
      EXTERNAL         LSAME, MA02JD
*     .. External Subroutines ..
      EXTERNAL         MB03TD
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, TYP, COMPU
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( SELECT(J), J = 1,N )
         READ ( NIN, FMT = * ) ( LOWER(J), J = 1,N )
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( COMPU, 'U' ) ) THEN
            READ ( NIN, FMT = * ) ( ( U1(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( U2(I,J), J = 1,N ), I = 1,N )
         END IF
         CALL MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, U1,
     $                LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( COMPU, 'U' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 10  I = 1, N
                  WRITE ( NOUT, FMT = 99994 )
     $                  ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N )
10             CONTINUE
               DO 20  I = 1, N
                  WRITE ( NOUT, FMT = 99994 )
     $                  ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N )
20             CONTINUE
               WRITE ( NOUT, FMT = 99992 ) MA02JD( .FALSE., .FALSE., N,
     $                 U1, LDU1, U2, LDU2, RES, LDRES )
            END IF
*
            WRITE ( NOUT, FMT = 99996 )
            DO 30  I = 1, N
               WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N )
30          CONTINUE
*
            WRITE ( NOUT, FMT = 99995 )
            IF ( LSAME( TYP, 'S' ) ) THEN
               DO 40  I = 1, N
                  WRITE ( NOUT, FMT = 99994 )
     $               ( -G(J,I), J = 1,I-1 ), ZERO, ( G(I,J), J = I+1,N )
40             CONTINUE
            ELSE
               DO 50  I = 1, N
                  WRITE ( NOUT, FMT = 99994 )
     $               ( G(J,I), J = 1,I-1 ), ( G(I,J), J = I,N )
50             CONTINUE
           END IF
         END IF
      END IF
*
99999 FORMAT (' MB03TD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03TD = ',I2)
99997 FORMAT (' The orthogonal symplectic factor U is ')
99996 FORMAT (/' The matrix A in reordered Schur canonical form is ')
99995 FORMAT (/' The matrix G is ')
99994 FORMAT (20(1X,F9.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2)
      END
Program Data 
MB03TD EXAMPLE PROGRAM DATA
	5	S	U
	.F. .T. .T. .F. .F.
	.F. .T. .T. .F. .F.
    0.9501    0.7621    0.6154    0.4057    0.0579
         0    0.4565    0.7919    0.9355    0.3529
         0   -0.6822    0.4565    0.9169    0.8132
         0         0         0    0.4103    0.0099
         0         0         0         0    0.1389
         0   -0.1834   -0.1851    0.5659    0.3040
         0         0    0.4011   -0.9122    0.2435
         0         0         0    0.4786   -0.2432
         0         0         0         0   -0.5272
         0         0         0         0         0
     1     0     0     0     0
     0     1     0     0     0
     0     0     1     0     0
     0     0     0     1     0
     0     0     0     0     1
     0     0     0     0     0
     0     0     0     0     0
     0     0     0     0     0
     0     0     0     0     0
     0     0     0     0     0
Program Results 
MB03TD EXAMPLE PROGRAM RESULTS

The orthogonal symplectic factor U is 
   0.0407    0.4847    0.8737    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000
   0.1245   -0.3866    0.2087    0.4509   -0.1047    0.3229    0.1248   -0.0843    0.1967    0.6415
  -0.0933    0.4089   -0.2225   -0.4085    0.0709   -0.2171    0.2156   -0.1095    0.4348    0.5551
  -0.1059   -0.5250    0.2962   -0.0295    0.2207   -0.6789    0.1133   -0.0312    0.2979   -0.1112
   0.3937    0.3071   -0.1887    0.5332   -0.4351   -0.4423    0.0600   -0.0127    0.1679   -0.1179
   0.0000    0.0000    0.0000    0.0000    0.0000    0.0407    0.4847    0.8737    0.0000    0.0000
  -0.3229   -0.1248    0.0843   -0.1967   -0.6415    0.1245   -0.3866    0.2087    0.4509   -0.1047
   0.2171   -0.2156    0.1095   -0.4348   -0.5551   -0.0933    0.4089   -0.2225   -0.4085    0.0709
   0.6789   -0.1133    0.0312   -0.2979    0.1112   -0.1059   -0.5250    0.2962   -0.0295    0.2207
   0.4423   -0.0600    0.0127   -0.1679    0.1179    0.3937    0.3071   -0.1887    0.5332   -0.4351

Orthogonality of U: || U'*U - I ||_F = .21E-14

The matrix A in reordered Schur canonical form is 
   0.4565   -0.4554    0.2756   -0.8651   -1.2050
   1.1863    0.4565    0.2186   -0.0233    0.8293
   0.0000    0.0000    0.9501    0.0625   -0.0064
   0.0000    0.0000    0.0000    0.4103    0.5597
   0.0000    0.0000    0.0000    0.0000    0.1389

The matrix G is 
   0.0000    0.3298   -0.0292   -0.1571    0.1751
  -0.3298    0.0000   -0.0633   -0.2951    0.2396
   0.0292    0.0633    0.0000    0.9567    0.7485
   0.1571    0.2951   -0.9567    0.0000    0.2960
  -0.1751   -0.2396   -0.7485   -0.2960    0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03TS.html000077500000000000000000000143141201767322700161170ustar00rootroot00000000000000 MB03TS - SLICOT Library Routine Documentation

MB03TS

Swapping two diagonal blocks of a matrix in (skew-)Hamiltonian canonical Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To swap diagonal blocks A11 and A22 of order 1 or 2 in the upper
  quasi-triangular matrix A contained in a skew-Hamiltonian matrix

                [  A   G  ]          T
          X  =  [       T ],   G = -G,
                [  0   A  ]

  or in a Hamiltonian matrix

                [  A   G  ]          T
          X  =  [       T ],   G =  G.
                [  0  -A  ]

  This routine is a modified version of the LAPACK subroutine
  DLAEX2.

  The matrix A must be in Schur canonical form (as returned by the
  LAPACK routine DHSEQR), that is, block upper triangular with
  1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
  its diagonal elements equal and its off-diagonal elements of
  opposite sign.
Specification 
      SUBROUTINE MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, LDU1, U2,
     $                   LDU2, J1, N1, N2, DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  ISHAM   LOGIGAL
          Specifies the type of X:
          = .TRUE.:   X is a Hamiltonian matrix;
          = .FALSE.:  X is a skew-Hamiltonian matrix.

  WANTU   LOGIGAL
          = .TRUE.:   update the matrices U1 and U2 containing the
                      Schur vectors;
          = .FALSE.:  do not update U1 and U2.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the upper quasi-triangular matrix A, in Schur
          canonical form.
          On exit, the leading N-by-N part of this array contains
          the reordered matrix A, again in Schur canonical form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, the leading N-by-N part of this array must
          contain the upper triangular part of the symmetric
          matrix G, if ISHAM = .TRUE., or the strictly upper
          triangular part of the skew-symmetric matrix G, otherwise.
          The rest of this array is not referenced.
          On exit, the leading N-by-N part of this array contains
          the upper or strictly upper triangular part of the
          symmetric or skew-symmetric matrix G, respectively,
          updated by the orthogonal transformation which reorders A.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,N).

  U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
          On entry, if WANTU = .TRUE., the leading N-by-N part of
          this array must contain the matrix U1.
          On exit, if WANTU = .TRUE., the leading N-by-N part of
          this array contains U1, postmultiplied by the orthogonal
          transformation which reorders A. See the description in
          the SLICOT subroutine MB03TD for further details.
          If WANTU = .FALSE., this array is not referenced.

  LDU1    INTEGER
          The leading dimension of the array U1.
          LDU1 >= MAX(1,N),  if WANTU = .TRUE.;
          LDU1 >= 1,         otherwise.

  U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
          On entry, if WANTU = .TRUE., the leading N-by-N part of
          this array must contain the matrix U2.
          On exit, if WANTU = .TRUE., the leading N-by-N part of
          this array contains U2, postmultiplied by the orthogonal
          transformation which reorders A.
          If WANTU = .FALSE., this array is not referenced.

  LDU2    INTEGER
          The leading dimension of the array U2.
          LDU2 >= MAX(1,N),  if WANTU = .TRUE.;
          LDU2 >= 1,         otherwise.

  J1      (input) INTEGER
          The index of the first row of the first block A11.
          If J1+N1 < N, then A11 is swapped with the block starting
          at (J1+N1+1)-th diagonal element.
          If J1+N1 > N, then A11 is the last block in A and swapped
          with -A11', if ISHAM = .TRUE.,
          or    A11', if ISHAM = .FALSE..

  N1      (input) INTEGER
          The order of the first block A11. N1 = 0, 1 or 2.

  N2      (input) INTEGER
          The order of the second block A22. N2 = 0, 1 or 2.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  the transformed matrix A would be too far from Schur
                form; the blocks are not swapped and A, G, U1 and
                U2 are unchanged.
References 
  [1] Bai, Z., and Demmel, J.W.
     On swapping diagonal blocks in real Schur form.
     Linear Algebra Appl., 186, pp. 73-95, 1993.

  [2] Benner, P., Kressner, D., and Mehrmann, V.
      Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory,
      Algorithms and Applications. Techn. Report, TU Berlin, 2003.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03UD.html000077500000000000000000000202231201767322700160750ustar00rootroot00000000000000 MB03UD - SLICOT Library Routine Documentation

MB03UD

Computation of the singular value decomposition of a real upper triangular matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute all, or part, of the singular value decomposition of a
  real upper triangular matrix.

  The N-by-N upper triangular matrix A is factored as  A = Q*S*P',
  where Q and P are N-by-N orthogonal matrices and S is an
  N-by-N diagonal matrix with non-negative diagonal elements,
  SV(1), SV(2), ..., SV(N), ordered such that

     SV(1) >= SV(2) >= ... >= SV(N) >= 0.

  The columns of Q are the left singular vectors of A, the diagonal
  elements of S are the singular values of A and the columns of P
  are the right singular vectors of A.

  Either or both of Q and P' may be requested.
  When P' is computed, it is returned in A.
Specification 
      SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         JOBP, JOBQ
      INTEGER           INFO, LDA, LDQ, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), Q(LDQ,*), SV(*)
Arguments

Mode Parameters 

  JOBQ    CHARACTER*1
          Specifies whether the user wishes to compute the matrix Q
          of left singular vectors as follows:
          = 'V':  Left singular vectors are computed;
          = 'N':  No left singular vectors are computed.

  JOBP    CHARACTER*1
          Specifies whether the user wishes to compute the matrix P'
          of right singular vectors as follows:
          = 'V':  Right singular vectors are computed;
          = 'N':  No right singular vectors are computed.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the upper triangular matrix A.
          On exit, if JOBP = 'V', the leading N-by-N part of this
          array contains the N-by-N orthogonal matrix  P'; otherwise
          the N-by-N upper triangular part of A is used as internal
          workspace. The strictly lower triangular part of A is set
          internally to zero before the reduction to bidiagonal form
          is performed.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
          If JOBQ = 'V', the leading N-by-N part of this array
          contains the orthogonal matrix Q.
          If JOBQ = 'N', Q is not referenced.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,  and when JOBQ = 'V',  LDQ >= MAX(1,N).

  SV      (output) DOUBLE PRECISION array, dimension (N)
          The N singular values of the matrix A, sorted in
          descending order.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK;
          if INFO > 0, DWORK(2:N) contains the unconverged
          superdiagonal elements of an upper bidiagonal matrix B
          whose diagonal is in SV (not necessarily sorted).
          B satisfies A = Q*B*P', so it has the same singular
          values as A, and singular vectors related by Q and P'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,5*N).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  the QR algorithm has failed to converge. In this
                case INFO specifies how many superdiagonals did not
                converge (see the description of DWORK).
                This failure is not likely to occur.
Method 
  The routine reduces A to bidiagonal form by means of elementary
  reflectors and then uses the QR algorithm on the bidiagonal form.
Further Comments 
  None
Example

Program Text 

*     MB03UD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 10 )
      INTEGER          LDA, LDQ
      PARAMETER        ( LDA = NMAX, LDQ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, 5*NMAX ) )
*     .. Local Scalars ..
      CHARACTER*1      JOBQ, JOBP
      INTEGER          I, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), Q(LDQ,NMAX),
     $                 SV(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
*     .. External Subroutines ..
      EXTERNAL         MB03UD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOBQ, JOBP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Compute the singular values and vectors.
         CALL MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK,
     $                LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99995 ) ( SV(I), I = 1,N )
            IF ( LSAME( JOBP, 'V' ) ) THEN
               WRITE ( NOUT, FMT = 99996 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10          CONTINUE
            END IF
            IF ( LSAME( JOBQ, 'V' ) ) THEN
               WRITE ( NOUT, FMT = 99994 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N )
   20          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03UD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03UD = ',I2)
99997 FORMAT (' Singular values are ',I5)
99996 FORMAT (/' The transpose of the right singular vectors matrix is '
     $       )
99995 FORMAT (8X,20(1X,F8.4))
99994 FORMAT (/' The left singular vectors matrix is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB03UD EXAMPLE PROGRAM DATA
   4     V      V
  -1.0  37.0 -12.0 -12.0
   0.0 -10.0   0.0   4.0
   0.0   0.0   7.0  -6.0
   0.0   0.0   0.0  -9.0
Program Results 
 MB03UD EXAMPLE PROGRAM RESULTS

 Singular values are 
          42.0909  11.7764   5.4420   0.2336

 The transpose of the right singular vectors matrix is 
           0.0230  -0.9084   0.2759   0.3132
           0.0075  -0.1272   0.5312  -0.8376
           0.0092   0.3978   0.8009   0.4476
           0.9997   0.0182  -0.0177  -0.0050

 The left singular vectors matrix is 
          -0.9671  -0.0882  -0.0501  -0.2335
           0.2456  -0.1765  -0.4020  -0.8643
           0.0012   0.7425   0.5367  -0.4008
          -0.0670   0.6401  -0.7402   0.1945

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03VD.html000077500000000000000000000325551201767322700161110ustar00rootroot00000000000000 MB03VD - SLICOT Library Routine Documentation

MB03VD

Periodic Hessenberg form of a product of p matrices using orthogonal similarity transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce a product of p real general matrices A = A_1*A_2*...*A_p
  to upper Hessenberg form, H = H_1*H_2*...*H_p, where H_1 is
  upper Hessenberg, and H_2, ..., H_p are upper triangular, by using
  orthogonal similarity transformations on A,

          Q_1' * A_1 * Q_2 = H_1,
          Q_2' * A_2 * Q_3 = H_2,
                 ...
          Q_p' * A_p * Q_1 = H_p.
Specification 
      SUBROUTINE MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU,
     $                   DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           IHI, ILO, INFO, LDA1, LDA2, LDTAU, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the square matrices A_1, A_2, ..., A_p.
          N >= 0.

  P       (input) INTEGER
          The number of matrices in the product A_1*A_2*...*A_p.
          P >= 1.

  ILO     (input) INTEGER
  IHI     (input) INTEGER
          It is assumed that all matrices A_j, j = 2, ..., p, are
          already upper triangular in rows and columns 1:ILO-1 and
          IHI+1:N, and A_1 is upper Hessenberg in rows and columns
          1:ILO-1 and IHI+1:N, with A_1(ILO,ILO-1) = 0 (unless
          ILO = 1), and A_1(IHI+1,IHI) = 0 (unless IHI = N).
          If this is not the case, ILO and IHI should be set to 1
          and N, respectively.
          1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N.

  A       (input/output) DOUBLE PRECISION array, dimension
          (LDA1,LDA2,P)
          On entry, the leading N-by-N-by-P part of this array must
          contain the matrices of factors to be reduced;
          specifically, A(*,*,j) must contain A_j, j = 1, ..., p.
          On exit, the leading N-by-N upper triangle and the first
          subdiagonal of A(*,*,1) contain the upper Hessenberg
          matrix H_1, and the elements below the first subdiagonal,
          with the first column of the array TAU represent the
          orthogonal matrix Q_1 as a product of elementary
          reflectors. See FURTHER COMMENTS.
          For j > 1, the leading N-by-N upper triangle of A(*,*,j)
          contains the upper triangular matrix H_j, and the elements
          below the diagonal, with the j-th column of the array TAU
          represent the orthogonal matrix Q_j as a product of
          elementary reflectors. See FURTHER COMMENTS.

  LDA1    INTEGER
          The first leading dimension of the array A.
          LDA1 >= max(1,N).

  LDA2    INTEGER
          The second leading dimension of the array A.
          LDA2 >= max(1,N).

  TAU     (output) DOUBLE PRECISION array, dimension (LDTAU,P)
          The leading N-1 elements in the j-th column contain the
          scalar factors of the elementary reflectors used to form
          the matrix Q_j, j = 1, ..., P. See FURTHER COMMENTS.

  LDTAU   INTEGER
          The leading dimension of the array TAU.
          LDTAU >= max(1,N-1).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The algorithm consists in ihi-ilo major steps. In each such
  step i, ilo <= i <= ihi-1, the subdiagonal elements in the i-th
  column of A_j are annihilated using a Householder transformation
  from the left, which is also applied to A_(j-1) from the right,
  for j = p:-1:2. Then, the elements below the subdiagonal of the
  i-th column of A_1 are annihilated, and the Householder
  transformation is also applied to A_p from the right.
  See FURTHER COMMENTS.
References 
  [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P.
      The periodic Schur decomposition: algorithms and applications.
      Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
      1992.

  [2] Sreedhar, J. and Van Dooren, P.
      Periodic Schur form and some matrix equations.
      Proc. of the Symposium on the Mathematical Theory of Networks
      and Systems (MTNS'93), Regensburg, Germany (U. Helmke,
      R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994.
Numerical Aspects 
  The algorithm is numerically stable.
Further Comments 
  Each matrix Q_j is represented as a product of (ihi-ilo)
  elementary reflectors,

     Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1).

  Each H_j(i), i = ilo, ..., ihi-1, has the form

     H_j(i) = I - tau_j * v_j * v_j',

  where tau_j is a real scalar, and v_j is a real vector with
  v_j(1:i) = 0, v_j(i+1) = 1 and v_j(ihi+1:n) = 0; v_j(i+2:ihi)
  is stored on exit in A_j(i+2:ihi,i), and tau_j in TAU(i,j).

  The contents of A_1 are illustrated by the following example
  for n = 7, ilo = 2, and ihi = 6:

  on entry                         on exit

  ( a   a   a   a   a   a   a )    ( a   h   h   h   h   h   a )
  ( 0   a   a   a   a   a   a )    ( 0   h   h   h   h   h   a )
  ( 0   a   a   a   a   a   a )    ( 0   h   h   h   h   h   h )
  ( 0   a   a   a   a   a   a )    ( 0   v2  h   h   h   h   h )
  ( 0   a   a   a   a   a   a )    ( 0   v2  v3  h   h   h   h )
  ( 0   a   a   a   a   a   a )    ( 0   v2  v3  v4  h   h   h )
  ( 0   0   0   0   0   0   a )    ( 0   0   0   0   0   0   a )

  where a denotes an element of the original matrix A_1, h denotes
  a modified element of the upper Hessenberg matrix H_1, and vi
  denotes an element of the vector defining H_1(i).

  The contents of A_j, j > 1, are illustrated by the following
  example for n = 7, ilo = 2, and ihi = 6:

  on entry                         on exit

  ( a   a   a   a   a   a   a )    ( a   h   h   h   h   h   a )
  ( 0   a   a   a   a   a   a )    ( 0   h   h   h   h   h   h )
  ( 0   a   a   a   a   a   a )    ( 0   v2  h   h   h   h   h )
  ( 0   a   a   a   a   a   a )    ( 0   v2  v3  h   h   h   h )
  ( 0   a   a   a   a   a   a )    ( 0   v2  v3  v4  h   h   h )
  ( 0   a   a   a   a   a   a )    ( 0   v2  v3  v4  v5  h   h )
  ( 0   0   0   0   0   0   a )    ( 0   0   0   0   0   0   a )

  where a denotes an element of the original matrix A_j, h denotes
  a modified element of the upper triangular matrix H_j, and vi
  denotes an element of the vector defining H_j(i). (The element
  (1,2) in A_p is also unchanged for this example.)

  Note that for P = 1, the LAPACK Library routine DGEHRD could be
  more efficient on some computer architectures than this routine
  (a BLAS 2 version).
Example

Program Text 

*     MB03VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, PMAX
      PARAMETER        ( NMAX = 20, PMAX = 20 )
      INTEGER          LDA1, LDA2, LDQ1, LDQ2, LDTAU
      PARAMETER        ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX,
     $                   LDQ2 = NMAX, LDTAU = NMAX-1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION SSQ
      INTEGER          I, IHI, ILO, INFO, J, K, KP1, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA1,LDA2,PMAX), AS(LDA1,LDA2,PMAX),
     $                 DWORK(LDWORK), Q(LDQ1,LDQ2,PMAX),
     $                 QTA(LDQ1,NMAX), TAU(LDTAU,PMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANGE, DLAPY2
      EXTERNAL         DLANGE, DLAPY2
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DLASET, MB03VD, MB03VY
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     .. Executable Statements ..
      WRITE (NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, P, ILO, IHI
      IF ( N.LT.0 .OR. N.GT.MIN( LDA1, LDA2 ) ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99990 ) P
         ELSE
*           Read matrices A_1, ..., A_p from the input file.
            DO 10 K = 1, P
               READ ( NIN, FMT = * )
     $            ( ( A(I,J,K), J = 1, N ), I = 1, N )
               CALL DLACPY( 'F', N, N, A(1,1,K), LDA1, AS(1,1,K), LDA1 )
   10       CONTINUE
*           Reduce to the periodic Hessenberg form.
            CALL MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU,
     $                   DWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99996 )
               DO 30 K = 1, P
                  CALL DLACPY( 'L', N, N, A(1,1,K), LDA1, Q(1,1,K),
     $                         LDQ1 )
                  IF ( N.GT.1 ) THEN
                     IF ( N.GT.2 .AND. K.EQ.1 ) THEN
                        CALL DLASET( 'L', N-2, N-2, ZERO, ZERO,
     $                               A(3,1,K), LDA1 )
                     ELSE IF ( K.GT.1 ) THEN
                        CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
     $                               A(2,1,K), LDA1 )
                     END IF
                  END IF
                  WRITE ( NOUT, FMT = 99995 ) K
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( A(I,J,K), J = 1, N )
   20             CONTINUE
   30          CONTINUE
*              Accumulate the transformations.
               CALL MB03VY( N, P, ILO, IHI, Q, LDQ1, LDQ2, TAU, LDTAU,
     $                      DWORK, LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 50 K = 1, P
                     WRITE ( NOUT, FMT = 99995 ) K
                     DO 40 I = 1, N
                        WRITE ( NOUT, FMT = 99994 )
     $                        ( Q(I,J,K), J = 1, N )
   40                CONTINUE
   50             CONTINUE
*                 Compute error.
                  SSQ = ZERO
                  DO 60 K = 1, P
                     KP1 = K+1
                     IF( KP1.GT.P ) KP1 = 1
*                    Compute NORM (Z' * A * Z - Aout)
                     CALL DGEMM( 'T', 'N', N, N, N, ONE, Q(1,1,K), LDQ1,
     $                           AS(1,1,K), LDA1, ZERO, QTA, LDQ1 )
                     CALL DGEMM( 'N', 'N', N, N, N, ONE, QTA, LDQ1,
     $                           Q(1,1,KP1), LDQ1, -ONE, A(1,1,K),
     $                           LDA1 )
                     SSQ = DLAPY2( SSQ,
     $                             DLANGE( 'Frobenius', N, N, A(1,1,K),
     $                                     LDA1, DWORK ) )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99992 ) SSQ
               END IF
            END IF
         END IF
      END IF
      STOP
99999 FORMAT (' MB03VD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from MB03VD = ', I2)
99997 FORMAT (' INFO on exit from MB03VY = ', I2)
99996 FORMAT (' Reduced matrices')
99995 FORMAT (/' K = ', I5)
99994 FORMAT (8F8.4)
99993 FORMAT (/' Transformation matrices')
99992 FORMAT (/,' NORM (Q''*A*Q - Aout) = ', 1PD12.5)
99991 FORMAT (/, ' N is out of range.',/' N = ', I5)
99990 FORMAT (/, ' P is out of range.',/' P = ', I5)
      END
Program Data 
MB03VD EXAMPLE PROGRAM DATA
4 2 1 4
1.5 -.7 3.5 -.7 
1.  0.  2.  3. 
1.5 -.7 2.5 -.3 
1.  0.  2.  1. 
1.5 -.7 3.5 -.7 
1.  0.  2.  3. 
1.5 -.7 2.5 -.3 
1.  0.  2.  1.
Program Results 
 MB03VD EXAMPLE PROGRAM RESULTS

 Reduced matrices

 K =     1
 -2.3926  2.7042 -0.9598 -1.2335
  4.1417 -1.7046  1.3001 -1.3120
  0.0000 -1.6247 -0.2534  1.6453
  0.0000  0.0000 -0.0169 -0.4451

 K =     2
 -2.5495  2.3402  4.7021  0.2329
  0.0000  1.9725 -0.2483 -2.3493
  0.0000  0.0000 -0.6290 -0.5975
  0.0000  0.0000  0.0000 -0.4426

 Transformation matrices

 K =     1
  1.0000  0.0000  0.0000  0.0000
  0.0000 -0.7103  0.5504 -0.4388
  0.0000 -0.4735 -0.8349 -0.2807
  0.0000 -0.5209  0.0084  0.8536

 K =     2
 -0.5883  0.2947  0.7528 -0.0145
 -0.3922 -0.8070  0.0009 -0.4415
 -0.5883  0.4292 -0.6329 -0.2630
 -0.3922 -0.2788 -0.1809  0.8577

 NORM (Q'*A*Q - Aout) =  2.93760D-15

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03VY.html000077500000000000000000000110241201767322700161220ustar00rootroot00000000000000 MB03VY - SLICOT Library Routine Documentation

MB03VY

Orthogonal matrices for reduction to periodic Hessenberg form of a product of matrices

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate the real orthogonal matrices Q_1, Q_2, ..., Q_p,
  which are defined as the product of ihi-ilo elementary reflectors
  of order n, as returned by SLICOT Library routine MB03VD:

     Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1).
Specification 
      SUBROUTINE MB03VY( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           IHI, ILO, INFO, LDA1, LDA2, LDTAU, LDWORK, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrices Q_1, Q_2, ..., Q_p.  N >= 0.

  P       (input) INTEGER
          The number p of transformation matrices.  P >= 1.

  ILO     (input) INTEGER
  IHI     (input) INTEGER
          The values of the indices ilo and ihi, respectively, used
          in the previous call of the SLICOT Library routine MB03VD.
          1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N.

  A       (input/output) DOUBLE PRECISION array, dimension
          (LDA1,LDA2,N)
          On entry, the leading N-by-N strictly lower triangular
          part of A(*,*,j) must contain the vectors which define the
          elementary reflectors used for reducing A_j, as returned
          by SLICOT Library routine MB03VD, j = 1, ..., p.
          On exit, the leading N-by-N part of A(*,*,j) contains the
          N-by-N orthogonal matrix Q_j, j = 1, ..., p.

  LDA1    INTEGER
          The first leading dimension of the array A.
          LDA1 >= max(1,N).

  LDA2    INTEGER
          The second leading dimension of the array A.
          LDA2 >= max(1,N).

  TAU     (input) DOUBLE PRECISION array, dimension (LDTAU,P)
          The leading N-1 elements in the j-th column must contain
          the scalar factors of the elementary reflectors used to
          form the matrix Q_j, as returned by SLICOT Library routine
          MB03VD.

  LDTAU   INTEGER
          The leading dimension of the array TAU.
          LDTAU >= max(1,N-1).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Each matrix Q_j is generated as the product of the elementary
  reflectors used for reducing A_j. Standard LAPACK routines for
  Hessenberg and QR decompositions are used.
References 
  [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P.
      The periodic Schur decomposition: algorithms and applications.
      Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
      1992.

  [2] Sreedhar, J. and Van Dooren, P.
      Periodic Schur form and some matrix equations.
      Proc. of the Symposium on the Mathematical Theory of Networks
      and Systems (MTNS'93), Regensburg, Germany (U. Helmke,
      R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994.
Numerical Aspects 
  The algorithm is numerically stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03WA.html000077500000000000000000000134251201767322700161020ustar00rootroot00000000000000 MB03WA - SLICOT Library Routine Documentation

MB03WA

Swapping two adjacent diagonal blocks in a periodic real Schur canonical form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To swap adjacent diagonal blocks A11*B11 and A22*B22 of size
  1-by-1 or 2-by-2 in an upper (quasi) triangular matrix product
  A*B by an orthogonal equivalence transformation.

  (A, B) must be in periodic real Schur canonical form (as returned
  by SLICOT Library routine MB03XP), i.e., A is block upper
  triangular with 1-by-1 and 2-by-2 diagonal blocks, and B is upper
  triangular.

  Optionally, the matrices Q and Z of generalized Schur vectors are
  updated.

      Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)',
      Z(in) * B(in) * Q(in)' = Z(out) * B(out) * Q(out)'.

  This routine is largely based on the LAPACK routine DTGEX2
  developed by Bo Kagstrom and Peter Poromaa.
Specification 
      SUBROUTINE MB03WA( WANTQ, WANTZ, N1, N2, A, LDA, B, LDB, Q, LDQ,
     $                   Z, LDZ, INFO )
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,*)
Arguments

Mode Parameters 

  WANTQ   LOGICAL
          Indicates whether or not the user wishes to accumulate
          the matrix Q as follows:
          = .TRUE. :  The matrix Q is updated;
          = .FALSE.:  the matrix Q is not required.

  WANTZ   LOGICAL
          Indicates whether or not the user wishes to accumulate
          the matrix Z as follows:
          = .TRUE. :  The matrix Z is updated;
          = .FALSE.:  the matrix Z is not required.
Input/Output Parameters 
  N1      (input) INTEGER
          The order of the first block A11*B11. N1 = 0, 1 or 2.

  N2      (input) INTEGER
          The order of the second block A22*B22. N2 = 0, 1 or 2.

  A       (input/output) DOUBLE PRECISION array, dimension
          (LDA,N1+N2)
          On entry, the leading (N1+N2)-by-(N1+N2) part of this
          array must contain the matrix A.
          On exit, the leading (N1+N2)-by-(N1+N2) part of this array
          contains the matrix A of the reordered pair.

  LDA     INTEGER
          The leading dimension of the array A. LDA >= MAX(1,N1+N2).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,N1+N2)
          On entry, the leading (N1+N2)-by-(N1+N2) part of this
          array must contain the matrix B.
          On exit, the leading (N1+N2)-by-(N1+N2) part of this array
          contains the matrix B of the reordered pair.

  LDB     INTEGER
          The leading dimension of the array B. LDB >= MAX(1,N1+N2).

  Q       (input/output) DOUBLE PRECISION array, dimension
          (LDQ,N1+N2)
          On entry, if WANTQ = .TRUE., the leading
          (N1+N2)-by-(N1+N2) part of this array must contain the
          orthogonal matrix Q.
          On exit, the leading (N1+N2)-by-(N1+N2) part of this array
          contains the updated matrix Q. Q will be a rotation
          matrix for N1=N2=1.
          This array is not referenced if WANTQ = .FALSE..

  LDQ     INTEGER
          The leading dimension of the array Q. LDQ >= 1.
          If WANTQ = .TRUE., LDQ >= N1+N2.

  Z       (input/output) DOUBLE PRECISION array, dimension
          (LDZ,N1+N2)
          On entry, if WANTZ = .TRUE., the leading
          (N1+N2)-by-(N1+N2) part of this array must contain the
          orthogonal matrix Z.
          On exit, the leading (N1+N2)-by-(N1+N2) part of this array
          contains the updated matrix Z. Z will be a rotation
          matrix for N1=N2=1.
          This array is not referenced if WANTZ = .FALSE..

  LDZ     INTEGER
          The leading dimension of the array Z. LDZ >= 1.
          If WANTZ = .TRUE., LDZ >= N1+N2.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  the transformed matrix (A, B) would be
                too far from periodic Schur form; the blocks are
                not swapped and (A,B) and (Q,Z) are unchanged.
Method 
  In the current code both weak and strong stability tests are
  performed. The user can omit the strong stability test by changing
  the internal logical parameter WANDS to .FALSE.. See ref. [2] for
  details.
References 
  [1] Kagstrom, B.
      A direct method for reordering eigenvalues in the generalized
      real Schur form of a regular matrix pair (A,B), in M.S. Moonen
      et al (eds.), Linear Algebra for Large Scale and Real-Time
      Applications, Kluwer Academic Publ., 1993, pp. 195-218.

  [2] Kagstrom, B., and Poromaa, P.
      Computing eigenspaces with specified eigenvalues of a regular
      matrix pair (A, B) and condition estimation: Theory,
      algorithms and software, Numer. Algorithms, 1996, vol. 12,
      pp. 369-407.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03WD.html000077500000000000000000000407221201767322700161050ustar00rootroot00000000000000 MB03WD - SLICOT Library Routine Documentation

MB03WD

Schur decomposition and eigenvalues of a product of matrices in periodic Hessenberg form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Schur decomposition and the eigenvalues of a
  product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper
  Hessenberg matrix and H_2, ..., H_p upper triangular matrices,
  without evaluating the product. Specifically, the matrices Z_i
  are computed, such that

          Z_1' * H_1 * Z_2 = T_1,
          Z_2' * H_2 * Z_3 = T_2,
                 ...
          Z_p' * H_p * Z_1 = T_p,

  where T_1 is in real Schur form, and T_2, ..., T_p are upper
  triangular.

  The routine works primarily with the Hessenberg and triangular
  submatrices in rows and columns ILO to IHI, but optionally applies
  the transformations to all the rows and columns of the matrices
  H_i, i = 1,...,p. The transformations can be optionally
  accumulated.
Specification 
      SUBROUTINE MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, IHIZ, H,
     $                   LDH1, LDH2, Z, LDZ1, LDZ2, WR, WI, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         COMPZ, JOB
      INTEGER           IHI, IHIZ, ILO, ILOZ, INFO, LDH1, LDH2, LDWORK,
     $                  LDZ1, LDZ2, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK( * ), H( LDH1, LDH2, * ), WI( * ),
     $                  WR( * ), Z( LDZ1, LDZ2, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates whether the user wishes to compute the full
          Schur form or the eigenvalues only, as follows:
          = 'E':  Compute the eigenvalues only;
          = 'S':  Compute the factors T_1, ..., T_p of the full
                  Schur form, T = T_1*T_2*...*T_p.

  COMPZ   CHARACTER*1
          Indicates whether or not the user wishes to accumulate
          the matrices Z_1, ..., Z_p, as follows:
          = 'N':  The matrices Z_1, ..., Z_p are not required;
          = 'I':  Z_i is initialized to the unit matrix and the
                  orthogonal transformation matrix Z_i is returned,
                  i = 1, ..., p;
          = 'V':  Z_i must contain an orthogonal matrix Q_i on
                  entry, and the product Q_i*Z_i is returned,
                  i = 1, ..., p.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix H.  N >= 0.

  P       (input) INTEGER
          The number of matrices in the product H_1*H_2*...*H_p.
          P >= 1.

  ILO     (input) INTEGER
  IHI     (input) INTEGER
          It is assumed that all matrices H_j, j = 2, ..., p, are
          already upper triangular in rows and columns 1:ILO-1 and
          IHI+1:N, and H_1 is upper quasi-triangular in rows and
          columns 1:ILO-1 and IHI+1:N, with H_1(ILO,ILO-1) = 0
          (unless ILO = 1), and H_1(IHI+1,IHI) = 0 (unless IHI = N).
          The routine works primarily with the Hessenberg submatrix
          in rows and columns ILO to IHI, but applies the
          transformations to all the rows and columns of the
          matrices H_i, i = 1,...,p, if JOB = 'S'.
          1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N.

  ILOZ    (input) INTEGER
  IHIZ    (input) INTEGER
          Specify the rows of Z to which the transformations must be
          applied if COMPZ = 'I' or COMPZ = 'V'.
          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.

  H       (input/output) DOUBLE PRECISION array, dimension
          (LDH1,LDH2,P)
          On entry, the leading N-by-N part of H(*,*,1) must contain
          the upper Hessenberg matrix H_1 and the leading N-by-N
          part of H(*,*,j) for j > 1 must contain the upper
          triangular matrix H_j, j = 2, ..., p.
          On exit, if JOB = 'S', the leading N-by-N part of H(*,*,1)
          is upper quasi-triangular in rows and columns ILO:IHI,
          with any 2-by-2 diagonal blocks corresponding to a pair of
          complex conjugated eigenvalues, and the leading N-by-N
          part of H(*,*,j) for j > 1 contains the resulting upper
          triangular matrix T_j.
          If JOB = 'E', the contents of H are unspecified on exit.

  LDH1    INTEGER
          The first leading dimension of the array H.
          LDH1 >= max(1,N).

  LDH2    INTEGER
          The second leading dimension of the array H.
          LDH2 >= max(1,N).

  Z       (input/output) DOUBLE PRECISION array, dimension
          (LDZ1,LDZ2,P)
          On entry, if COMPZ = 'V', the leading N-by-N-by-P part of
          this array must contain the current matrix Q of
          transformations accumulated by SLICOT Library routine
          MB03VY.
          If COMPZ = 'I', Z need not be set on entry.
          On exit, if COMPZ = 'V', or COMPZ = 'I', the leading
          N-by-N-by-P part of this array contains the transformation
          matrices which produced the Schur form; the
          transformations are applied only to the submatrices
          Z_j(ILOZ:IHIZ,ILO:IHI), j = 1, ..., P.
          If COMPZ = 'N', Z is not referenced.

  LDZ1    INTEGER
          The first leading dimension of the array Z.
          LDZ1 >= 1,        if COMPZ = 'N';
          LDZ1 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'.

  LDZ2    INTEGER
          The second leading dimension of the array Z.
          LDZ2 >= 1,        if COMPZ = 'N';
          LDZ2 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          The real and imaginary parts, respectively, of the
          computed eigenvalues ILO to IHI are stored in the
          corresponding elements of WR and WI. If two eigenvalues
          are computed as a complex conjugate pair, they are stored
          in consecutive elements of WR and WI, say the i-th and
          (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the
          eigenvalues are stored in the same order as on the
          diagonal of the Schur form returned in H.
Workspace 
  DWORK   DOUBLE PRECISION work array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= IHI-ILO+P-1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, ILO <= i <= IHI, the QR algorithm
                failed to compute all the eigenvalues ILO to IHI
                in a total of 30*(IHI-ILO+1) iterations;
                the elements i+1:IHI of WR and WI contain those
                eigenvalues which have been successfully computed.
Method 
  A refined version of the QR algorithm proposed in [1] and [2] is
  used. The elements of the subdiagonal, diagonal, and the first
  supradiagonal of current principal submatrix of H are computed
  in the process.
References 
  [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P.
      The periodic Schur decomposition: algorithms and applications.
      Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
      1992.

  [2] Sreedhar, J. and Van Dooren, P.
      Periodic Schur form and some matrix equations.
      Proc. of the Symposium on the Mathematical Theory of Networks
      and Systems (MTNS'93), Regensburg, Germany (U. Helmke,
      R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994.
Numerical Aspects 
  The algorithm is numerically stable.
Further Comments 
  Note that for P = 1, the LAPACK Library routine DHSEQR could be
  more efficient on some computer architectures than this routine,
  because DHSEQR uses a block multishift QR algorithm.
  When P is large and JOB = 'S', it could be more efficient to
  compute the product matrix H, and use the LAPACK Library routines.
Example

Program Text 

*     MB03WD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, PMAX
      PARAMETER        ( NMAX = 20, PMAX = 20 )
      INTEGER          LDA1, LDA2, LDTAU, LDZ1, LDZ2, LDZTA
      PARAMETER        ( LDA1 = NMAX, LDA2 = NMAX, LDTAU = NMAX-1,
     $                   LDZ1 = NMAX, LDZ2 = NMAX, LDZTA = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX, NMAX + PMAX - 2 ) )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION SSQ
      INTEGER          I, IHI, IHIZ, ILO, ILOZ, INFO, J, K, KP1, N, P
      CHARACTER        COMPZ, JOB
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA1,LDA2,PMAX), AS(LDA1,LDA2,PMAX),
     $                 DWORK(LDWORK), TAU(LDTAU,PMAX), WI(NMAX),
     $                 WR(NMAX), Z(LDZ1,LDZ2,PMAX), ZTA(LDZTA,NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANGE, DLAPY2
      LOGICAL          LSAME
      EXTERNAL         DLANGE, DLAPY2, LSAME
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, MB03VD, MB03VY, MB03WD, MB03WX
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
      WRITE (NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, P, ILO, IHI, ILOZ, IHIZ, JOB, COMPZ
      IF ( N.LT.0 .OR. N.GT.MIN( LDA1, LDA2 ) ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99987 ) P
         ELSE
*           Read matrices A_1, ..., A_p from the input file.
            DO 10 K = 1, P
               READ ( NIN, FMT = * )
     $            ( ( A(I,J,K), J = 1, N ), I = 1, N )
               CALL DLACPY( 'F', N, N, A(1,1,K), LDA1, AS(1,1,K), LDA1 )
   10       CONTINUE
*           Reduce to the periodic Hessenberg form.
            CALL MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU,
     $                   DWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               IF ( LSAME( COMPZ, 'V' ) ) THEN
                  DO 20 K = 1, P
                     CALL DLACPY( 'L', N, N, A(1,1,K), LDA1, Z(1,1,K),
     $                            LDZ1 )
   20             CONTINUE
*                 Accumulate the transformations.
                  CALL MB03VY( N, P, ILO, IHI, Z, LDZ1, LDZ2, TAU,
     $                         LDTAU, DWORK, LDWORK, INFO )
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99996 ) INFO
                     STOP
                  ELSE
*                    Reduce to the periodic Schur form.
                     CALL MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ,
     $                            IHIZ, A, LDA1, LDA2, Z, LDZ1, LDZ2,
     $                            WR, WI, DWORK, LDWORK, INFO )
                     IF ( INFO.GT.0 ) THEN
                        WRITE ( NOUT, FMT = 99998 ) INFO
                        WRITE ( NOUT, FMT = 99991 )
                        DO 30 I = MAX( ILO, INFO + 1 ), IHI
                           WRITE ( NOUT, FMT = 99990 ) WR(I), WI(I)
   30                   CONTINUE
                        STOP
                     END IF
                     IF ( INFO.LT.0 ) THEN
                        WRITE ( NOUT, FMT = 99998 ) INFO
                     ELSE
*                       Store the isolated eigenvalues.
                        CALL MB03WX( ILO-1, P, A, LDA1, LDA2, WR, WI,
     $                               INFO )
                        IF ( IHI.LT.N )
     $                     CALL MB03WX( N-IHI, P, A(IHI+1,IHI+1,1),
     $                                  LDA1, LDA2, WR(IHI+1),
     $                                  WI(IHI+1), INFO )
                        WRITE ( NOUT, FMT = 99991 )
                        DO 40 I = 1, N
                           WRITE ( NOUT, FMT = 99990 ) WR(I), WI(I)
   40                   CONTINUE
                        WRITE ( NOUT, FMT = 99995 )
                        DO 60 K = 1, P
                           WRITE ( NOUT, FMT = 99994 ) K
                           DO 50 I = 1, N
                              WRITE ( NOUT, FMT = 99993 )
     $                              ( A(I,J,K), J = 1, N )
   50                      CONTINUE
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99992 )
                        DO 80 K = 1, P
                           WRITE ( NOUT, FMT = 99994 ) K
                           DO 70 I = 1, N
                              WRITE ( NOUT, FMT = 99993 )
     $                              ( Z(I,J,K), J = 1, N )
   70                      CONTINUE
   80                   CONTINUE
*                       Compute error.
                        SSQ = ZERO
                        DO 90 K = 1, P
                           KP1 = K+1
                           IF( KP1.GT.P ) KP1 = 1
*                          Compute NORM (Z' * A * Z - Aout)
                           CALL DGEMM( 'T', 'N', N, N, N, ONE, Z(1,1,K),
     $                                 LDZ1, AS(1,1,K), LDA1, ZERO, ZTA,
     $                                 LDZTA )
                           CALL DGEMM( 'N', 'N', N, N, N, ONE, ZTA,
     $                                 LDZTA, Z(1,1,KP1), LDZ1, -ONE,
     $                                 A(1,1,K), LDA1 )
                           SSQ = DLAPY2( SSQ,
     $                                   DLANGE( 'Frobenius', N, N,
     $                                           A(1,1,K), LDA1,
     $                                           DWORK ) )
   90                   CONTINUE
                        WRITE ( NOUT, FMT = 99989 ) SSQ
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
99999 FORMAT (' MB03WD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from MB03WD = ', I2)
99997 FORMAT (' INFO on exit from MB03VD = ', I2)
99996 FORMAT (' INFO on exit from MB03VY = ', I2)
99995 FORMAT (/' Reduced matrices')
99994 FORMAT (/' K = ', I5)
99993 FORMAT (8F8.4)
99992 FORMAT (/' Transformation matrices')
99991 FORMAT ( ' Computed eigenvalues'/)
99990 FORMAT (4X,'( ', F17.6,' ,', F17.6,' )')
99989 FORMAT (/,' NORM (Z''*A*Z - Aout) = ', 1PD12.5)
99988 FORMAT (/, ' N is out of range.',/' N = ', I5)
99987 FORMAT (/, ' P is out of range.',/' P = ', I5)
      END
Program Data 
MB03WD EXAMPLE PROGRAM DATA
4 2 1 4 1 4 S V
1.5 -.7 3.5 -.7 
1.  0.  2.  3. 
1.5 -.7 2.5 -.3 
1.  0.  2.  1. 
1.5 -.7 3.5 -.7 
1.  0.  2.  3. 
1.5 -.7 2.5 -.3 
1.  0.  2.  1.
Program Results 
 MB03WD EXAMPLE PROGRAM RESULTS

 Computed eigenvalues

    (          6.449861 ,         7.817717 )
    (          6.449861 ,        -7.817717 )
    (          0.091315 ,         0.000000 )
    (          0.208964 ,         0.000000 )

 Reduced matrices

 K =     1
  2.2112  4.3718 -2.3362  0.8907
 -0.9179  2.7688 -0.6570 -2.2426
  0.0000  0.0000  0.3022  0.1932
  0.0000  0.0000  0.0000 -0.4571

 K =     2
  2.9169  3.4539  2.2016  1.2367
  0.0000  3.4745  1.0209 -2.0720
  0.0000  0.0000  0.3022 -0.1932
  0.0000  0.0000  0.0000 -0.4571

 Transformation matrices

 K =     1
  0.3493  0.6751 -0.6490  0.0327
  0.7483 -0.4863 -0.1249 -0.4336
  0.2939  0.5504  0.7148 -0.3158
  0.4813 -0.0700  0.2286  0.8433

 K =     2
  0.2372  0.7221  0.6490  0.0327
  0.8163 -0.3608  0.1249 -0.4336
  0.2025  0.5902 -0.7148 -0.3158
  0.4863  0.0076 -0.2286  0.8433

 NORM (Z'*A*Z - Aout) =  7.10254D-15

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03WX.html000077500000000000000000000055241201767322700161320ustar00rootroot00000000000000 MB03WX - SLICOT Library Routine Documentation

MB03WX

Eigenvalues of a product of matrices in periodic Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of a product of matrices,
  T = T_1*T_2*...*T_p, where T_1 is an upper quasi-triangular
  matrix and T_2, ..., T_p are upper triangular matrices.
Specification 
      SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDT1, LDT2, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION T( LDT1, LDT2, * ), WI( * ), WR( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix T.  N >= 0.

  P       (input) INTEGER
          The number of matrices in the product T_1*T_2*...*T_p.
          P >= 1.

  T       (input) DOUBLE PRECISION array, dimension (LDT1,LDT2,P)
          The leading N-by-N part of T(*,*,1) must contain the upper
          quasi-triangular matrix T_1 and the leading N-by-N part of
          T(*,*,j) for j > 1 must contain the upper-triangular
          matrix T_j, j = 2, ..., p.
          The elements below the subdiagonal of T(*,*,1) and below
          the diagonal of T(*,*,j), j = 2, ..., p, are not
          referenced.

  LDT1    INTEGER
          The first leading dimension of the array T.
          LDT1 >= max(1,N).

  LDT2    INTEGER
          The second leading dimension of the array T.
          LDT2 >= max(1,N).

  WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
          The real and imaginary parts, respectively, of the
          eigenvalues of T. The eigenvalues are stored in the same
          order as on the diagonal of T_1. If T(i:i+1,i:i+1,1) is a
          2-by-2 diagonal block with complex conjugated eigenvalues
          then WI(i) > 0 and WI(i+1) = -WI(i).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03XD.html000077500000000000000000000631441201767322700161110ustar00rootroot00000000000000 MB03XD - SLICOT Library Routine Documentation

MB03XD

Computing the eigenvalues of a Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of a Hamiltonian matrix,

                [  A   G  ]         T        T
          H  =  [       T ],   G = G,   Q = Q,                  (1)
                [  Q  -A  ]

  where A, G and Q are real n-by-n matrices.

  Due to the structure of H all eigenvalues appear in pairs
  (lambda,-lambda). This routine computes the eigenvalues of H
  using an algorithm based on the symplectic URV and the periodic
  Schur decompositions as described in [1],

        T       [  T   G  ]
       U H V =  [       T ],                                    (2)
                [  0  -S  ]

  where U and V are 2n-by-2n orthogonal symplectic matrices,
  S is in real Schur form and T is upper triangular.

  The algorithm is backward stable and preserves the eigenvalue
  pairings in finite precision arithmetic.

  Optionally, a symplectic balancing transformation to improve the
  conditioning of eigenvalues is computed (see MB04DD). In this
  case, the matrix H in decomposition (2) must be replaced by the
  balanced matrix.

  The SLICOT Library routine MB03ZD can be used to compute invariant
  subspaces of H from the output of this routine.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  BALANC  CHARACTER*1
          Indicates how H should be diagonally scaled and/or
          permuted to reduce its norm.
          = 'N': Do not diagonally scale or permute;
          = 'P': Perform symplectic permutations to make the matrix
                 closer to Hamiltonian Schur form. Do not diagonally
                 scale;
          = 'S': Diagonally scale the matrix, i.e., replace A, G and
                 Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where
                 D is a diagonal matrix chosen to make the rows and
                 columns of H more equal in norm. Do not permute;
          = 'B': Both diagonally scale and permute A, G and Q.
          Permuting does not change the norm of H, but scaling does.

  JOB     CHARACTER*1
          Indicates whether the user wishes to compute the full
          decomposition (2) or the eigenvalues only, as follows:
          = 'E': compute the eigenvalues only;
          = 'S': compute matrices T and S of (2);
          = 'G': compute matrices T, S and G of (2).

  JOBU    CHARACTER*1
          Indicates whether or not the user wishes to compute the
          orthogonal symplectic matrix U of (2) as follows:
          = 'N': the matrix U is not computed;
          = 'U': the matrix U is computed.

  JOBV    CHARACTER*1
          Indicates whether or not the user wishes to compute the
          orthogonal symplectic matrix V of (2) as follows:
          = 'N': the matrix V is not computed;
          = 'V': the matrix V is computed.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, this array is overwritten. If JOB = 'S' or
          JOB = 'G', the leading N-by-N part of this array contains
          the matrix S in real Schur form of decomposition (2).

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  QG      (input/output) DOUBLE PRECISION array, dimension
                         (LDQG,N+1)
          On entry, the leading N-by-N+1 part of this array must
          contain in columns 1:N the lower triangular part of the
          matrix Q and in columns 2:N+1 the upper triangular part
          of the matrix G.
          On exit, this array is overwritten. If JOB = 'G', the
          leading N-by-N+1 part of this array contains in columns
          2:N+1 the matrix G of decomposition (2).

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= max(1,N).

  T       (output) DOUBLE PRECISION array, dimension (LDT,N)
          On exit, if JOB = 'S' or JOB = 'G', the leading N-by-N
          part of this array contains the upper triangular matrix T
          of the decomposition (2). Otherwise, this array is used as
          workspace.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= MAX(1,N).

  U1      (output) DOUBLE PRECISION array, dimension (LDU1,N)
          On exit, if JOBU = 'U', the leading N-by-N part of this
          array contains the (1,1) block of the orthogonal
          symplectic matrix U of decomposition (2).

  LDU1    INTEGER
          The leading dimension of the array U1.  LDU1 >= 1.
          LDU1 >= N,    if JOBU = 'U'.

  U2      (output) DOUBLE PRECISION array, dimension (LDU2,N)
          On exit, if JOBU = 'U', the leading N-by-N part of this
          array contains the (2,1) block of the orthogonal
          symplectic matrix U of decomposition (2).

  LDU2    INTEGER
          The leading dimension of the array U2.  LDU2 >= 1.
          LDU2 >= N,    if JOBU = 'U'.

  V1      (output) DOUBLE PRECISION array, dimension (LDV1,N)
          On exit, if JOBV = 'V', the leading N-by-N part of this
          array contains the (1,1) block of the orthogonal
          symplectic matrix V of decomposition (2).

  LDV1    INTEGER
          The leading dimension of the array V1.  LDV1 >= 1.
          LDV1 >= N,    if JOBV = 'V'.

  V2      (output) DOUBLE PRECISION array, dimension (LDV2,N)
          On exit, if JOBV = 'V', the leading N-by-N part of this
          array contains the (2,1) block of the orthogonal
          symplectic matrix V of decomposition (2).

  LDV2    INTEGER
          The leading dimension of the array V2.  LDV2 >= 1.
          LDV2 >= N,    if JOBV = 'V'.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          On exit, the leading N elements of WR and WI contain the
          real and imaginary parts, respectively, of N eigenvalues
          that have nonpositive real part. Complex conjugate pairs
          of eigenvalues with real part not equal to zero will
          appear consecutively with the eigenvalue having the
          positive imaginary part first. For complex conjugate pairs
          of eigenvalues on the imaginary axis only the eigenvalue
          having nonnegative imaginary part will be returned.

  ILO     (output) INTEGER
          ILO is an integer value determined when H was balanced.
          The balanced A(i,j) = 0 if I > J and J = 1,...,ILO-1.
          The balanced Q(i,j) = 0 if J = 1,...,ILO-1 or
          I = 1,...,ILO-1.

  SCALE   (output) DOUBLE PRECISION array, dimension (N)
          On exit, if SCALE = 'S', the leading N elements of this
          array contain details of the permutation and scaling
          factors applied when balancing H, see MB04DD.
          This array is not referenced if BALANC = 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -25,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  (input) INTEGER
          The dimension of the array DWORK. LDWORK >= max( 1, 8*N ).
          Moreover:
          If JOB = 'E' or 'S' and JOBU = 'N' and JOBV = 'N',
             LDWORK >= 7*N+N*N.
          If JOB = 'G' and JOBU = 'N' and JOBV = 'N',
             LDWORK >= max( 7*N+N*N, 2*N+3*N*N ).
          If JOB = 'G' and JOBU = 'U' and JOBV = 'N',
             LDWORK >= 7*N+2*N*N.
          If JOB = 'G' and JOBU = 'N' and JOBV = 'V',
             LDWORK >= 7*N+2*N*N.
          If JOB = 'G' and JOBU = 'U' and JOBV = 'V',
             LDWORK >= 7*N+N*N.
          For good performance, LDWORK must generally be larger.
Error Indicator 
  INFO     (output) INTEGER
           = 0:  successful exit;
           < 0:  if INFO = -i, the i-th argument had an illegal
                 value;
           > 0:  if INFO = i, the periodic QR algorithm failed to
                 compute all the eigenvalues, elements i+1:N of WR
                 and WI contain eigenvalues which have converged.
References 
  [1] Benner, P., Mehrmann, V., and Xu, H.
      A numerically stable, structure preserving method for
      computing the eigenvalues of real Hamiltonian or symplectic
      pencils.
      Numer. Math., Vol. 78(3), pp. 329-358, 1998.

  [2] Benner, P., Mehrmann, V., and Xu, H.
      A new method for computing the stable invariant subspace of a
      real Hamiltonian matrix,  J. Comput. Appl. Math., vol. 86,
      pp. 17-43, 1997.
Further Comments 
  None
Example

Program Text 

*     MB03XD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDQG, LDRES, LDT, LDU1, LDU2, LDV1, LDV2,
     $                 LDWORK
      PARAMETER        ( LDA = NMAX, LDQG = NMAX, LDRES = NMAX,
     $                   LDT = NMAX, LDU1 = NMAX, LDU2 = NMAX,
     $                   LDV1 = NMAX, LDV2 = NMAX,
     $                   LDWORK = 3*NMAX*NMAX + 7*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      BALANC, JOB, JOBU, JOBV
      INTEGER          I, ILO, INFO, J, N
      DOUBLE PRECISION TEMP
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), DWORK(LDWORK), QG(LDQG, NMAX+1),
     $                 RES(LDRES,3*NMAX+1), SCALE(NMAX), T(LDT,NMAX),
     $                 U1(LDU1,NMAX), U2(LDU2, NMAX), V1(LDV1,NMAX),
     $                 V2(LDV2, NMAX), WI(NMAX), WR(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLANGE, DLAPY2, MA02JD
      EXTERNAL         DLANGE, DLAPY2, LSAME, MA02JD
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, MB03XD, MB04DD
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, BALANC, JOB, JOBU, JOBV
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES )
         INFO = 0
         CALL 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 )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20  I = 1, N
               WRITE ( NOUT, FMT = 99996 ) I, WR(I), WI(I)
20          CONTINUE
            IF ( LSAME( JOB, 'S' ).OR.LSAME( JOB, 'G' ) ) THEN
               WRITE ( NOUT, FMT = 99995 )
               DO 30  I = 1, N
                  WRITE ( NOUT, FMT = 99990 ) ( A(I,J), J = 1,N )
30             CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 40  I = 1, N
                  WRITE ( NOUT, FMT = 99990 ) ( T(I,J), J = 1,N )
40             CONTINUE
            END IF
            IF ( LSAME( JOB, 'G' ) ) THEN
               WRITE ( NOUT, FMT = 99993 )
               DO 50  I = 1, N
                  WRITE ( NOUT, FMT = 99990 ) ( QG(I,J+1), J = 1,N )
50             CONTINUE
            END IF
C
            IF ( LSAME( JOB, 'G' ).AND.LSAME( JOBU, 'U' ).AND.
     $           LSAME( JOBV, 'V' ) ) THEN
               CALL MB04DD( BALANC, N, RES(1,N+1), LDRES, RES(1,2*N+1),
     $                      LDRES, I, DWORK, INFO )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     RES(1,N+1), LDRES, V1, LDV1, ZERO, RES,
     $                     LDRES )
               CALL DSYMM ( 'Left', 'Upper', N, N, -ONE, RES(1,2*N+2),
     $                      LDRES, V2, LDV2, ONE, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N,
     $                     -ONE, U1, LDU1, T, LDT, ONE, RES, LDRES )
               TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DWORK )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     RES(1,N+1), LDRES, V2, LDV2, ZERO, RES,
     $                     LDRES )
               CALL DSYMM( 'Left', 'Upper', N, N, ONE, RES(1,2*N+2),
     $                     LDRES, V1, LDV1, ONE, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N,
     $                     -ONE, U1, LDU1, QG(1,2), LDQG, ONE, RES,
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N,
     $                     -ONE, U2, LDU2, A, LDA, ONE, RES, LDRES )
               TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES,
     $                                      LDRES, DWORK ) )
               CALL DSYMM( 'Left', 'Lower', N, N, ONE, RES(1,2*N+1),
     $                     LDRES, V1, LDV1, ZERO, RES, LDRES )
               CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE,
     $                     RES(1,N+1), LDRES, V2, LDV2, ONE, RES,
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U2, LDU2, T, LDT, ONE, RES, LDRES )
               TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES,
     $                                      LDRES, DWORK ) )


               CALL DSYMM( 'Left', 'Lower', N, N, ONE, RES(1,2*N+1),
     $                     LDRES, V2, LDV2, ZERO, RES, LDRES )
               CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, -ONE,
     $                     RES(1,N+1), LDRES, V1, LDV1, ONE, RES,
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U2, LDU2, QG(1,2), LDQG, ONE, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N,
     $                     -ONE, U1, LDU1, A, LDA, ONE, RES, LDRES )
               TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES,
     $                                      LDRES, DWORK ) )
               WRITE ( NOUT, FMT = 99987 ) TEMP
            END IF
C
            IF ( LSAME( JOBU, 'U' ) ) THEN
               WRITE ( NOUT, FMT = 99992 )
               DO 60  I = 1, N
                  WRITE ( NOUT, FMT = 99990 )
     $               ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N )
60             CONTINUE
               DO 70  I = 1, N
                  WRITE ( NOUT, FMT = 99990 )
     $               ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N )
70             CONTINUE
               WRITE ( NOUT, FMT = 99986 ) MA02JD( .FALSE., .FALSE., N,
     $                 U1, LDU1, U2, LDU2, RES, LDRES )
            END IF
            IF ( LSAME( JOBV, 'V' ) ) THEN
               WRITE ( NOUT, FMT = 99991 )
               DO 80  I = 1, N
                  WRITE ( NOUT, FMT = 99990 )
     $               ( V1(I,J), J = 1,N ), ( V2(I,J), J = 1,N )
80             CONTINUE
               DO 90  I = 1, N
                  WRITE ( NOUT, FMT = 99990 )
     $               ( -V2(I,J), J = 1,N ), ( V1(I,J), J = 1,N )
90             CONTINUE
               WRITE ( NOUT, FMT = 99985 ) MA02JD( .FALSE., .FALSE., N,
     $                 V1, LDV1, V2, LDV2, RES, LDRES )
            END IF
            IF ( LSAME( BALANC, 'S' ).OR.LSAME( BALANC, 'B' ) ) THEN
               WRITE ( NOUT, FMT = 99989 )
               DO 100  I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) I, SCALE(I)
100            CONTINUE
            END IF
         END IF
      END IF
*
99999 FORMAT (' MB03XD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03XD = ',I2)
99997 FORMAT (' The stable eigenvalues are',//'   i',6X,
     $        'WR(i)',6X,'WI(i)',/)
99996 FORMAT (I4,3X,F8.4,3X,F8.4)
99995 FORMAT (/' The matrix S of the reduced matrix is')
99994 FORMAT (/' The matrix T of the reduced matrix is')
99993 FORMAT (/' The matrix G of the reduced matrix is')
99992 FORMAT (/' The orthogonal symplectic factor U is')
99991 FORMAT (/' The orthogonal symplectic factor V is')
99990 FORMAT (20(1X,F19.16))
99989 FORMAT (/' The diagonal scaling factors are ',//'   i',6X,
     $        'SCALE(i)',/)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2)
99986 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2)
99985 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2)
      END
Program Data 
MB03XD EXAMPLE PROGRAM DATA
	5	N	G	U	V
  3.7588548168313685e-001  9.1995720669587144e-001  1.9389317998466821e-001  5.4878212553858818e-001  6.2731478808399666e-001
  9.8764628987858052e-003  8.4472150190817474e-001  9.0481233416635698e-001  9.3158335257969060e-001  6.9908013774533750e-001
  4.1985780631021896e-001  3.6775288246828447e-001  5.6920574967174709e-001  3.3519743020639464e-001  3.9718395379261456e-001
  7.5366962581358721e-001  6.2080133182114383e-001  6.3178992922175603e-001  6.5553105501201447e-001  4.1362889533818031e-001
  7.9387177473231862e-001  7.3127726446634478e-001  2.3441295540825388e-001  3.9190420688900335e-001  6.5521294635567051e-001
  1.8015558545989005e-001  4.1879254941592853e-001  2.7203760737317784e-001  2.8147214090719214e-001  1.7731904815580199e-001  3.4718672159409536e-001
  2.7989257702981651e-001  3.5042861661866559e-001  2.5565572408444881e-001  4.3977750345993827e-001  2.8855026075967616e-001  2.1496327083014577e-001
  1.7341073886969158e-001  3.9913855375815932e-001  4.0151317011596516e-001  4.0331887464437133e-001  2.6723538667317948e-001  3.7110275606849241e-001
  3.7832182695699140e-001  3.3812641389556752e-001  8.4360396433341395e-002  4.3672540277019672e-001  7.0022228267365608e-002  3.8210230186291916e-001
  1.9548216143135175e-001  2.9055490787446736e-001  4.7670819669167425e-001  1.4636498713707141e-001  2.7670398401519275e-001  2.9431082727794898e-002
Program Results 
 MB03XD EXAMPLE PROGRAM RESULTS

 The stable eigenvalues are

   i      WR(i)      WI(i)

   1    -3.1941     0.0000
   2    -0.1350     0.3179
   3    -0.1350    -0.3179
   4    -0.0595     0.2793
   5    -0.0595    -0.2793

 The matrix S of the reduced matrix is
 -3.1844761777714705  0.1612357243439340 -0.0628592203751098  0.2449004200921959  0.1974400149992626
  0.0000000000000000 -0.1510667773167789  0.4260444411622883 -0.1775026035208666  0.3447278421198391
  0.0000000000000000 -0.1386140422054271 -0.3006779624777444  0.2944143257134114  0.3456440339120371
  0.0000000000000000  0.0000000000000000  0.0000000000000000 -0.2710128384740574  0.0933189808067095
  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.4844146572359634  0.2004347508746742

 The matrix T of the reduced matrix is
  3.2038208121776348  0.1805955192510640  0.2466389119377566 -0.2539149302433392 -0.0359238844381156
  0.0000000000000000 -0.7196686433290816  0.0000000000000000  0.2428659121580376 -0.0594190100670782
  0.0000000000000000  0.0000000000000000 -0.1891741194498114 -0.3309578443491296 -0.0303520731950499
  0.0000000000000000  0.0000000000000000  0.0000000000000000 -0.4361574461961528  0.0000000000000000
  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.1530894573304223

 The matrix G of the reduced matrix is
 -0.0370982242678457  0.0917788436945731 -0.0560402416315241  0.1345152517579191  0.0256668227276677
  0.0652183678916931 -0.0700457231988316  0.0350041175858833 -0.2233868768749274 -0.1171980260782826
 -0.0626428681377085  0.2327575351902817 -0.1251515732208144 -0.0177816046663199  0.3696921118421150
  0.0746042309265577 -0.0828007611045206  0.0217427473546019 -0.1157775118548848 -0.3161183681200569
  0.1374372236164831  0.1002727885506978  0.4021556774753979 -0.0431072263235601  0.1067394572547818

 Residual: || H*V - U*R ||_F = .46E-14

 The orthogonal symplectic factor U is
  0.3806883009357248 -0.0347810363019652 -0.5014665065895682  0.5389691288472414  0.2685446895251484 -0.1795922007470743  0.1908329820840928  0.0868799433942036  0.3114741142062438 -0.2579907627915120
  0.4642712665555325 -0.5942766860716391  0.4781179763952650  0.2334370556238112  0.0166790369048892 -0.2447897730222851 -0.1028403314750051 -0.1157840914576275 -0.1873268885694416  0.1700708002861561
  0.2772789197782786 -0.0130145392695875 -0.2123817030594140 -0.2550292626960040 -0.5049268366774471 -0.2243335325285328  0.3180998613802515  0.3315380214794929  0.1977859924739848  0.5072476567310018
  0.4209268575081796  0.1499593172661209 -0.1925590746592153 -0.5472292877802430  0.4543329704184027 -0.2128397588651423 -0.2740560593051887  0.1941418870268840 -0.3096684962457376 -0.0581576193198811
  0.3969669479129447  0.6321903535930841  0.3329156356041933  0.0163533225344418 -0.2638879466190077 -0.2002027567371932 -0.0040094115506849 -0.3979373387545270  0.1520881534833964 -0.2010804514091296
  0.1795922007470743 -0.1908329820840928 -0.0868799433942036 -0.3114741142062438  0.2579907627915120  0.3806883009357248 -0.0347810363019652 -0.5014665065895682  0.5389691288472414  0.2685446895251484
  0.2447897730222851  0.1028403314750051  0.1157840914576275  0.1873268885694416 -0.1700708002861561  0.4642712665555325 -0.5942766860716391  0.4781179763952650  0.2334370556238112  0.0166790369048892
  0.2243335325285328 -0.3180998613802515 -0.3315380214794929 -0.1977859924739848 -0.5072476567310018  0.2772789197782786 -0.0130145392695875 -0.2123817030594140 -0.2550292626960040 -0.5049268366774471
  0.2128397588651423  0.2740560593051887 -0.1941418870268840  0.3096684962457376  0.0581576193198811  0.4209268575081796  0.1499593172661209 -0.1925590746592153 -0.5472292877802430  0.4543329704184027
  0.2002027567371932  0.0040094115506849  0.3979373387545270 -0.1520881534833964  0.2010804514091296  0.3969669479129447  0.6321903535930841  0.3329156356041933  0.0163533225344418 -0.2638879466190077

 Orthogonality of U: || U^T U - I ||_F = .44E-14

 The orthogonal symplectic factor V is
  0.4447147692018326 -0.6830166755147431 -0.0002576861753472  0.5781954611783312 -0.0375091627893765  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000
  0.5121756358795811  0.0297197140254803  0.4332229148788684 -0.3240527006890551  0.5330850295256574  0.0299719306696789 -0.2322624725320721 -0.0280846899680319 -0.3044255686880006 -0.1077641482535489
  0.3664711365265599  0.3288511296455133  0.0588396016404453  0.1134221597062261  0.1047567336850063 -0.0069083614679702  0.3351358347080118 -0.4922707032978923  0.4293545450291748  0.4372821269061881
  0.4535357098437906  0.1062866148880800 -0.3964092656837794 -0.2211800890450660  0.0350667323996171  0.0167847133528844  0.2843629278945297  0.5958979805231186  0.3097336757510848 -0.2086733033047147
  0.4450432900616095  0.2950206358263791 -0.1617837757183793 -0.0376369332204956 -0.6746752660482674  0.0248567764822071 -0.2810759958040470 -0.1653113624869855 -0.3528780198620398 -0.0254898556119232
  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.4447147692018326 -0.6830166755147431 -0.0002576861753472  0.5781954611783312 -0.0375091627893765
 -0.0299719306696789  0.2322624725320721  0.0280846899680319  0.3044255686880006  0.1077641482535489  0.5121756358795811  0.0297197140254803  0.4332229148788684 -0.3240527006890551  0.5330850295256574
  0.0069083614679702 -0.3351358347080118  0.4922707032978923 -0.4293545450291748 -0.4372821269061881  0.3664711365265599  0.3288511296455133  0.0588396016404453  0.1134221597062261  0.1047567336850063
 -0.0167847133528844 -0.2843629278945297 -0.5958979805231186 -0.3097336757510848  0.2086733033047147  0.4535357098437906  0.1062866148880800 -0.3964092656837794 -0.2211800890450660  0.0350667323996171
 -0.0248567764822071  0.2810759958040470  0.1653113624869855  0.3528780198620398  0.0254898556119232  0.4450432900616095  0.2950206358263791 -0.1617837757183793 -0.0376369332204956 -0.6746752660482674

 Orthogonality of V: || V^T V - I ||_F = .28E-14

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03XP.html000077500000000000000000000440731201767322700161250ustar00rootroot00000000000000 MB03XP - SLICOT Library Routine Documentation

MB03XP

Computing periodic Schur decomposition and eigenvalues of a matrix product A B, with A upper Hessenberg and B upper triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the periodic Schur decomposition and the eigenvalues of
  a product of matrices, H = A*B, with A upper Hessenberg and B
  upper triangular without evaluating any part of the product.
  Specifically, the matrices Q and Z are computed, so that

       Q' * A * Z = S,    Z' * B * Q = T

  where S is in real Schur form, and T is upper triangular.
Specification 
      SUBROUTINE MB03XP( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,
     $                   Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK,
     $                   LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates whether the user wishes to compute the full
          Schur form or the eigenvalues only, as follows:
          = 'E':  Compute the eigenvalues only;
          = 'S':  compute the factors S and T of the full
                  Schur form.

  COMPQ   CHARACTER*1
          Indicates whether or not the user wishes to accumulate
          the matrix Q as follows:
          = 'N':  The matrix Q is not required;
          = 'I':  Q is initialized to the unit matrix and the
                  orthogonal transformation matrix Q is returned;
          = 'V':  Q must contain an orthogonal matrix U on entry,
                  and the product U*Q is returned.

  COMPZ   CHARACTER*1
          Indicates whether or not the user wishes to accumulate
          the matrix Z as follows:
          = 'N':  The matrix Z is not required;
          = 'I':  Z is initialized to the unit matrix and the
                  orthogonal transformation matrix Z is returned;
          = 'V':  Z must contain an orthogonal matrix U on entry,
                  and the product U*Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and B. N >= 0.

  ILO     (input) INTEGER
  IHI     (input) INTEGER
          It is assumed that the matrices A and B are already upper
          triangular in rows and columns 1:ILO-1 and IHI+1:N.
          The routine works primarily with the submatrices in rows
          and columns ILO to IHI, but applies the transformations to
          all the rows and columns of the matrices A and B, if
          JOB = 'S'.
          1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array A must
          contain the upper Hessenberg matrix A.
          On exit, if JOB = 'S', the leading N-by-N part of this
          array is upper quasi-triangular with any 2-by-2 diagonal
          blocks corresponding to a pair of complex conjugated
          eigenvalues.
          If JOB = 'E', the diagonal elements and 2-by-2 diagonal
          blocks of A will be correct, but the remaining parts of A
          are unspecified on exit.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array B must
          contain the upper triangular matrix B.
          On exit, if JOB = 'S', the leading N-by-N part of this
          array contains the transformed upper triangular matrix.
          2-by-2 blocks in B corresponding to 2-by-2 blocks in A
          will be reduced to positive diagonal form. (I.e., if
          A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j)
          and B(j+1,j+1) will be positive.)
          If JOB = 'E', the elements corresponding to diagonal
          elements and 2-by-2 diagonal blocks in A will be correct,
          but the remaining parts of B are unspecified on exit.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, if COMPQ = 'V', then the leading N-by-N part of
          this array must contain a matrix Q which is assumed to be
          equal to the unit matrix except for the submatrix
          Q(ILO:IHI,ILO:IHI).
          If COMPQ = 'I', Q need not be set on entry.
          On exit, if COMPQ = 'V' or COMPQ = 'I' the leading N-by-N
          part of this array contains the transformation matrix
          which produced the Schur form.
          If COMPQ = 'N', Q is not referenced.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= 1.
          If COMPQ <> 'N', LDQ >= MAX(1,N).

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          On entry, if COMPZ = 'V', then the leading N-by-N part of
          this array must contain a matrix Z which is assumed to be
          equal to the unit matrix except for the submatrix
          Z(ILO:IHI,ILO:IHI).
          If COMPZ = 'I', Z need not be set on entry.
          On exit, if COMPZ = 'V' or COMPZ = 'I' the leading N-by-N
          part of this array contains the transformation matrix
          which produced the Schur form.
          If COMPZ = 'N', Z is not referenced.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= 1.
          If COMPZ <> 'N', LDZ >= MAX(1,N).

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
  BETA    (output) DOUBLE PRECISION array, dimension (N)
          The i-th (1 <= i <= N) computed eigenvalue is given by
          BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two
          eigenvalues are computed as a complex conjugate pair,
          they are stored in consecutive elements of ALPHAR, ALPHAI
          and BETA. If JOB = 'S', the eigenvalues are stored in the
          same order as on the diagonales of the Schur forms of A
          and B.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -19,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, then MB03XP failed to compute the Schur
                form in a total of 30*(IHI-ILO+1) iterations;
                elements 1:ilo-1 and i+1:n of ALPHAR, ALPHAI and
                BETA contain successfully computed eigenvalues.
Method 
  The implemented algorithm is a multi-shift version of the periodic
  QR algorithm described in [1,3] with some minor modifications
  proposed in [2].
References 
  [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P.
      The periodic Schur decomposition: Algorithms and applications.
      Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
      1992.

  [2] Kressner, D.
      An efficient and reliable implementation of the periodic QZ
      algorithm. Proc. of the IFAC Workshop on Periodic Control
      Systems, pp. 187-192, 2001.

  [3] Van Loan, C.
      Generalized Singular Values with Algorithms and Applications.
      Ph. D. Thesis, University of Michigan, 1973.
Numerical Aspects 
  The algorithm requires O(N**3) floating point operations and is
  backward stable.
Further Comments 
  None
Example

Program Text 

*     MB03XP EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 200 )
      INTEGER          LDA, LDB, LDQ, LDRES, LDZ, LDWORK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDQ = NMAX,
     $                   LDRES = NMAX, LDWORK = NMAX, LDZ = NMAX )
*     .. Local Scalars ..
      INTEGER          I, IHI, ILO, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX),
     $                 B(LDA,NMAX), BETA(NMAX), DWORK(LDWORK),
     $                 Q(LDQ,NMAX), RES(LDRES,3*NMAX), Z(LDZ,NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANGE
      EXTERNAL         DLANGE
*     .. External Subroutines ..
      EXTERNAL         DGEMM, MB03XP
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, ILO, IHI
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, B, LDB, RES(1,2*N+1), LDRES )
         CALL MB03XP( 'S', 'I', 'I', N, ILO, IHI, A, LDA, B, LDB, Q,
     $                LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, LDWORK,
     $                INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99996 )
            DO 10  I = 1, N
               WRITE (NOUT, FMT = 99991) ( A(I,J), J = 1,N )
10          CONTINUE
            CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                  RES(1,N+1), LDRES, Z, LDZ, ZERO, RES, LDRES )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE,
     $                  Q, LDQ, A, LDA, ONE, RES, LDRES )
            WRITE ( NOUT, FMT = 99989 ) DLANGE( 'Frobenius', N, N, RES,
     $                                          LDRES, DWORK )
            WRITE ( NOUT, FMT = 99995 )
            DO 20  I = 1, N
               WRITE (NOUT, FMT = 99991) ( B(I,J), J = 1,N )
20          CONTINUE
            CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                  RES(1,2*N+1), LDRES, Q, LDQ, ZERO, RES, LDRES )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE,
     $                  Z, LDZ, B, LDB, ONE, RES, LDRES )
            WRITE ( NOUT, FMT = 99988 ) DLANGE( 'Frobenius', N, N, RES,
     $                                          LDRES, DWORK )
            WRITE ( NOUT, FMT = 99994 )
            DO 30  I = 1, N
               WRITE (NOUT, FMT = 99991) ( Q(I,J), J = 1,N )
30          CONTINUE
            CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q,
     $                  LDQ, Q, LDQ, ONE, RES, LDRES )
            DO 40  I = 1, N
               RES(I,I) = RES(I,I) - ONE
40          CONTINUE
            WRITE ( NOUT, FMT = 99987 ) DLANGE( 'Frobenius', N, N, RES,
     $                                          LDRES, DWORK )
            WRITE ( NOUT, FMT = 99993 )
            DO 50  I = 1, N
               WRITE (NOUT, FMT = 99991) ( Z(I,J), J = 1,N )
50          CONTINUE
            CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Z,
     $                  LDZ, Z, LDZ, ONE, RES, LDRES )
            DO 60 I = 1, N
               RES(I,I) = RES(I,I) - ONE
60          CONTINUE
            WRITE ( NOUT, FMT = 99986 ) DLANGE( 'Frobenius', N, N, RES,
     $                                          LDRES, DWORK )
            WRITE ( NOUT, FMT = 99992 )
            DO 70  I = 1, N
               WRITE ( NOUT, FMT = 99991 )
     $                 ALPHAR(I), ALPHAI(I), BETA(I)
70          CONTINUE
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03XP EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03XP = ',I2)
99996 FORMAT (' The reduced matrix A is ')
99995 FORMAT (/' The reduced matrix B is ')
99994 FORMAT (/' The orthogonal factor Q is ')
99993 FORMAT (/' The orthogonal factor Z is ')
99992 FORMAT (/4X,'ALPHAR',4X,'ALPHAI',4X,'BETA')
99991 FORMAT (1000(1X,F9.4))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' Residual: || A*Z - Q*S ||_F = ',G7.2)
99988 FORMAT (/' Residual: || B*Q - Z*T ||_F = ',G7.2)
99987 FORMAT (/' Orthogonality of Q: || Q''*Q - I ||_F = ',G7.2)
99986 FORMAT (/' Orthogonality of Z: || Z''*Z - I ||_F = ',G7.2)
      END
Program Data 
MB03XP EXAMPLE PROGRAM DATA
        8       1       8
    0.9708   -1.1156   -0.0884   -0.2684    0.2152    0.0402    0.0333    0.5141
   -1.6142    2.8635    1.0420   -0.2295   -0.3560    0.4885    0.1026   -0.0164
         0    1.1138    0.3509   -0.0963    0.0875    0.2158    0.2444   -0.2838
         0         0   -0.5975    0.1021   -0.1026   -0.0062   -0.2646   -0.0745
         0         0         0    0.6181    0.1986    0.3612   -0.1750    0.3332
         0         0         0         0   -0.7387   -0.5201    0.0713    0.0501
         0         0         0         0         0   -0.2677   -0.4918   -0.2838
         0         0         0         0         0         0    0.3011    0.3389
    0.9084    0.1739    0.5915    0.8729    0.8188    0.1911    0.4122    0.5527
         0    0.1708    0.1197    0.2379    0.4302    0.4225    0.9016    0.4001
         0         0    0.0381    0.6458    0.8903    0.8560    0.0056    0.1988
         0         0         0    0.9669    0.7349    0.4902    0.2974    0.6252
         0         0         0         0    0.6873    0.8159    0.0492    0.7334
         0         0         0         0         0    0.4608    0.6932    0.3759
         0         0         0         0         0         0    0.6501    0.0099
         0         0         0         0         0         0         0    0.4199
Program Results 
 MB03XP EXAMPLE PROGRAM RESULTS

 The reduced matrix A is 
   -0.6290   -0.1397   -0.0509    0.1603   -0.3248    0.2381    0.0694    0.0103
    1.5112   -3.4273   -0.4485   -0.4357   -0.3456    0.4619    0.5998    0.5654
    0.0000    0.0000    0.0547   -0.4360    0.1714   -0.2103   -0.0900   -0.4011
    0.0000    0.0000    0.6623    0.2038    0.2796   -0.2629    0.3837    0.2382
    0.0000    0.0000    0.0000    0.0000   -0.6315    0.2071   -0.0174   -0.3538
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.5850   -0.1813    0.2435
    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000   -0.7884    0.1535
    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.2832

 Residual: || A*Z - Q*S ||_F = .46E-14

 The reduced matrix B is 
   -0.9231    0.0000   -0.9834    0.1805    0.4428    0.3655   -0.4300    0.8498
    0.0000   -0.1837   -0.1873    0.0681    0.8412   -0.0556    0.0538    0.6113
    0.0000    0.0000   -1.8997    0.0000    0.5651   -0.2785    0.2882    1.0458
    0.0000    0.0000    0.0000   -0.2602    0.3527   -0.0020   -0.3396    0.2739
    0.0000    0.0000    0.0000    0.0000    0.8521   -0.0164    0.2115    0.5446
    0.0000    0.0000    0.0000    0.0000    0.0000    0.0283   -0.5128    0.0153
    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.4153    0.4587
    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.5894

 Residual: || B*Q - Z*T ||_F = .39E-14

 The orthogonal factor Q is 
   -0.5333    0.3661   -0.1179    0.0264    0.0026    0.7527    0.0018    0.0189
    0.0583   -0.8833   -0.0666   -0.0007    0.0017    0.4603    0.0050    0.0092
   -0.8414   -0.2927    0.0347    0.0452   -0.0005   -0.4498   -0.0269    0.0001
    0.0077    0.0046   -0.5687   -0.4810    0.0227   -0.0708   -0.6500    0.1312
    0.0598    0.0059   -0.6128    0.7656    0.1348   -0.0863    0.0038    0.0954
   -0.0242   -0.0016   -0.4295   -0.4163    0.3871   -0.0709    0.6964   -0.0417
    0.0027    0.0001    0.3109    0.0620    0.8615    0.0378   -0.2267    0.3231
    0.0012    0.0000    0.0188   -0.0514   -0.2987   -0.0172    0.2010    0.9312

 Orthogonality of Q: || Q'*Q - I ||_F = .52E-14

 The orthogonal factor Z is 
    0.9957   -0.0786    0.0397   -0.0032    0.0006    0.0227    0.0104    0.0123
    0.0764    0.9956    0.0200    0.0073   -0.0009    0.0389    0.0263    0.0193
   -0.0062    0.0235    0.6714   -0.0229    0.0271   -0.4461   -0.5354   -0.2486
   -0.0445   -0.0437    0.6098    0.4197   -0.0656    0.6125    0.1248    0.2302
   -0.0242   -0.0148    0.4049   -0.6041    0.2808   -0.1328    0.5972    0.1311
    0.0096    0.0037   -0.0183    0.6539    0.5114   -0.4136    0.3620   -0.0913
   -0.0019   -0.0004   -0.1055   -0.1544    0.7891    0.2944   -0.4436    0.2426
   -0.0005    0.0000   -0.0039    0.0826   -0.1786   -0.3853   -0.1119    0.8946

 Orthogonality of Z: || Z'*Z - I ||_F = .55E-14

    ALPHAR    ALPHAI    BETA
    0.4723    0.1464    1.2811
    0.4723   -0.1464    1.2811
   -0.0295    0.1416    2.6621
   -0.0295   -0.1416    2.6621
   -0.6315    0.0000    0.8521
   -0.5850    0.0000    0.0283
   -0.7884    0.0000    0.4153
    0.2832    0.0000    0.5894

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03XU.html000077500000000000000000000260611201767322700161270ustar00rootroot00000000000000 MB03XU - SLICOT Library Routine Documentation

MB03XU

Panel reduction of columns and rows of a real (k+2n)-by-(k+2n) matrix by orthogonal symplectic transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce 2*nb columns and rows of a real (k+2n)-by-(k+2n)
  matrix H:

          [ op(A)   G   ]
      H = [             ],
          [  Q    op(B) ]

  so that elements in the first nb columns below the k-th
  subdiagonal of the (k+n)-by-n matrix op(A), in the first nb
  columns and rows of the n-by-n matrix Q and in the first nb rows
  above the diagonal of the n-by-(k+n) matrix op(B) are zero.
  The reduction is performed by orthogonal symplectic
  transformations UU'*H*VV and matrices U, V, YA, YB, YG, YQ, XA,
  XB, XG, and XQ are returned so that

                 [ op(Aout)+U*YA'+XA*V'     G+U*YG'+XG*V'    ]
      UU' H VV = [                                           ].
                 [   Qout+U*YQ'+XQ*V'   op(Bout)+U*YB'+XB*V' ]

  This is an auxiliary routine called by MB04TB.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  LTRA    LOGICAL
          Specifies the form of op( A ) as follows:
          = .FALSE.:  op( A ) = A;
          = .TRUE.:   op( A ) = A'.

  LTRB    LOGICAL
          Specifies the form of op( B ) as follows:
          = .FALSE.:  op( B ) = B;
          = .TRUE.:   op( B ) = B'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix Q. N >= 0.

  K       (input) INTEGER
          The offset of the reduction. Elements below the K-th
          subdiagonal in the first NB columns of op(A) are
          reduced to zero. K >= 0.

  NB      (input) INTEGER
          The number of columns/rows to be reduced. N > NB >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension
                  (LDA,N)     if LTRA = .FALSE.
                  (LDA,K+N)   if LTRA = .TRUE.
          On entry with LTRA = .FALSE., the leading (K+N)-by-N part
          of this array must contain the matrix A.
          On entry with LTRA = .TRUE., the leading N-by-(K+N) part
          of this array must contain the matrix A.
          On exit with LTRA = .FALSE., the leading (K+N)-by-N part
          of this array contains the matrix Aout and, in the zero
          parts, information about the elementary reflectors used to
          compute the reduction.
          On exit with LTRA = .TRUE., the leading N-by-(K+N) part of
          this array contains the matrix Aout and in the zero parts
          information about the elementary reflectors.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,K+N),  if LTRA = .FALSE.;
          LDA >= MAX(1,N),    if LTRA = .TRUE..

  B       (input/output) DOUBLE PRECISION array, dimension
                  (LDB,K+N)   if LTRB = .FALSE.
                  (LDB,N)     if LTRB = .TRUE.
          On entry with LTRB = .FALSE., the leading N-by-(K+N) part
          of this array must contain the matrix B.
          On entry with LTRB = .TRUE., the leading (K+N)-by-N part
          of this array must contain the matrix B.
          On exit with LTRB = .FALSE., the leading N-by-(K+N) part
          of this array contains the matrix Bout and, in the zero
          parts, information about the elementary reflectors used to
          compute the reduction.
          On exit with LTRB = .TRUE., the leading (K+N)-by-N part of
          this array contains the matrix Bout and in the zero parts
          information about the elementary reflectors.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N),    if LTRB = .FALSE.;
          LDB >= MAX(1,K+N),  if LTRB = .TRUE..

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix G.
          On exit, the leading N-by-N part of this array contains
          the matrix Gout.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix Q.
          On exit, the leading N-by-N part of this array contains
          the matrix Qout and in the zero parts information about
          the elementary reflectors used to compute the reduction.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= MAX(1,N).

  XA      (output) DOUBLE PRECISION array, dimension (LDXA,2*NB)
          On exit, the leading N-by-(2*NB) part of this array
          contains the matrix XA.

  LDXA    INTEGER
          The leading dimension of the array XA.  LDXA >= MAX(1,N).

  XB      (output) DOUBLE PRECISION array, dimension (LDXB,2*NB)
          On exit, the leading (K+N)-by-(2*NB) part of this array
          contains the matrix XB.

  LDXB    INTEGER
          The leading dimension of the array XB. LDXB >= MAX(1,K+N).

  XG      (output) DOUBLE PRECISION array, dimension (LDXG,2*NB)
          On exit, the leading (K+N)-by-(2*NB) part of this array
          contains the matrix XG.

  LDXG    INTEGER
          The leading dimension of the array XG. LDXG >= MAX(1,K+N).

  XQ      (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB)
          On exit, the leading N-by-(2*NB) part of this array
          contains the matrix XQ.

  LDXQ    INTEGER
          The leading dimension of the array XQ.  LDXQ >= MAX(1,N).

  YA      (output) DOUBLE PRECISION array, dimension (LDYA,2*NB)
          On exit, the leading (K+N)-by-(2*NB) part of this array
          contains the matrix YA.

  LDYA    INTEGER
          The leading dimension of the array YA. LDYA >= MAX(1,K+N).

  YB      (output) DOUBLE PRECISION array, dimension (LDYB,2*NB)
          On exit, the leading N-by-(2*NB) part of this array
          contains the matrix YB.

  LDYB    INTEGER
          The leading dimension of the array YB.  LDYB >= MAX(1,N).

  YG      (output) DOUBLE PRECISION array, dimension (LDYG,2*NB)
          On exit, the leading (K+N)-by-(2*NB) part of this array
          contains the matrix YG.

  LDYG    INTEGER
          The leading dimension of the array YG. LDYG >= MAX(1,K+N).

  YQ      (output) DOUBLE PRECISION array, dimension (LDYQ,2*NB)
          On exit, the leading N-by-(2*NB) part of this array
          contains the matrix YQ.

  LDYQ    INTEGER
          The leading dimension of the array YQ.  LDYQ >= MAX(1,N).

  CSL     (output) DOUBLE PRECISION array, dimension (2*NB)
          On exit, the first 2NB elements of this array contain the
          cosines and sines of the symplectic Givens rotations
          applied from the left-hand side used to compute the
          reduction.

  CSR     (output) DOUBLE PRECISION array, dimension (2*NB)
          On exit, the first 2NB-2 elements of this array contain
          the cosines and sines of the symplectic Givens rotations
          applied from the right-hand side used to compute the
          reduction.

  TAUL    (output) DOUBLE PRECISION array, dimension (NB)
          On exit, the first NB elements of this array contain the
          scalar factors of some of the elementary reflectors
          applied form the left-hand side.

  TAUR    (output) DOUBLE PRECISION array, dimension (NB)
          On exit, the first NB-1 elements of this array contain the
          scalar factors of some of the elementary reflectors
          applied form the right-hand side.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (5*NB)
Method 
  For details regarding the representation of the orthogonal
  symplectic matrices UU and VV within the arrays A, B, CSL, CSR, Q,
  TAUL and TAUR see the description of MB04TB.

  The contents of A, B, G and Q on exit are illustrated by the
  following example with op(A) = A, op(B) = B, n = 5, k = 2 and
  nb = 2:

       ( a  r  r  a  a  )       ( g  g  g  r  r  g  g  )
       ( a  r  r  a  a  )       ( g  g  g  r  r  g  g  )
       ( r  r  r  r  r  )       ( r  r  r  r  r  r  r  )
   A = ( u2 r  r  r  r  ),  G = ( r  r  r  r  r  r  r  ),
       ( u2 u2 r  a  a  )       ( g  g  g  r  r  g  g  )
       ( u2 u2 r  a  a  )       ( g  g  g  r  r  g  g  )
       ( u2 u2 r  a  a  )       ( g  g  g  r  r  g  g  )

       ( t  t  v1 v1 v1 )       ( r  r  r  r  r  v2 v2 )
       ( u1 t  t  v1 v1 )       ( r  r  r  r  r  r  v2 )
   Q = ( u1 u1 r  q  q  ),  B = ( b  b  b  r  r  b  b  ).
       ( u1 u1 r  q  q  )       ( b  b  b  r  r  b  b  )
       ( u1 u1 r  q  q  )       ( b  b  b  r  r  b  b  )

  where a, b, g and q denote elements of the original matrices, r
  denotes a modified element, t denotes a scalar factor of an
  applied elementary reflector, ui and vi denote elements of the
  matrices U and V, respectively.
Numerical Aspects 
  The algorithm requires ( 16*K + 32*N + 42 )*N*NB +
  ( 16*K + 112*N - 208/3*NB - 69 )*NB*NB - 29/3*NB floating point
  operations and is numerically backward stable.
References 
  [1] Benner, P., Mehrmann, V., and Xu, H.
      A numerically stable, structure preserving method for
      computing the eigenvalues of real Hamiltonian or symplectic
      pencils.
      Numer. Math., Vol. 78 (3), pp. 329-358, 1998.

  [2] Kressner, D.
      Block algorithms for orthogonal symplectic factorizations.
      BIT Numerical Mathematics, 43 (4), pp. 775-790, 2003.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03YA.html000077500000000000000000000162641201767322700161100ustar00rootroot00000000000000 MB03YA - SLICOT Library Routine Documentation

MB03YA

Annihilation of one or two entries on the subdiagonal of a Hessenberg matrix corresponding to zero elements on the diagonal of a triangular matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To annihilate one or two entries on the subdiagonal of the
  Hessenberg matrix A for dealing with zero elements on the diagonal
  of the triangular matrix B.

  MB03YA is an auxiliary routine called by SLICOT Library routines
  MB03XP and MB03YD.
Specification 
      SUBROUTINE MB03YA( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ,
     $                   POS, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )
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,*)
Arguments

Mode Parameters 

  WANTT   LOGICAL
          Indicates whether the user wishes to compute the full
          Schur form or the eigenvalues only, as follows:
          = .TRUE. :  Compute the full Schur form;
          = .FALSE.:  compute the eigenvalues only.

  WANTQ   LOGICAL
          Indicates whether or not the user wishes to accumulate
          the matrix Q as follows:
          = .TRUE. :  The matrix Q is updated;
          = .FALSE.:  the matrix Q is not required.

  WANTZ   LOGICAL
          Indicates whether or not the user wishes to accumulate
          the matrix Z as follows:
          = .TRUE. :  The matrix Z is updated;
          = .FALSE.:  the matrix Z is not required.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and B. N >= 0.

  ILO     (input) INTEGER
  IHI     (input) INTEGER
          It is assumed that the matrices A and B are already
          (quasi) upper triangular in rows and columns 1:ILO-1 and
          IHI+1:N. The routine works primarily with the submatrices
          in rows and columns ILO to IHI, but applies the
          transformations to all the rows and columns of the
          matrices A and B, if WANTT = .TRUE..
          1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N.

  ILOQ    (input) INTEGER
  IHIQ    (input) INTEGER
          Specify the rows of Q and Z to which transformations
          must be applied if WANTQ = .TRUE. and WANTZ = .TRUE.,
          respectively.
          1 <= ILOQ <= ILO; IHI <= IHIQ <= N.

  POS     (input) INTEGER
          The position of the zero element on the diagonal of B.
          ILO <= POS <= IHI.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the upper Hessenberg matrix A.
          On exit, the leading N-by-N part of this array contains
          the updated matrix A where A(POS,POS-1) = 0, if POS > ILO,
          and A(POS+1,POS) = 0, if POS < IHI.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain an upper triangular matrix B with B(POS,POS) = 0.
          On exit, the leading N-by-N part of this array contains
          the updated upper triangular matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, if WANTQ = .TRUE., then the leading N-by-N part
          of this array must contain the current matrix Q of
          transformations accumulated by MB03XP.
          On exit, if WANTQ = .TRUE., then the leading N-by-N part
          of this array contains the matrix Q updated in the
          submatrix Q(ILOQ:IHIQ,ILO:IHI).
          If WANTQ = .FALSE., Q is not referenced.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= 1.
          If WANTQ = .TRUE., LDQ >= MAX(1,N).

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          On entry, if WANTZ = .TRUE., then the leading N-by-N part
          of this array must contain the current matrix Z of
          transformations accumulated by MB03XP.
          On exit, if WANTZ = .TRUE., then the leading N-by-N part
          of this array contains the matrix Z updated in the
          submatrix Z(ILOQ:IHIQ,ILO:IHI).
          If WANTZ = .FALSE., Z is not referenced.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= 1.
          If WANTZ = .TRUE., LDZ >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The method is illustrated by Wilkinson diagrams for N = 5,
  POS = 3:

        [ x x x x x ]       [ x x x x x ]
        [ x x x x x ]       [ o x x x x ]
    A = [ o x x x x ],  B = [ o o o x x ].
        [ o o x x x ]       [ o o o x x ]
        [ o o o x x ]       [ o o o o x ]

  First, a QR factorization is applied to A(1:3,1:3) and the
  resulting nonzero in the updated matrix B is immediately
  annihilated by a Givens rotation acting on columns 1 and 2:

        [ x x x x x ]       [ x x x x x ]
        [ x x x x x ]       [ o x x x x ]
    A = [ o o x x x ],  B = [ o o o x x ].
        [ o o x x x ]       [ o o o x x ]
        [ o o o x x ]       [ o o o o x ]

  Secondly, an RQ factorization is applied to A(4:5,4:5) and the
  resulting nonzero in the updated matrix B is immediately
  annihilated by a Givens rotation acting on rows 4 and 5:

        [ x x x x x ]       [ x x x x x ]
        [ x x x x x ]       [ o x x x x ]
    A = [ o o x x x ],  B = [ o o o x x ].
        [ o o o x x ]       [ o o o x x ]
        [ o o o x x ]       [ o o o o x ]
References 
  [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P.
      The periodic Schur decomposition: Algorithms and applications.
      Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
      1992.
Numerical Aspects 
  The algorithm requires O(N**2) floating point operations and is
  backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03YD.html000077500000000000000000000204361201767322700161070ustar00rootroot00000000000000 MB03YD - SLICOT Library Routine Documentation

MB03YD

Periodic QR iteration

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To deal with small subtasks of the product eigenvalue problem.

  MB03YD is an auxiliary routine called by SLICOT Library routine
  MB03XP.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  WANTT   LOGICAL
          Indicates whether the user wishes to compute the full
          Schur form or the eigenvalues only, as follows:
          = .TRUE. :  Compute the full Schur form;
          = .FALSE.:  compute the eigenvalues only.

  WANTQ   LOGICAL
          Indicates whether or not the user wishes to accumulate
          the matrix Q as follows:
          = .TRUE. :  The matrix Q is updated;
          = .FALSE.:  the matrix Q is not required.

  WANTZ   LOGICAL
          Indicates whether or not the user wishes to accumulate
          the matrix Z as follows:
          = .TRUE. :  The matrix Z is updated;
          = .FALSE.:  the matrix Z is not required.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and B. N >= 0.

  ILO     (input) INTEGER
  IHI     (input) INTEGER
          It is assumed that the matrices A and B are already
          (quasi) upper triangular in rows and columns 1:ILO-1 and
          IHI+1:N. The routine works primarily with the submatrices
          in rows and columns ILO to IHI, but applies the
          transformations to all the rows and columns of the
          matrices A and B, if WANTT = .TRUE..
          1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N.

  ILOQ    (input) INTEGER
  IHIQ    (input) INTEGER
          Specify the rows of Q and Z to which transformations
          must be applied if WANTQ = .TRUE. and WANTZ = .TRUE.,
          respectively.
          1 <= ILOQ <= ILO; IHI <= IHIQ <= N.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the upper Hessenberg matrix A.
          On exit, if WANTT = .TRUE., the leading N-by-N part of
          this array is upper quasi-triangular in rows and columns
          ILO:IHI.
          If WANTT = .FALSE., the diagonal elements and 2-by-2
          diagonal blocks of A will be correct, but the remaining
          parts of A are unspecified on exit.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the upper triangular matrix B.
          On exit, if WANTT = .TRUE., the leading N-by-N part of
          this array contains the transformed upper triangular
          matrix. 2-by-2 blocks in B corresponding to 2-by-2 blocks
          in A will be reduced to positive diagonal form. (I.e., if
          A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j)
          and B(j+1,j+1) will be positive.)
          If WANTT = .FALSE., the elements corresponding to diagonal
          elements and 2-by-2 diagonal blocks in A will be correct,
          but the remaining parts of B are unspecified on exit.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, if WANTQ = .TRUE., then the leading N-by-N part
          of this array must contain the current matrix Q of
          transformations accumulated by MB03XP.
          On exit, if WANTQ = .TRUE., then the leading N-by-N part
          of this array contains the matrix Q updated in the
          submatrix Q(ILOQ:IHIQ,ILO:IHI).
          If WANTQ = .FALSE., Q is not referenced.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= 1.
          If WANTQ = .TRUE., LDQ >= MAX(1,N).

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          On entry, if WANTZ = .TRUE., then the leading N-by-N part
          of this array must contain the current matrix Z of
          transformations accumulated by MB03XP.
          On exit, if WANTZ = .TRUE., then the leading N-by-N part
          of this array contains the matrix Z updated in the
          submatrix Z(ILOQ:IHIQ,ILO:IHI).
          If WANTZ = .FALSE., Z is not referenced.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= 1.
          If WANTZ = .TRUE., LDZ >= MAX(1,N).

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
  BETA    (output) DOUBLE PRECISION array, dimension (N)
          The i-th (ILO <= i <= IHI) computed eigenvalue is given
          by BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two
          eigenvalues are computed as a complex conjugate pair,
          they are stored in consecutive elements of ALPHAR, ALPHAI
          and BETA. If WANTT = .TRUE., the eigenvalues are stored in
          the same order as on the diagonals of the Schur forms of
          A and B.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = -19,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, then MB03YD failed to compute the Schur
                form in a total of 30*(IHI-ILO+1) iterations;
                elements i+1:n of ALPHAR, ALPHAI and BETA contain
                successfully computed eigenvalues.
Method 
  The implemented algorithm is a double-shift version of the
  periodic QR algorithm described in [1,3] with some minor
  modifications [2]. The eigenvalues are computed via an implicit
  complex single shift algorithm.
References 
  [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P.
      The periodic Schur decomposition: Algorithms and applications.
      Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
      1992.

  [2] Kressner, D.
      An efficient and reliable implementation of the periodic QZ
      algorithm. Proc. of the IFAC Workshop on Periodic Control
      Systems, pp. 187-192, 2001.

  [3] Van Loan, C.
      Generalized Singular Values with Algorithms and Applications.
      Ph. D. Thesis, University of Michigan, 1973.
Numerical Aspects 
  The algorithm requires O(N**3) floating point operations and is
  backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB03YT.html000077500000000000000000000077471201767322700161410ustar00rootroot00000000000000 MB03YT - SLICOT Library Routine Documentation

MB03YT

Periodic Schur factorization of a real 2-by-2 matrix pair (A,B) with B upper triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the periodic Schur factorization of a real 2-by-2
  matrix pair (A,B) where B is upper triangular. This routine
  computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
  SNR such that

  1) if the pair (A,B) has two real eigenvalues, then

     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
     [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]

     [ b11 b12 ] := [  CSR  SNR ] [ b11 b12 ] [  CSL -SNL ]
     [  0  b22 ]    [ -SNR  CSR ] [  0  b22 ] [  SNL  CSL ],

  2) if the pair (A,B) has a pair of complex conjugate eigenvalues,
     then

     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
     [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]

     [ b11  0  ] := [  CSR  SNR ] [ b11 b12 ] [  CSL -SNL ]
     [  0  b22 ]    [ -SNR  CSR ] [  0  b22 ] [  SNL  CSL ].

  This is a modified version of the LAPACK routine DLAGV2 for
  computing the real, generalized Schur decomposition of a
  two-by-two matrix pencil.
Specification 
      SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
     $                   CSR, SNR )
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)
Arguments

Input/Output Parameters 

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,2)
          On entry, the leading 2-by-2 part of this array must
          contain the matrix A.
          On exit, the leading 2-by-2 part of this array contains
          the matrix A of the pair in periodic Schur form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= 2.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,2)
          On entry, the leading 2-by-2 part of this array must
          contain the upper triangular matrix B.
          On exit, the leading 2-by-2 part of this array contains
          the matrix B of the pair in periodic Schur form.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= 2.

  ALPHAR  (output) DOUBLE PRECISION array, dimension (2)
  ALPHAI  (output) DOUBLE PRECISION array, dimension (2)
  BETA    (output) DOUBLE PRECISION array, dimension (2)
          (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the
          pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0.

  CSL     (output) DOUBLE PRECISION
          The cosine of the first rotation matrix.

  SNL     (output) DOUBLE PRECISION
          The sine of the first rotation matrix.

  CSR     (output) DOUBLE PRECISION
          The cosine of the second rotation matrix.

  SNR     (output) DOUBLE PRECISION
          The sine of the second rotation matrix.
References 
  [1] Van Loan, C.
      Generalized Singular Values with Algorithms and Applications.
      Ph. D. Thesis, University of Michigan, 1973.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03ZA.html000077500000000000000000000267731201767322700161170ustar00rootroot00000000000000 MB03ZA - SLICOT Library Routine Documentation

MB03ZA

Reordering a selected cluster of eigenvalues of a given matrix pair in periodic Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  1. To compute, for a given matrix pair (A,B) in periodic Schur
     form, orthogonal matrices Ur and Vr so that

         T           [ A11  A12 ]     T           [ B11  B12 ]
       Vr * A * Ur = [          ],  Ur * B * Vr = [          ], (1)
                     [  0   A22 ]                 [  0   B22 ]

     is in periodic Schur form, and the eigenvalues of A11*B11
     form a selected cluster of eigenvalues.

  2. To compute an orthogonal matrix W so that

                T  [  0  -A11 ]       [  R11   R12 ]
               W * [          ] * W = [            ],           (2)
                   [ B11   0  ]       [   0    R22 ]

     where the eigenvalues of R11 and -R22 coincide and have
     positive real part.

  Optionally, the matrix C is overwritten by Ur'*C*Vr.

  All eigenvalues of A11*B11 must either be complex or real and
  negative.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  COMPC   CHARACTER*1
          = 'U':  update the matrix C;
          = 'N':  do not update C.

  COMPU   CHARACTER*1
          = 'U':  update the matrices U1 and U2;
          = 'N':  do not update U1 and U2.
          See the description of U1 and U2.

  COMPV   CHARACTER*1
          = 'U':  update the matrices V1 and V2;
          = 'N':  do not update V1 and V2.
          See the description of V1 and V2.

  COMPW   CHARACTER*1
          Indicates whether or not the user wishes to accumulate
          the matrix W as follows:
          = 'N':  the matrix W is not required;
          = 'I':  W is initialized to the unit matrix and the
                  orthogonal transformation matrix W is returned;
          = 'V':  W must contain an orthogonal matrix Q on entry,
                  and the product Q*W is returned.

  WHICH   CHARACTER*1
          = 'A':  select all eigenvalues, this effectively means
                  that Ur and Vr are identity matrices and A11 = A,
                  B11 = B;
          = 'S':  select a cluster of eigenvalues specified by
                  SELECT.

  SELECT  LOGICAL array, dimension (N)
          If WHICH = 'S', then SELECT specifies the eigenvalues of
          A*B in the selected cluster. To select a real eigenvalue
          w(j), SELECT(j) must be set to .TRUE.. To select a complex
          conjugate pair of eigenvalues w(j) and w(j+1),
          corresponding to a 2-by-2 diagonal block in A, both
          SELECT(j) and SELECT(j+1) must be set to .TRUE.; a complex
          conjugate pair of eigenvalues must be either both included
          in the cluster or both excluded.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the upper quasi-triangular matrix A of the matrix
          pair (A,B) in periodic Schur form.
          On exit, the leading M-by-M part of this array contains
          the matrix R22 in (2).

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the upper triangular matrix B of the matrix pair
          (A,B) in periodic Schur form.
          On exit, the leading N-by-N part of this array is
          overwritten.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, if COMPC = 'U', the leading N-by-N part of this
          array must contain a general matrix C.
          On exit, if COMPC = 'U', the leading N-by-N part of this
          array contains the updated matrix Ur'*C*Vr.
          If COMPC = 'N' or WHICH = 'A', this array is not
          referenced.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= 1.
          LDC >= N,  if COMPC = 'U' and WHICH = 'S'.

  U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
          On entry, if COMPU = 'U' and WHICH = 'S', the leading
          N-by-N part of this array must contain U1, the (1,1)
          block of an orthogonal symplectic matrix
          U = [ U1, U2; -U2, U1 ].
          On exit, if COMPU = 'U' and WHICH = 'S', the leading
          N-by-N part of this array contains U1*Ur.
          If COMPU = 'N' or WHICH = 'A', this array is not
          referenced.

  LDU1    INTEGER
          The leading dimension of the array U1.  LDU1 >= 1.
          LDU1 >= N,  if COMPU = 'U' and WHICH = 'S'.

  U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
          On entry, if COMPU = 'U' and WHICH = 'S', the leading
          N-by-N part of this array must contain U2, the (1,2)
          block of an orthogonal symplectic matrix
          U = [ U1, U2; -U2, U1 ].
          On exit, if COMPU = 'U' and WHICH = 'S', the leading
          N-by-N part of this array contains U2*Ur.
          If COMPU = 'N' or WHICH = 'A', this array is not
          referenced.

  LDU2    INTEGER
          The leading dimension of the array U2.  LDU2 >= 1.
          LDU2 >= N,  if COMPU = 'U' and WHICH = 'S'.

  V1      (input/output) DOUBLE PRECISION array, dimension (LDV1,N)
          On entry, if COMPV = 'U' and WHICH = 'S', the leading
          N-by-N part of this array must contain V1, the (1,1)
          block of an orthogonal symplectic matrix
          V = [ V1, V2; -V2, V1 ].
          On exit, if COMPV = 'U' and WHICH = 'S', the leading
          N-by-N part of this array contains V1*Vr.
          If COMPV = 'N' or WHICH = 'A', this array is not
          referenced.

  LDV1    INTEGER
          The leading dimension of the array V1.  LDV1 >= 1.
          LDV1 >= N,  if COMPV = 'U' and WHICH = 'S'.

  V2      (input/output) DOUBLE PRECISION array, dimension (LDV2,N)
          On entry, if COMPV = 'U' and WHICH = 'S', the leading
          N-by-N part of this array must contain V2, the (1,2)
          block of an orthogonal symplectic matrix
          V = [ V1, V2; -V2, V1 ].
          On exit, if COMPV = 'U' and WHICH = 'S', the leading
          N-by-N part of this array contains V2*Vr.
          If COMPV = 'N' or WHICH = 'A', this array is not
          referenced.

  LDV2    INTEGER
          The leading dimension of the array V2.  LDV2 >= 1.
          LDV2 >= N,  if COMPV = 'U' and WHICH = 'S'.

  W       (input/output) DOUBLE PRECISION array, dimension (LDW,2*M)
          On entry, if COMPW = 'V', then the leading 2*M-by-2*M part
          of this array must contain a matrix W.
          If COMPW = 'I', then W need not be set on entry, W is set
          to the identity matrix.
          On exit, if COMPW = 'I' or 'V' the leading 2*M-by-2*M part
          of this array is post-multiplied by the transformation
          matrix that produced (2).
          If COMPW = 'N', this array is not referenced.

  LDW     INTEGER
          The leading dimension of the array W.  LDW >= 1.
          LDW >= 2*M,  if COMPW = 'I' or COMPW = 'V'.

  WR      (output) DOUBLE PRECISION array, dimension (M)
  WI      (output) DOUBLE PRECISION array, dimension (M)
          The real and imaginary parts, respectively, of the
          eigenvalues of R22. The eigenvalues are stored in the same
          order as on the diagonal of R22, with
          WR(i) = R22(i,i) and, if R22(i:i+1,i:i+1) is a 2-by-2
          diagonal block, WI(i) > 0 and WI(i+1) = -WI(i).
          In exact arithmetic, these eigenvalue are the positive
          square roots of the selected eigenvalues of the product
          A*B. However, if an eigenvalue is sufficiently
          ill-conditioned, then its value may differ significantly.

  M       (output) INTEGER
          The number of selected eigenvalues.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if  INFO = -28,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, 4*N, 8*M ).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  reordering of the product A*B in Step 1 failed
                because some eigenvalues are too close to separate;
          = 2:  reordering of some submatrix in Step 2 failed
                because some eigenvalues are too close to separate;
          = 3:  the QR algorithm failed to compute the Schur form
                of some submatrix in Step 2;
          = 4:  the condition that all eigenvalues of A11*B11 must
                either be complex or real and negative is
                numerically violated.
Method 
  Step 1 is performed using a reordering technique analogous to the
  LAPACK routine DTGSEN for reordering matrix pencils [1,2]. Step 2
  is an implementation of Algorithm 2 in [3]. It requires O(M*N*N)
  floating point operations.
References 
  [1] Kagstrom, B.
      A direct method for reordering eigenvalues in the generalized
      real Schur form of a regular matrix pair (A,B), in M.S. Moonen
      et al (eds), Linear Algebra for Large Scale and Real-Time
      Applications, Kluwer Academic Publ., 1993, pp. 195-218.

  [2] Kagstrom, B. and Poromaa P.:
      Computing eigenspaces with specified eigenvalues of a regular
      matrix pair (A, B) and condition estimation: Theory,
      algorithms and software, Numer. Algorithms, 1996, vol. 12,
      pp. 369-407.

  [3] Benner, P., Mehrmann, V., and Xu, H.
      A new method for computing the stable invariant subspace of a
      real Hamiltonian matrix,  J. Comput. Appl. Math., 86,
      pp. 17-43, 1997.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB03ZD.html000077500000000000000000000577671201767322700161310ustar00rootroot00000000000000 MB03ZD - SLICOT Library Routine Documentation

MB03ZD

Computing the stable and unstable invariant subspaces for a Hamiltonian matrix with no eigenvalues on the imaginary axis

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the stable and unstable invariant subspaces for a
  Hamiltonian matrix with no eigenvalues on the imaginary axis,
  using the output of the SLICOT Library routine MB03XD.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  WHICH   CHARACTER*1
          Specifies the cluster of eigenvalues for which the
          invariant subspaces are computed:
          = 'A':  select all n eigenvalues;
          = 'S':  select a cluster of eigenvalues specified by
                  SELECT.

  METH    CHARACTER*1
          If WHICH = 'A' this parameter specifies the method to be
          used for computing bases of the invariant subspaces:
          = 'S':  compute the n-dimensional basis from a set of
                  n vectors;
          = 'L':  compute the n-dimensional basis from a set of
                  2*n vectors.
          When in doubt, use METH = 'S'. In some cases, METH = 'L'
          may result in more accurately computed invariant
          subspaces, see [1].

  STAB    CHARACTER*1
          Specifies the type of invariant subspaces to be computed:
          = 'S':  compute the stable invariant subspace, i.e., the
                  invariant subspace belonging to those selected
                  eigenvalues that have negative real part;
          = 'U':  compute the unstable invariant subspace, i.e.,
                  the invariant subspace belonging to those
                  selected eigenvalues that have positive real
                  part;
          = 'B':  compute both the stable and unstable invariant
                  subspaces.

  BALANC  CHARACTER*1
          Specifies the type of inverse balancing transformation
          required:
          = 'N':  do nothing;
          = 'P':  do inverse transformation for permutation only;
          = 'S':  do inverse transformation for scaling only;
          = 'B':  do inverse transformations for both permutation
                  and scaling.
          BALANC must be the same as the argument BALANC supplied to
          MB03XD. Note that if the data is further post-processed,
          e.g., for solving an algebraic Riccati equation, it is
          recommended to delay inverse balancing (in particular the
          scaling part) and apply it to the final result only,
          see [2].

  ORTBAL  CHARACTER*1
          If BALANC <> 'N', this option specifies how inverse
          balancing is applied to the computed invariant subspaces:
          = 'B':  apply inverse balancing before orthogonal bases
                  for the invariant subspaces are computed;
          = 'A':  apply inverse balancing after orthogonal bases
                  for the invariant subspaces have been computed;
                  this may yield non-orthogonal bases if
                  BALANC = 'S' or BALANC = 'B'.

  SELECT  (input) LOGICAL array, dimension (N)
          If WHICH = 'S', SELECT specifies the eigenvalues
          corresponding to the positive and negative square
          roots of the eigenvalues of S*T in the selected cluster.
          To select a real eigenvalue w(j), SELECT(j) must be set
          to .TRUE.. To select a complex conjugate pair of
          eigenvalues w(j) and w(j+1), corresponding to a 2-by-2
          diagonal block, both SELECT(j) and SELECT(j+1) must be set
          to .TRUE.; a complex conjugate pair of eigenvalues must be
          either both included in the cluster or both excluded.
          This array is not referenced if WHICH = 'A'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices S, T and G. N >= 0.

  MM      (input) INTEGER
          The number of columns in the arrays US and/or UU.
          If WHICH = 'A' and METH = 'S',  MM >=   N;
          if WHICH = 'A' and METH = 'L',  MM >= 2*N;
          if WHICH = 'S',                 MM >=   M.
          The minimal values above for MM give the numbers of
          vectors to be used for computing a basis for the
          invariant subspace(s).

  ILO     (input) INTEGER
          If BALANC <> 'N', then ILO is the integer returned by
          MB03XD.  1 <= ILO <= N+1.

  SCALE   (input) DOUBLE PRECISION array, dimension (N)
          If BALANC <> 'N', the leading N elements of this array
          must contain details of the permutation and scaling
          factors, as returned by MB03XD.
          This array is not referenced if BALANC = 'N'.

  S       (input/output) DOUBLE PRECISION array, dimension (LDS,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix S in real Schur form.
          On exit, the leading N-by-N part of this array is
          overwritten.

  LDS     INTEGER
          The leading dimension of the array S.  LDS >= max(1,N).

  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
          On entry, the leading N-by-N part of this array must
          contain the upper triangular matrix T.
          On exit, the leading N-by-N part of this array is
          overwritten.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= max(1,N).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, if METH = 'L', the leading N-by-N part of this
          array must contain a general matrix G.
          On exit, if METH = 'L', the leading N-by-N part of this
          array is overwritten.
          This array is not referenced if METH = 'S'.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= 1.
          LDG >= max(1,N) if METH = 'L'.

  U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
          On entry, the leading N-by-N part of this array must
          contain the (1,1) block of an orthogonal symplectic
          matrix U.
          On exit, this array is overwritten.

  LDU1    INTEGER
          The leading dimension of the array U1.  LDU1 >= MAX(1,N).

  U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
          On entry, the leading N-by-N part of this array must
          contain the (2,1) block of an orthogonal symplectic
          matrix U.
          On exit, this array is overwritten.

  LDU2    INTEGER
          The leading dimension of the array U2.  LDU2 >= MAX(1,N).

  V1      (input/output) DOUBLE PRECISION array, dimension (LDV1,N)
          On entry, the leading N-by-N part of this array must
          contain the (1,1) block of an orthogonal symplectic
          matrix V.
          On exit, this array is overwritten.

  LDV1    INTEGER
          The leading dimension of the array V1.  LDV1 >= MAX(1,N).

  V2      (input/output) DOUBLE PRECISION array, dimension (LDV1,N)
          On entry, the leading N-by-N part of this array must
          contain the (2,1) block of an orthogonal symplectic
          matrix V.
          On exit, this array is overwritten.

  LDV2    INTEGER
          The leading dimension of the array V2.  LDV2 >= MAX(1,N).

  M       (output) INTEGER
          The number of selected eigenvalues.

  WR      (output) DOUBLE PRECISION array, dimension (M)
  WI      (output) DOUBLE PRECISION array, dimension (M)
          On exit, the leading M elements of WR and WI contain the
          real and imaginary parts, respectively, of the selected
          eigenvalues that have nonpositive real part. Complex
          conjugate pairs of eigenvalues with real part not equal
          to zero will appear consecutively with the eigenvalue
          having the positive imaginary part first. Note that, due
          to roundoff errors, these numbers may differ from the
          eigenvalues computed by MB03XD.

  US      (output) DOUBLE PRECISION array, dimension (LDUS,MM)
          On exit, if STAB = 'S' or STAB = 'B', the leading 2*N-by-M
          part of this array contains a basis for the stable
          invariant subspace belonging to the selected eigenvalues.
          This basis is orthogonal unless ORTBAL = 'A'.

  LDUS    INTEGER
          The leading dimension of the array US.  LDUS >= 1.
          If STAB = 'S' or STAB = 'B',  LDUS >= 2*N.

  UU      (output) DOUBLE PRECISION array, dimension (LDUU,MM)
          On exit, if STAB = 'U' or STAB = 'B', the leading 2*N-by-M
          part of this array contains a basis for the unstable
          invariant subspace belonging to the selected eigenvalues.
          This basis is orthogonal unless ORTBAL = 'A'.

  LDUU    INTEGER
          The leading dimension of the array UU.  LDUU >= 1.
          If STAB = 'U' or STAB = 'B',  LDUU >= 2*N.
Workspace 
  LWORK   LOGICAL array, dimension (2*N)
          This array is only referenced if WHICH = 'A' and
          METH = 'L'.

  IWORK   INTEGER array, dimension (2*N),
          This array is only referenced if WHICH = 'A' and
          METH = 'L'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -35,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          If WHICH = 'S' or METH = 'S':
             LDWORK >= MAX( 1, 4*M*M + MAX( 8*M, 4*N ) ).
          If WHICH = 'A' and METH = 'L' and
             ( STAB = 'U' or STAB = 'S' ):
             LDWORK >= MAX( 1, 2*N*N + 2*N, 8*N ).
          If WHICH = 'A' and METH = 'L' and STAB = 'B':
             LDWORK >= 8*N + 1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  some of the selected eigenvalues are on or too close
                to the imaginary axis;
          = 2:  reordering of the product S*T in routine MB03ZA
                failed because some eigenvalues are too close to
                separate;
          = 3:  the QR algorithm failed to compute some Schur form
                in MB03ZA;
          = 4:  reordering of the Hamiltonian Schur form in routine
                MB03TD failed because some eigenvalues are too close
                to separate.
Method 
  This is an implementation of Algorithm 1 in [1].
Numerical Aspects 
  The method is strongly backward stable for an embedded
  (skew-)Hamiltonian matrix, see [1]. Although good results have
  been reported if the eigenvalues are not too close to the
  imaginary axis, the method is not backward stable for the original
  Hamiltonian matrix itself.
References 
  [1] Benner, P., Mehrmann, V., and Xu, H.
      A new method for computing the stable invariant subspace of a
      real Hamiltonian matrix, J. Comput. Appl. Math., 86,
      pp. 17-43, 1997.

  [2] Benner, P.
      Symplectic balancing of Hamiltonian matrices.
      SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000.
Further Comments 
  None
Example

Program Text 

*     MB03ZD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 200 )
      INTEGER          LDG, LDRES, LDS, LDT, LDU1, LDU2, LDUS, LDUU,
     $                 LDV1, LDV2, LDWORK
      PARAMETER        ( LDG = NMAX, LDRES = 2*NMAX, LDS = NMAX,
     $                   LDT = NMAX, LDU1 = NMAX, LDU2 = NMAX,
     $                   LDUS = 2*NMAX, LDUU = 2*NMAX, LDV1 = NMAX,
     $                   LDV2 = NMAX, LDWORK = 3*NMAX*NMAX + 7*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      BALANC, METH, ORTBAL, STAB, WHICH
      INTEGER          I, ILO, INFO, J, M, N
*     .. Local Arrays ..
      LOGICAL          LWORK(2*NMAX), SELECT(NMAX)
      INTEGER          IWORK(2*NMAX)
      DOUBLE PRECISION DWORK(LDWORK), G(LDG, NMAX), RES(LDRES,NMAX),
     $                 S(LDS, NMAX), SCALE(NMAX), T(LDT,NMAX),
     $                 U1(LDU1,NMAX), U2(LDU2, NMAX), US(LDUS,2*NMAX),
     $                 UU(LDUU,2*NMAX), V1(LDV1,NMAX), V2(LDV2, NMAX),
     $                 WI(NMAX), WR(NMAX)
*     .. External Functions ..
      EXTERNAL         DLANGE, LSAME
      LOGICAL          LSAME
      DOUBLE PRECISION DLANGE
*     .. External Subroutines ..
      EXTERNAL         MB03ZD
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, ILO, WHICH, METH, STAB, BALANC, ORTBAL
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
*
         IF ( LSAME( WHICH, 'S' ) )
     $      READ ( NIN, FMT = * ) ( SELECT(I), I = 1,N )
         READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( WHICH, 'A' ).AND.LSAME( METH, 'L' ) )
     $      READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( BALANC, 'P' ).OR.LSAME( BALANC, 'S' ).OR.
     $        LSAME( BALANC, 'B' ) )
     $      READ ( NIN, FMT = * ) ( SCALE(I), I = 1,N )
         READ ( NIN, FMT = * ) ( ( U1(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( U2(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( V1(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( V2(I,J), J = 1,N ), I = 1,N )
*
         CALL MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, 2*N,
     $                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 )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20  I = 1, N
               WRITE ( NOUT, FMT = 99996 ) I, WR(I), WI(I)
20          CONTINUE
*
            IF ( LSAME( STAB, 'S' ).OR.LSAME( STAB, 'B' ) ) THEN
               WRITE ( NOUT, FMT = 99995 )
               DO 30  I = 1, 2*N
                  WRITE ( NOUT, FMT = 99993 ) ( US(I,J), J = 1,M )
30             CONTINUE
               IF ( LSAME( ORTBAL, 'B' ).OR.LSAME( BALANC, 'N' ).OR.
     $            LSAME( BALANC, 'P' ) ) THEN
                  CALL DGEMM( 'Transpose', 'No Transpose', M, M, 2*N,
     $                        ONE, US, LDUS, US, LDUS, ZERO, RES,
     $                        LDRES )
                  DO 40  I = 1, M
                     RES(I,I) = RES(I,I) - ONE
40                CONTINUE
                  WRITE ( NOUT, FMT = 99991 ) DLANGE( 'Frobenius', M, M,
     $                    RES, LDRES, DWORK )
               END IF
               CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, ONE,
     $                     US, LDUS, US(N+1,1), LDUS, ZERO, RES, LDRES )
               CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, -ONE,
     $                     US(N+1,1), LDUS, US, LDUS, ONE, RES, LDRES )
               WRITE ( NOUT, FMT = 99990 ) DLANGE( 'Frobenius', M, M,
     $                 RES, LDRES, DWORK )
            END IF
*
            IF ( LSAME( STAB, 'U' ).OR.LSAME( STAB, 'B' ) ) THEN
               WRITE ( NOUT, FMT = 99994 )
               DO 50  I = 1, 2*N
                  WRITE ( NOUT, FMT = 99993 ) ( UU(I,J), J = 1,M )
50             CONTINUE
               IF ( LSAME( ORTBAL, 'B' ).OR.LSAME( BALANC, 'N' ).OR.
     $            LSAME( BALANC, 'P' ) ) THEN
                  CALL DGEMM( 'Transpose', 'No Transpose', M, M, 2*N,
     $                        ONE, UU, LDUU, UU, LDUU, ZERO, RES,
     $                        LDRES )
                  DO 60  I = 1, M
                     RES(I,I) = RES(I,I) - ONE
60                CONTINUE
                  WRITE ( NOUT, FMT = 99989 ) DLANGE( 'Frobenius', M, M,
     $                    RES, LDRES, DWORK )
               END IF
               CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, ONE,
     $                     UU, LDUU, UU(N+1,1), LDUU, ZERO, RES, LDRES )
               CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, -ONE,
     $                     UU(N+1,1), LDUU, UU, LDUU, ONE, RES, LDRES )
               WRITE ( NOUT, FMT = 99988 ) DLANGE( 'Frobenius', M, M,
     $                 RES, LDRES, DWORK )
            END IF
         END IF
      END IF
*
99999 FORMAT (' MB03ZD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03ZD = ',I2)
99997 FORMAT (' The stable eigenvalues are',//'   i',6X,
     $        'WR(i)',6X,'WI(i)',/)
99996 FORMAT (I4,3X,F8.4,3X,F8.4)
99995 FORMAT (/' A basis for the stable invariant subspace is')
99994 FORMAT (/' A basis for the unstable invariant subspace is')
99993 FORMAT (20(1X,F9.3))
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' Orthogonality of US: || US''*US - I ||_F = ',G7.2)
99990 FORMAT (/' Symplecticity of US: || US''*J*US   ||_F = ',G7.2)
99989 FORMAT (/' Orthogonality of UU: || UU''*UU - I ||_F = ',G7.2)
99988 FORMAT (/' Symplecticity of UU: || UU''*J*UU   ||_F = ',G7.2)

      END
Program Data 
MB03ZD EXAMPLE PROGRAM DATA
	5	1	A	L	B	N	B
 -3.1844761777714732  0.1612357243439331 -0.0628592203751138  0.2449004200921981  0.1974400149992579
  0.0000000000000000 -0.1510667773167784  0.4260444411622838 -0.1775026035208615  0.3447278421198472
  0.0000000000000000 -0.1386140422054264 -0.3006779624777515  0.2944143257134196  0.3456440339120323
  0.0000000000000000  0.0000000000000000  0.0000000000000000 -0.2710128384740570  0.0933189808067138
  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.4844146572359603  0.2004347508746697
  3.2038208121776366  0.1805955192510651  0.2466389119377561 -0.2539149302433368 -0.0359238844381195
  0.0000000000000000 -0.7196686433290816  0.0000000000000000  0.2428659121580384 -0.0594190100670832
  0.0000000000000000  0.0000000000000000 -0.1891741194498107 -0.3309578443491266 -0.0303520731950515
  0.0000000000000000  0.0000000000000000  0.0000000000000000 -0.4361574461961550  0.0000000000000000
  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.1530894573304220
 -0.0370982242678464  0.0917788436945724 -0.0560402416315252  0.1345152517579192  0.0256668227276700
  0.0652183678916931 -0.0700457231988297  0.0350041175858839 -0.2233868768749268 -0.1171980260782843
 -0.0626428681377119  0.2327575351902772 -0.1251515732208170 -0.0177816046663201  0.3696921118421182
  0.0746042309265599 -0.0828007611045140  0.0217427473546043 -0.1157775118548851 -0.3161183681200527
  0.1374372236164812  0.1002727885506992  0.4021556774753973 -0.0431072263235579  0.1067394572547867
  0.3806883009357247 -0.0347810363019649 -0.5014665065895758  0.5389691288472394  0.2685446895251367
  0.4642712665555326 -0.5942766860716395  0.4781179763952615  0.2334370556238151  0.0166790369048933
  0.2772789197782788 -0.0130145392695876 -0.2123817030594055 -0.2550292626960107 -0.5049268366774490
  0.4209268575081796  0.1499593172661228 -0.1925590746592156 -0.5472292877802402  0.4543329704184054
  0.3969669479129449  0.6321903535930828  0.3329156356041961  0.0163533225344433 -0.2638879466190024
 -0.1795922007470742  0.1908329820840911  0.0868799433942070  0.3114741142062388 -0.2579907627915167
 -0.2447897730222852 -0.1028403314750045 -0.1157840914576285 -0.1873268885694406  0.1700708002861580
 -0.2243335325285328  0.3180998613802520  0.3315380214794822  0.1977859924739963  0.5072476567310013
 -0.2128397588651423 -0.2740560593051881  0.1941418870268881 -0.3096684962457369 -0.0581576193198714
 -0.2002027567371932 -0.0040094115506855 -0.3979373387545264  0.1520881534833910 -0.2010804514091372
  0.4447147692018334 -0.6830166755147440 -0.0002576861753487  0.5781954611783305 -0.0375091627893805
  0.5121756358795817  0.0297197140254773  0.4332229148788766 -0.3240527006890552  0.5330850295256511
  0.3664711365265602  0.3288511296455119  0.0588396016404451  0.1134221597062257  0.1047567336850078
  0.4535357098437908  0.1062866148880792 -0.3964092656837774 -0.2211800890450674  0.0350667323996222
  0.4450432900616097  0.2950206358263853 -0.1617837757183893 -0.0376369332204927 -0.6746752660482623
  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000  0.0000000000000000
  0.0299719306696789 -0.2322624725320701 -0.0280846899680325 -0.3044255686880000 -0.1077641482535519
 -0.0069083614679702  0.3351358347080056 -0.4922707032978891  0.4293545450291714  0.4372821269062001
  0.0167847133528843  0.2843629278945327  0.5958979805231146  0.3097336757510886 -0.2086733033047188
  0.0248567764822071 -0.2810759958040470 -0.1653113624869834 -0.3528780198620412 -0.0254898556119252
Program Results 
MB03ZD EXAMPLE PROGRAM RESULTS

The stable eigenvalues are

  i      WR(i)      WI(i)

  1    -3.1941     0.0000
  2    -0.1350     0.3179
  3    -0.1350    -0.3179
  4    -0.0595     0.2793
  5    -0.0595    -0.2793

A basis for the stable invariant subspace is
   -0.102    -0.116     0.627     0.118    -0.605
   -0.100    -0.510    -0.266     0.504     0.124
   -0.179     0.015    -0.112    -0.142     0.413
   -0.055     0.252     0.182    -0.134     0.100
   -0.078     0.576    -0.271    -0.252    -0.177
    0.340    -0.135     0.053    -0.234    -0.110
    0.528     0.108    -0.205     0.219    -0.096
    0.397    -0.429     0.161    -0.598     0.199
    0.444     0.342     0.447     0.406     0.440
    0.434     0.014    -0.383     0.072    -0.391

Orthogonality of US: || US'*US - I ||_F = .62E-15

Symplecticity of US: || US'*J*US   ||_F = .23E-14

A basis for the unstable invariant subspace is
   -0.428     0.383     0.048     0.105     0.187
   -0.506    -0.100     0.541     0.245     0.223
   -0.334    -0.524    -0.044    -0.153     0.126
   -0.453     0.076     0.103    -0.525    -0.268
   -0.436     0.098    -0.752     0.209    -0.251
   -0.093    -0.089     0.258    -0.114    -0.725
   -0.112    -0.196    -0.186    -0.302     0.394
   -0.120    -0.286     0.027     0.680    -0.119
   -0.102     0.630     0.079     0.040     0.127
   -0.091    -0.171    -0.136    -0.136     0.231

Orthogonality of UU: || UU'*UU - I ||_F = .69E-15

Symplecticity of UU: || UU'*J*UU   ||_F = .10E-13

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04AD.html000077500000000000000000000617351201767322700160670ustar00rootroot00000000000000 MB04AD - SLICOT Library Routine Documentation

MB04AD

Eigenvalues of a real skew-Hamiltonian/Hamiltonian pencil in factored form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of a real N-by-N skew-Hamiltonian/
  Hamiltonian pencil aS - bH with

                                   (  0  I  )
    S = T Z = J Z' J' Z, where J = (        ),                   (1)
                                   ( -I  0  )

  via generalized symplectic URV decomposition. That is, orthogonal
  matrices Q1 and Q2 and orthogonal symplectic matrices U1 and U2
  are computed such that

                                (  T11  T12 )
    Q1' T U1 = Q1' J Z' J' U1 = (           ) = Tout,
                                (   0   T22 )

               (  Z11  Z12 )
    U2' Z Q2 = (           ) = Zout,                             (2)
               (   0   Z22 )

               ( H11  H12 )
    Q1' H Q2 = (          ) = Hout,
               (  0   H22 )

  where T11, T22', Z11, Z22', H11 are upper triangular and H22' is
  upper quasi-triangular.
  Optionally, if COMPQ1 = 'C' the orthogonal transformation matrix
  Q1 will be computed.
  Optionally, if COMPQ2 = 'C' the orthogonal transformation matrix
  Q2 will be computed.
  Optionally, if COMPU1 = 'C' the orthogonal symplectic
  transformation matrix

         (  U11  U12  )
    U1 = (            )
         ( -U12  U11  )

  will be computed.
  Optionally, if COMPU2 = 'C' the orthogonal symplectic
  transformation matrix

         (  U21  U22  )
    U2 = (            )
         ( -U22  U21  )

  will be computed.
Specification 
      SUBROUTINE MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ,
     $                   H, LDH, T, LDT, Q1, LDQ1, Q2, LDQ2, U11, LDU11,
     $                   U12, LDU12, U21, LDU21, U22, LDU22, ALPHAR,
     $                   ALPHAI, BETA, IWORK, LIWORK, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ1, COMPQ2, COMPU1, COMPU2, JOB
      INTEGER            INFO, LDH, LDQ1, LDQ2, LDT, LDU11, LDU12,
     $                   LDU21, LDU22, LDWORK, LDZ, LIWORK, N
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), BETA( * ),
     $                   DWORK( * ), H( LDH, * ), Q1( LDQ1, * ),
     $                   Q2( LDQ2, * ), T( LDT, * ), U11( LDU11, * ),
     $                   U12( LDU12, * ), U21( LDU21, * ),
     $                   U22( LDU22, * ), Z( LDZ, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'E': compute the eigenvalues only; Z, T, and H will not
                 necessarily be put into the forms in (2); H22' is
                 upper Hessenberg;
          = 'T': put Z, T, and H into the forms in (2), and return
                 the eigenvalues in ALPHAR, ALPHAI and BETA.

  COMPQ1  CHARACTER*1
          Specifies whether to compute the orthogonal transformation
          matrix Q1, as follows:
          = 'N': Q1 is not computed;
          = 'C': compute the matrix Q1 of the orthogonal
                 transformations applied on the left to the pencil
                 aTZ - bH to reduce its matrices to the form (2).
                 The array Q1 is initialized internally to the
                 identity matrix.

  COMPQ2  CHARACTER*1
          Specifies whether to compute the orthogonal transformation
          matrix Q2, as follows:
          = 'N': Q2 is not computed;
          = 'C': compute the matrix Q2 of the orthogonal
                 transformations applied on the right to the pencil
                 aTZ - bH to reduce its matrices to the form (2).
                 The array Q2 is initialized internally to the
                 identity matrix.

  COMPU1  CHARACTER*1
          Specifies whether to compute the orthogonal symplectic
          transformation matrix U1, as follows:
          = 'N': U1 is not computed;
          = 'C': compute the matrices U11 and U12 of the orthogonal
                 symplectic transformations applied to the pencil
                 aTZ - bT to reduce its matrices to the form (2).
                 The arrays U11 and U12 are initialized internally
                 to correspond to an identity matrix U1.

  COMPU2  CHARACTER*1
          Specifies whether to compute the orthogonal symplectic
          transformation matrix U2, as follows:
          = 'N': U2 is not computed;
          = 'C': compute the matrices U21 and U22 of the orthogonal
                 symplectic transformations applied to the pencil
                 aTZ - bT to reduce its matrices to the form (2).
                 The arrays U21 and U22 are initialized internally
                 to correspond to an identity matrix U2.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the pencil aS - bH.  N >= 0, even.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
          On entry, the leading N-by-N part of this array must
          contain the matrix Z.
          On exit, if JOB = 'T', the leading N-by-N part of this
          array contains the matrix Zout; otherwise, it contains the
          matrix Z obtained just before the application of the
          periodic QZ algorithm.
          The elements of the (2,1) block, i.e., in the rows N/2+1
          to N and in the columns 1 to N/2 are not set to zero, but
          are unchanged on exit.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= MAX(1, N).

  H       (input/output) DOUBLE PRECISION array, dimension (LDH, N)
          On entry, the leading N-by-N part of this array must
          contain the Hamiltonian matrix H (H22 = -H11', H12 = H12',
          H21 = H21').
          On exit, if JOB = 'T', the leading N-by-N part of this
          array contains the matrix Hout; otherwise, it contains the
          matrix H obtained just before the application of the
          periodic QZ algorithm.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= MAX(1, N).

  T       (output) DOUBLE PRECISION array, dimension (LDT, N)
          If JOB = 'T', the leading N-by-N part of this array
          contains the matrix Tout; otherwise, it contains the
          matrix T obtained just before the application of the
          periodic QZ algorithm.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= MAX(1, N).

  Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N)
          On exit, if COMPQ1 = 'C', the leading N-by-N part of this
          array contains the orthogonal transformation matrix Q1.
          If COMPQ1 = 'N', this array is not referenced.

  LDQ1    INTEGER
          The leading dimension of the array Q1.
          LDQ1 >= 1,         if COMPQ1 = 'N';
          LDQ1 >= MAX(1, N), if COMPQ1 = 'C'.

  Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
          On exit, if COMPQ2 = 'C', the leading N-by-N part of this
          array contains the orthogonal transformation matrix Q2.
          If COMPQ2 = 'N', this array is not referenced.

  LDQ2    INTEGER
          The leading dimension of the array Q2.
          LDQ2 >= 1,         if COMPQ2 = 'N';
          LDQ2 >= MAX(1, N), if COMPQ2 = 'C'.

  U11     (output) DOUBLE PRECISION array, dimension (LDU11, N/2)
          On exit, if COMPU1 = 'C', the leading N/2-by-N/2 part of
          this array contains the upper left block U11 of the
          orthogonal symplectic transformation matrix U1.
          If COMPU1 = 'N', this array is not referenced.

  LDU11   INTEGER
          The leading dimension of the array U11.
          LDU11 >= 1,           if COMPU1 = 'N';
          LDU11 >= MAX(1, N/2), if COMPU1 = 'C'.

  U12     (output) DOUBLE PRECISION array, dimension (LDU12, N/2)
          On exit, if COMPU1 = 'C', the leading N/2-by-N/2 part of
          this array contains the upper right block U12 of the
          orthogonal symplectic transformation matrix U1.
          If COMPU1 = 'N', this array is not referenced.

  LDU12   INTEGER
          The leading dimension of the array U12.
          LDU12 >= 1,           if COMPU1 = 'N';
          LDU12 >= MAX(1, N/2), if COMPU1 = 'C'.

  U21     (output) DOUBLE PRECISION array, dimension (LDU21, N/2)
          On exit, if COMPU2 = 'C', the leading N/2-by-N/2 part of
          this array contains the upper left block U21 of the
          orthogonal symplectic transformation matrix U2.
          If COMPU2 = 'N', this array is not referenced.

  LDU21   INTEGER
          The leading dimension of the array U21.
          LDU21 >= 1,           if COMPU2 = 'N';
          LDU21 >= MAX(1, N/2), if COMPU2 = 'C'.

  U22     (output) DOUBLE PRECISION array, dimension (LDU22, N/2)
          On exit, if COMPU2 = 'C', the leading N/2-by-N/2 part of
          this array contains the upper right block U22 of the
          orthogonal symplectic transformation matrix U2.
          If COMPU2 = 'N', this array is not referenced.

  LDU22   INTEGER
          The leading dimension of the array U22.
          LDU22 >= 1,           if COMPU2 = 'N';
          LDU22 >= MAX(1, N/2), if COMPU2 = 'C'.

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
          The real parts of each scalar alpha defining an eigenvalue
          of the pencil aS - bH.

  ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
          The imaginary parts of each scalar alpha defining an
          eigenvalue of the pencil aS - bH.
          If ALPHAI(j) is zero, then the j-th eigenvalue is real.

  BETA    (output) DOUBLE PRECISION array, dimension (N/2)
          The scalars beta defining the eigenvalues of the pencil
          aS - bH.
          If INFO = 0, the quantities alpha = (ALPHAR(j),ALPHAI(j)),
          and beta = BETA(j) represent together the j-th eigenvalue
          of the pencil aS - bH, in the form lambda = alpha/beta.
          Since lambda may overflow, the ratios should not, in
          general, be computed. Due to the skew-Hamiltonian/
          Hamiltonian structure of the pencil, only half of the
          spectrum is saved in ALPHAR, ALPHAI and BETA.
          Specifically, the eigenvalues with positive real parts or
          with non-negative imaginary parts, when real parts are
          zero, are returned. The remaining eigenvalues have
          opposite signs.
          If INFO = 3, one or more BETA(j) is not representable, and
          the eigenvalues are returned as described below.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          On exit, if INFO = 3, IWORK(1), ..., IWORK(N/2) return the
          scaling parameters for the eigenvalues of the pencil
          aS - bH (see INFO = 3).

  LIWORK  INTEGER
          The dimension of the array IWORK.
          LIWORK >= N/2+18.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and DWORK(2) returns the machine base, b.
          On exit, if INFO = -31, DWORK(1) returns the minimum value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N' and
          COMPU1 = 'N' and COMPU2 = 'N', then
                LDWORK >= 3/2*N**2+MAX(N, 48);
          else, LDWORK >=   3*N**2+MAX(N, 48).
          For good performance LDWORK should generally be larger.

          If LDWORK = -1, then a workspace query is assumed; the
          routine only calculates the optimal size of the DWORK
          array, returns this value as the first entry of the DWORK
          array, and no error message related to LDWORK is issued by
          XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit.
          < 0: if INFO = -i, the i-th argument had an illegal value.
          = 1: the periodic QZ algorithm was not able to reveal
               information about the eigenvalues from the 2-by-2
               blocks in the SLICOT Library routine MB03BD;
          = 2: the periodic QZ algorithm did not converge in the
               SLICOT Library routine MB03BD;
          = 3: the eigenvalues will under- or overflow if evaluated;
               therefore, the j-th eigenvalue is represented by
               the quantities alpha = (ALPHAR(j),ALPHAI(j)),
               beta = BETA(j), and gamma = IWORK(j) in the form
               lambda = (alpha/beta) * b**gamma, where b is the
               machine base (often 2.0). This is not an error.
Method 
  The algorithm uses Givens rotations and Householder reflections to
  annihilate elements in T, Z, and H such that T11, T22', Z11, Z22'
  and H11 are upper triangular and H22' is upper Hessenberg. Finally
  the periodic QZ algorithm is applied to transform H22' to upper
  quasi-triangular form while T11, T22', Z11, Z22', and H11 stay in
  upper triangular form.
  See also page 17 in [1] for more details.
References 
  [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
                                                            3
  The algorithm is numerically backward stable and needs O(N ) real
  floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB04AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            NMAX
      PARAMETER          ( NMAX = 50 )
      INTEGER            LDH, LDQ1, LDQ2, LDT, LDU11, LDU12, LDU21,
     $                   LDU22, LDWORK, LDZ, LIWORK
      PARAMETER          ( LDH = NMAX, LDQ1  = NMAX,   LDQ2 = NMAX,
     $                     LDT = NMAX, LDU11 = NMAX/2, LDU12 = NMAX/2,
     $                     LDU21  = NMAX/2, LDU22 = NMAX/2,
     $                     LDWORK = 3*NMAX*NMAX + MAX( NMAX, 48 ),
     $                     LDZ = NMAX,  LIWORK = NMAX/2 + 18 )
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ1, COMPQ2, COMPU1, COMPU2, JOB
      INTEGER            I, INFO, J, M, N
*
*     .. Local Arrays ..
      INTEGER            IWORK( LIWORK )
      DOUBLE PRECISION   ALPHAI( NMAX/2 ), ALPHAR( NMAX/2 ),
     $                   BETA( NMAX/2 ), DWORK( LDWORK ),
     $                   H( LDH, NMAX ), Q1( LDQ1, NMAX ),
     $                   Q2( LDQ2, NMAX ), T( LDT, NMAX ),
     $                   U11( LDU11, NMAX/2 ), U12( LDU12, NMAX/2 ),
     $                   U21( LDU21, NMAX/2 ), U22( LDU22, NMAX/2 ),
     $                   Z( LDZ, NMAX )
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           DLASET, MB04AD
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N
      IF( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         READ( NIN, FMT = * ) ( ( Z( I, J ), J = 1, N ), I = 1, N )
         READ( NIN, FMT = * ) ( ( H( I, J ), J = 1, N ), I = 1, N )
*        Compute the eigenvalues of a real skew-Hamiltonian/Hamiltonian
*        pencil (factored version).
         CALL MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ, H,
     $                LDH, T, LDT, Q1, LDQ1, Q2, LDQ2, U11, LDU11, U12,
     $                LDU12, U21, LDU21, U22, LDU22, ALPHAR, ALPHAI,
     $                BETA, IWORK, LIWORK, DWORK, LDWORK, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE
            M = N/2
            CALL DLASET( 'Full', M, M, ZERO, ZERO, Z( M+1, 1 ), LDZ )
            WRITE( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( T( I, J ), J = 1, N )
   10       CONTINUE
            WRITE( NOUT, FMT = 99994 )
            DO 20 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( Z( I, J ), J = 1, N )
   20       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            DO 30 I = 1, N
               WRITE( NOUT, FMT = 99995 ) ( H( I, J ), J = 1, N )
   30       CONTINUE
            IF( LSAME( COMPQ1, 'C' ) ) THEN
               WRITE( NOUT, FMT = 99992 )
               DO 40 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( Q1( I, J ), J = 1, N )
   40          CONTINUE
            END IF
            IF( LSAME( COMPQ2, 'C' ) ) THEN
               WRITE( NOUT, FMT = 99991 )
               DO 50 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( Q2( I, J ), J = 1, N )
   50          CONTINUE
            END IF
            IF( LSAME( COMPU1, 'C' ) ) THEN
               WRITE( NOUT, FMT = 99990 )
               DO 60 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U11( I, J ), J = 1, M )
   60          CONTINUE
               WRITE( NOUT, FMT = 99989 )
               DO 70 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U12( I, J ), J = 1, M )
   70          CONTINUE
            END IF
            IF( LSAME( COMPU2, 'C' ) ) THEN
               WRITE( NOUT, FMT = 99988 )
               DO 80 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U21( I, J ), J = 1, M )
   80          CONTINUE
               WRITE( NOUT, FMT = 99987 )
               DO 90 I = 1, M
                  WRITE( NOUT, FMT = 99995 ) ( U22( I, J ), J = 1, M )
   90          CONTINUE
            END IF
            WRITE( NOUT, FMT = 99986 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M )
            WRITE( NOUT, FMT = 99985 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M )
            WRITE( NOUT, FMT = 99984 )
            WRITE( NOUT, FMT = 99995 ) (   BETA( I ), I = 1, M )
         END IF
      END IF
      STOP
* 
99999 FORMAT( 'MB04AD EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT( 'INFO on exit from MB04AD = ', I2 )
99996 FORMAT( 'The matrix T on exit is ' )
99995 FORMAT( 50( 1X, F8.4 ) )
99994 FORMAT( 'The matrix Z on exit is ' )
99993 FORMAT( 'The matrix H is ' )
99992 FORMAT( 'The matrix Q1 is ' )
99991 FORMAT( 'The matrix Q2 is ' )
99990 FORMAT( 'The upper left block of the matrix U1 is ' )
99989 FORMAT( 'The upper right block of the matrix U1 is ' )
99988 FORMAT( 'The upper left block of the matrix U2 is ' )
99987 FORMAT( 'The upper right block of the matrix U2 is ' )
99986 FORMAT( 'The vector ALPHAR is ' )
99985 FORMAT( 'The vector ALPHAI is ' )
99984 FORMAT( 'The vector BETA is ' )
      END
Program Data 
MB04AD EXAMPLE PROGRAM DATA
   T   C   C   C   C   8
   3.1472    4.5751   -0.7824    1.7874   -2.2308   -0.6126    2.0936    4.5974
   4.0579    4.6489    4.1574    2.5774   -4.5383   -1.1844    2.5469   -1.5961
  -3.7301   -3.4239    2.9221    2.4313   -4.0287    2.6552   -2.2397    0.8527
   4.1338    4.7059    4.5949   -1.0777    3.2346    2.9520    1.7970   -2.7619
   1.3236    4.5717    1.5574    1.5548    1.9483   -3.1313    1.5510    2.5127
  -4.0246   -0.1462   -4.6429   -3.2881   -1.8290   -0.1024   -3.3739   -2.4490
  -2.2150    3.0028    3.4913    2.0605    4.5022   -0.5441   -3.8100    0.0596
   0.4688   -3.5811    4.3399   -4.6817   -4.6555    1.4631   -0.0164    1.9908
   3.9090   -3.5071    3.1428   -3.0340   -1.4834    3.7401   -0.1715    0.4026
   4.5929   -2.4249   -2.5648   -2.4892    3.7401   -2.1416    1.6251    2.6645
   0.4722    3.4072    4.2926    1.1604   -0.1715    1.6251   -4.2415   -0.0602
  -3.6138   -2.4572   -1.5002   -0.2671    0.4026    2.6645   -0.0602   -3.7009
   0.6882   -1.8421   -4.1122    0.1317   -3.9090   -4.5929   -0.4722    3.6138
  -1.8421    2.9428   -0.4340    1.3834    3.5071    2.4249   -3.4072    2.4572
  -4.1122   -0.4340   -2.3703    0.5231   -3.1428    2.5648   -4.2926    1.5002
   0.1317    1.3834    0.5231   -4.1618    3.0340    2.4892   -1.1604    0.2671
Program Results 
MB04AD EXAMPLE PROGRAM RESULTS
The matrix T on exit is 
  -3.9699   3.7658   5.5815  -1.7750  -0.8818  -0.0511  -4.2158   1.9054
   0.0000   5.3686  -5.9166   4.9163   1.3839   0.8870   3.9458  -4.9167
   0.0000   0.0000   5.9641   1.9432  -2.0680   2.4402  -1.4091   5.8512
   0.0000   0.0000   0.0000   5.9983  -3.8172   4.0147  -2.0739  -1.2570
   0.0000   0.0000   0.0000   0.0000   8.2005   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   1.5732   8.0098   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   0.6017   2.4397   5.9751   0.0000
   0.0000   0.0000   0.0000   0.0000  -2.5869   0.5598   0.2544   5.2129
The matrix Z on exit is 
  -6.4705  -2.5511  -4.0551  -1.9895  -2.7642   0.7532  -4.1047  -2.2046
   0.0000   7.3589  -4.4480  -2.7491  -1.5465  -1.4345  -0.9272   1.3121
   0.0000   0.0000   4.9125  -0.4968   5.3574   3.8579   5.2547  -1.7324
   0.0000   0.0000   0.0000   9.0822   0.0460  -0.3382   3.9302   3.1084
   0.0000   0.0000   0.0000   0.0000   6.1869   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   5.5573   6.6549   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   2.7456  -3.5789   4.3432   0.0000
   0.0000   0.0000   0.0000   0.0000   0.1549   3.5335   3.1346   4.1062
The matrix H is 
  -7.4834   0.4404   2.3558   1.6724  -0.4630   1.9533   1.5724  -2.7254
   0.0000  -7.3500   3.7414   3.7466   0.2837   0.6849   0.7727  -4.2140
   0.0000   0.0000  -2.3493  -3.7994  -0.6872   1.1773  -2.6901  -5.1494
   0.0000   0.0000   0.0000  -3.4719   5.3322   0.4182   1.9779   1.5175
   0.0000   0.0000   0.0000   0.0000  -6.1880   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000  -3.3324   9.0833   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000  -1.8703   0.0799  -2.8180   0.0000
   0.0000   0.0000   0.0000   0.0000  -2.3477   3.3110   0.6561   0.7281
The matrix Q1 is 
  -0.2489  -0.1409   0.3615   0.6458   0.0113   0.6063  -0.0470   0.0238
  -0.2436   0.1294  -0.0874  -0.4103   0.3408   0.3628  -0.3267   0.6272
  -0.4316  -0.2352   0.5553  -0.2811  -0.2198  -0.2880  -0.4564  -0.1773
   0.1992  -0.2176  -0.5198   0.1561  -0.1523   0.1299  -0.7281  -0.2197
   0.0161   0.7390   0.1125  -0.2226  -0.1003   0.3608  -0.1118  -0.4886
  -0.5824   0.0984  -0.3052   0.1996   0.5889  -0.2442   0.0060  -0.3341
  -0.3246   0.4661  -0.1835   0.3523  -0.5153  -0.3034  -0.0865   0.3931
  -0.4559  -0.2961  -0.3790  -0.3127  -0.4356   0.3452   0.3642  -0.1467
The matrix Q2 is 
   0.0288  -0.1842  -0.6791  -0.2115  -0.4790   0.4212  -0.0417  -0.2253
  -0.0666  -0.0787  -0.3711   0.1737  -0.0482  -0.5770  -0.6785   0.1607
   0.1506   0.6328   0.0518  -0.6266   0.0652  -0.0790  -0.2854  -0.2994
  -0.2900  -0.2737  -0.0076  -0.3671  -0.2017  -0.6241   0.4521  -0.2675
   0.3353   0.4107   0.0326   0.1400  -0.6447  -0.2043   0.2561   0.4187
   0.0905  -0.1648  -0.2363  -0.5323   0.3180   0.0286   0.1252   0.7126
  -0.7246   0.0468   0.3328  -0.1794  -0.3639   0.2257  -0.2623   0.2786
   0.4922  -0.5353   0.4803  -0.2501  -0.2723   0.0199  -0.3194  -0.0371
The upper left block of the matrix U1 is 
   0.4144   0.2249   0.6015  -0.1964
  -0.0198   0.5131  -0.2823  -0.3058
  -0.6620   0.1508   0.2237   0.0240
  -0.0743  -0.4323  -0.0332  -0.7263
The upper right block of the matrix U1 is 
  -0.3474   0.1306  -0.3391  -0.3530
  -0.3760   0.1550   0.6087  -0.1646
   0.1707   0.6553  -0.1262  -0.1177
   0.3048  -0.0773   0.0767  -0.4173
The upper left block of the matrix U2 is 
   0.1403  -0.6447  -0.6536  -0.3707
   0.7069   0.2609  -0.0091  -0.1702
  -0.1218  -0.1120   0.3766  -0.5154
   0.0773   0.6349  -0.5070  -0.1810
The upper right block of the matrix U2 is 
   0.0000   0.0000   0.0000   0.0000
   0.1182   0.1587   0.1930  -0.5716
   0.6051  -0.2720   0.3364   0.1089
   0.2823  -0.0386  -0.1529   0.4434
The vector ALPHAR is 
   0.0000   0.7122   0.0000   0.7450
The vector ALPHAI is 
   0.7540   0.0000   0.7465   0.0000
The vector BETA is 
   4.0000   4.0000   8.0000  16.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04BD.html000077500000000000000000000551761201767322700160720ustar00rootroot00000000000000 MB04BD - SLICOT Library Routine Documentation

MB04BD

Eigenvalues of a real skew-Hamiltonian/Hamiltonian pencil

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the eigenvalues of a real N-by-N skew-Hamiltonian/
  Hamiltonian pencil aS - bH with

        (  A  D  )         (  C  V  )
    S = (        ) and H = (        ).                           (1)
        (  E  A' )         (  W -C' )

  Optionally, if JOB = 'T', decompositions of S and H will be
  computed via orthogonal transformations Q1 and Q2 as follows:

                    (  Aout  Dout  )
    Q1' S J Q1 J' = (              ),
                    (   0    Aout' )

                    (  Bout  Fout  )
    J' Q2' J S Q2 = (              ) =: T,                       (2)
                    (   0    Bout' )

               (  C1out  Vout  )            (  0  I  )
    Q1' H Q2 = (               ), where J = (        )
               (  0     C2out' )            ( -I  0  )

  and Aout, Bout, C1out are upper triangular, C2out is upper quasi-
  triangular and Dout and Fout are skew-symmetric. The notation M'
  denotes the transpose of the matrix M.
  Optionally, if COMPQ1 = 'I', the orthogonal transformation matrix
  Q1 will be computed.
  Optionally, if COMPQ2 = 'I', the orthogonal transformation matrix
  Q2 will be computed.
Specification 
      SUBROUTINE MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1,
     $                   LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F,
     $                   LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK,
     $                   LIWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ1, COMPQ2, JOB
      INTEGER            INFO, LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1,
     $                   LDQ2, LDVW, LDWORK, LIWORK, N
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), C1( LDC1, * ),
     $                   C2( LDC2, * ), DE( LDDE, * ), DWORK( * ),
     $                   F( LDF, * ), Q1( LDQ1, * ), Q2( LDQ2, * ),
     $                   VW( LDVW, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'E': compute the eigenvalues only; S and H will not
                 necessarily be transformed as in (2).
          = 'T': put S and H into the forms in (2) and return the
                 eigenvalues in ALPHAR, ALPHAI and BETA.

  COMPQ1  CHARACTER*1
          Specifies whether to compute the orthogonal transformation
          matrix Q1, as follows:
          = 'N':  Q1 is not computed;
          = 'I':  the array Q1 is initialized internally to the unit
                  matrix, and the orthogonal matrix Q1 is returned;
          = 'U':  the array Q1 contains an orthogonal matrix Q on
                  entry, and the product Q*Q1 is returned, where Q1
                  is the product of the orthogonal transformations
                  that are applied to the pencil aS - bH to reduce
                  S and H to the forms in (2), for COMPQ1 = 'I'.

  COMPQ2  CHARACTER*1
          Specifies whether to compute the orthogonal transformation
          matrix Q2, as follows:
          = 'N':  Q2 is not computed;
          = 'I':  on exit, the array Q2 contains the orthogonal
                  matrix Q2;
          = 'U':  on exit, the array Q2 contains the matrix product
                  J*Q*J'*Q2, where Q2 is the product of the
                  orthogonal transformations that are applied to
                  the pencil aS - bH to reduce S and H to the forms
                  in (2), for COMPQ2 = 'I'.
                  Setting COMPQ2 <> 'N' assumes COMPQ2 = COMPQ1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the pencil aS - bH.  N has to be even.

  A       (input/output) DOUBLE PRECISION array, dimension
                         (LDA, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the matrix A.
          On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
          array contains the matrix Aout; otherwise, it contains the
          upper triangular matrix A obtained just before the
          application of the periodic QZ algorithm.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1, N/2).

  DE      (input/output) DOUBLE PRECISION array, dimension
                         (LDDE, N/2+1)
          On entry, the leading N/2-by-N/2 strictly lower triangular
          part of this array must contain the strictly lower
          triangular part of the skew-symmetric matrix E, and the
          N/2-by-N/2 strictly upper triangular part of the submatrix
          in the columns 2 to N/2+1 of this array must contain the
          strictly upper triangular part of the skew-symmetric
          matrix D.
          The entries on the diagonal and the first superdiagonal of
          this array need not be set, but are assumed to be zero.
          On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
          upper triangular part of the submatrix in the columns
          2 to N/2+1 of this array contains the strictly upper
          triangular part of the skew-symmetric matrix Dout.
          If JOB = 'E', the leading N/2-by-N/2 strictly upper
          triangular part of the submatrix in the columns 2 to N/2+1
          of this array contains the strictly upper triangular part
          of the skew-symmetric matrix D just before the application
          of the periodic QZ algorithm. The remaining entries are
          meaningless.

  LDDE    INTEGER
          The leading dimension of the array DE.
          LDDE >= MAX(1, N/2).

  C1      (input/output) DOUBLE PRECISION array, dimension
                        (LDC1, N/2)
          On entry, the leading N/2-by-N/2 part of this array must
          contain the matrix C1 = C.
          On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
          array contains the matrix C1out; otherwise, it contains the
          upper triangular matrix C1 obtained just before the
          application of the periodic QZ algorithm.

  LDC1    INTEGER
          The leading dimension of the array C1.
          LDC1 >= MAX(1, N/2).

  VW      (input/output) DOUBLE PRECISION array, dimension
                         (LDVW, N/2+1)
          On entry, the leading N/2-by-N/2 lower triangular part of
          this array must contain the lower triangular part of the
          symmetric matrix W, and the N/2-by-N/2 upper triangular
          part of the submatrix in the columns 2 to N/2+1 of this
          array must contain the upper triangular part of the
          symmetric matrix V.
          On exit, if JOB = 'T', the N/2-by-N/2 part in the columns
          2 to N/2+1 of this array contains the matrix Vout.
          If JOB = 'E', the N/2-by-N/2 part in the columns 2 to
          N/2+1 of this array contains the matrix V just before the
          application of the periodic QZ algorithm.

  LDVW    INTEGER
          The leading dimension of the array VW.
          LDVW >= MAX(1, N/2).

  Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1, N)
          On entry, if COMPQ1 = 'U', then the leading N-by-N part of
          this array must contain a given matrix Q, and on exit,
          the leading N-by-N part of this array contains the product
          of the input matrix Q and the transformation matrix Q1
          used to transform the matrices S and H.
          On exit, if COMPQ1 = 'I', then the leading N-by-N part of
          this array contains the orthogonal transformation matrix
          Q1.
          If COMPQ1 = 'N', this array is not referenced.

  LDQ1    INTEGER
          The leading dimension of the array Q1.
          LDQ1 >= 1,         if COMPQ1 = 'N';
          LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'.

  Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
          On exit, if COMPQ2 = 'U', then the leading N-by-N part of
          this array contains the product of the matrix J*Q*J' and
          the transformation matrix Q2 used to transform the
          matrices S and H.
          On exit, if COMPQ2 = 'I', then the leading N-by-N part of
          this array contains the orthogonal transformation matrix
          Q2.
          If COMPQ2 = 'N', this array is not referenced.

  LDQ2    INTEGER
          The leading dimension of the array Q2.
          LDQ2 >= 1,         if COMPQ2 = 'N';
          LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'.

  B       (output) DOUBLE PRECISION array, dimension (LDB, N/2)
          On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
          array contains the matrix Bout; otherwise, it contains the
          upper triangular matrix B obtained just before the
          application of the periodic QZ algorithm.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1, N/2).

  F       (output) DOUBLE PRECISION array, dimension (LDF, N/2)
          On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
          upper triangular part of this array contains the strictly
          upper triangular part of the skew-symmetric matrix Fout.
          If JOB = 'E', the leading N/2-by-N/2 strictly upper
          triangular part of this array contains the strictly upper
          triangular part of the skew-symmetric matrix F just before
          the application of the periodic QZ algorithm.
          The entries on the leading N/2-by-N/2 lower triangular
          part of this array are not referenced.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= MAX(1, N/2).

  C2      (output) DOUBLE PRECISION array, dimension (LDC2, N/2)
          On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
          array contains the matrix C2out; otherwise, it contains
          the upper Hessenberg matrix C2 obtained just before the
          application of the periodic QZ algorithm.

  LDC2    INTEGER
          The leading dimension of the array C2.
          LDC2 >= MAX(1, N/2).

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
          The real parts of each scalar alpha defining an eigenvalue
          of the pencil aS - bH.

  ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
          The imaginary parts of each scalar alpha defining an
          eigenvalue of the pencil aS - bH.
          If ALPHAI(j) is zero, then the j-th eigenvalue is real.

  BETA    (output) DOUBLE PRECISION array, dimension (N/2)
          The scalars beta that define the eigenvalues of the pencil
          aS - bH.
          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
          beta = BETA(j) represent the j-th eigenvalue of the pencil
          aS - bH, in the form lambda = alpha/beta. Since lambda may
          overflow, the ratios should not, in general, be computed.
          Due to the skew-Hamiltonian/Hamiltonian structure of the
          pencil, for every eigenvalue lambda, -lambda is also an
          eigenvalue, and thus it has only to be saved once in
          ALPHAR, ALPHAI and BETA.
          Specifically, only eigenvalues with imaginary parts
          greater than or equal to zero are stored; their conjugate
          eigenvalues are not stored. If imaginary parts are zero
          (i.e., for real eigenvalues), only positive eigenvalues
          are stored.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)

  LIWORK  INTEGER
          The dimension of the array IWORK.
          LIWORK >= N/2+12.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
          On exit, if INFO = -27, DWORK(1) returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N',
             LDWORK >= N**2 + MAX(N,32);
          if JOB = 'T' or COMPQ1 <> 'N' or COMPQ2 <> 'N',
             LDWORK >= 2*N**2 + MAX(N,32).
          For good performance LDWORK should generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          < 0: if INFO = -i, the i-th argument had an illegal value;
          = 1: problem during computation of the eigenvalues;
          = 2: periodic QZ algorithm did not converge in the SLICOT
               Library subroutine MB03BD.
Method 
  The algorithm uses Givens rotations and Householder reflections to
  annihilate elements in S, T, and H such that A, B, and C1 are
  upper triangular and C2 is upper Hessenberg. Finally, the periodic
  QZ algorithm is applied to transform C2 to upper quasi-triangular
  form while A, B, and C1 stay in upper triangular form.
  See also page 27 in [1] for more details.
References 
  [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.
Numerical Aspects 
                                                            3
  The algorithm is numerically backward stable and needs O(N ) real
  floating point operations.
Further Comments 
  None
Example

Program Text 

*     MB04BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            NMAX
      PARAMETER          ( NMAX = 50 )
      INTEGER            LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1, LDQ2,
     $                   LDVW, LDWORK, LIWORK
      PARAMETER          (  LDA = NMAX/2,  LDB = NMAX/2, LDC1 = NMAX/2,
     $                     LDC2 = NMAX/2, LDDE = NMAX/2,  LDF = NMAX/2,
     $                     LDQ1 = NMAX, LDQ2 = NMAX, LDVW = NMAX/2,
     $                     LDWORK = 2*NMAX*NMAX + MAX( NMAX, 32 ),
     $                     LIWORK = NMAX/2 + 12 )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ1, COMPQ2, JOB
      INTEGER            I, INFO, J, M, N
*
*     .. Local Arrays ..
      INTEGER            IWORK( LIWORK )
      DOUBLE PRECISION   A( LDA, NMAX/2 ), ALPHAI( NMAX/2 ),
     $                   ALPHAR( NMAX/2 ), B( LDB, NMAX/2 ),
     $                   BETA( NMAX/2 ), C1( LDC1, NMAX/2 ),
     $                   C2( LDC2, NMAX/2 ), DE( LDDE, NMAX/2+1 ),
     $                   DWORK( LDWORK ),  F( LDF, NMAX/2 ),
     $                   Q1( LDQ1, NMAX ), Q2( LDQ2, NMAX ),
     $                   VW( LDVW, NMAX/2+1 )
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           MB04BD
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) JOB, COMPQ1, COMPQ2, N
      IF( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         M = N/2
         READ( NIN, FMT = * ) ( (  A( I, J ), J = 1, M   ), I = 1, M )
         READ( NIN, FMT = * ) ( ( DE( I, J ), J = 1, M+1 ), I = 1, M )
         READ( NIN, FMT = * ) ( ( C1( I, J ), J = 1, M   ), I = 1, M )
         READ( NIN, FMT = * ) ( ( VW( I, J ), J = 1, M+1 ), I = 1, M )
*        Compute the eigenvalues of a real skew-Hamiltonian/Hamiltonian
*        pencil.
         CALL MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1,
     $                LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F,
     $                LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK,
     $                LIWORK, DWORK, LDWORK, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE
            WRITE( NOUT, FMT = 99996 )
            DO 10 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( A( I, J ), J = 1, M )
   10       CONTINUE
            WRITE( NOUT, FMT = 99994 )
            DO 20 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( DE( I, J ), J = 2, M+1 )
   20       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            DO 30 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( B( I, J ), J = 1, M )
   30       CONTINUE
            WRITE( NOUT, FMT = 99992 )
            DO 40 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( F( I, J ), J = 1, M )
   40       CONTINUE
            WRITE( NOUT, FMT = 99991 )
            DO 50 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( C1( I, J ), J = 1, M )
   50       CONTINUE
            WRITE( NOUT, FMT = 99990 )
            DO 60 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( C2( I, J ), J = 1, M )
   60       CONTINUE
            WRITE( NOUT, FMT = 99989 )
            DO 70 I = 1, M
               WRITE( NOUT, FMT = 99995 ) ( VW( I, J ), J = 2, M+1 )
   70       CONTINUE
            WRITE( NOUT, FMT = 99988 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M )
            WRITE( NOUT, FMT = 99987 )
            WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M )
            WRITE( NOUT, FMT = 99986 )
            WRITE( NOUT, FMT = 99995 ) (   BETA( I ), I = 1, M )
            WRITE( NOUT, FMT = 99985 )
            IF( .NOT.LSAME( COMPQ1, 'N' ) ) THEN
               DO 80 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( Q1( I, J ), J = 1, N )
   80          CONTINUE
            END IF
            IF( .NOT.LSAME( COMPQ2, 'N' ) ) THEN
               WRITE( NOUT, FMT = 99984 )
               DO 90 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( Q2( I, J ), J = 1, N )
   90          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT( 'MB04BD EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT( 'INFO on exit from MB04BD = ', I2 )
99996 FORMAT( 'The matrix A on exit is ' )
99995 FORMAT( 50( 1X, F8.4 ) )
99994 FORMAT( 'The matrix D on exit is ' )
99993 FORMAT( 'The matrix B on exit is ' )
99992 FORMAT( 'The matrix F on exit is ' )
99991 FORMAT( 'The matrix C1 on exit is ' )
99990 FORMAT( 'The matrix C2 on exit is ' )
99989 FORMAT( 'The matrix V on exit is ' )
99988 FORMAT( 'The vector ALPHAR is ' )
99987 FORMAT( 'The vector ALPHAI is ' )
99986 FORMAT( 'The vector BETA is ' )
99985 FORMAT( 'The matrix Q1 is ' )
99984 FORMAT( 'The matrix Q2 is ' )
      END
Program Data 
MB04BD EXAMPLE PROGRAM DATA
   T   I   I   8
   3.1472   1.3236   4.5751   4.5717
   4.0579  -4.0246   4.6489  -0.1462
  -3.7301  -2.2150  -3.4239   3.0028
   4.1338   0.4688   4.7059  -3.5811
   0.0000   0.0000  -1.5510  -4.5974  -2.5127
   3.5071   0.0000   0.0000   1.5961   2.4490  
  -3.1428   2.5648   0.0000   0.0000  -0.0596 
   3.0340   2.4892  -1.1604   0.0000   0.0000
   0.6882  -3.3782  -3.3435   1.8921
  -0.3061   2.9428   1.0198   2.4815
  -4.8810  -1.8878  -2.3703  -0.4946
  -1.6288   0.2853   1.5408  -4.1618
  -2.4013  -2.7102   0.3834  -3.9335   3.1730
  -3.1815  -2.3620   4.9613   4.6190   3.6869
   3.6929   0.7970   0.4986  -4.9537  -4.1556
   3.5303   1.2206  -1.4905   0.1325  -1.0022
Program Results 
MB04BD EXAMPLE PROGRAM RESULTS
The matrix A on exit is 
  -4.7460   4.1855   3.2696  -0.2244
   0.0000   6.4157   2.8287   1.4553
   0.0000   0.0000   7.4626   1.5726
   0.0000   0.0000   0.0000   8.8702
The matrix D on exit is 
   0.0000  -1.3137  -6.3615  -0.8940
   0.0000   0.0000   1.0704  -0.0659
   4.4324   0.0000   0.0000  -0.6922
   0.5254   1.6653   0.0000   0.0000
The matrix B on exit is 
  -6.4937  -2.1982  -1.3881   1.3477
   0.0000   4.6929   0.6650  -4.1191
   0.0000   0.0000   9.1725   3.4721
   0.0000   0.0000   0.0000   7.2106
The matrix F on exit is 
   0.0000  -1.1367   2.2966  -1.0744
   0.0000   0.0000   3.7875   0.9427
   0.0000   0.0000   0.0000  -4.7136
   0.0000   0.0000   0.0000   0.0000
The matrix C1 on exit is 
   6.9525  -4.9881   2.3661   4.2188
   0.0000   8.5009   0.7182   5.5533
   0.0000   0.0000  -4.6650  -2.8177
   0.0000   0.0000   0.0000   1.5124
The matrix C2 on exit is 
  -5.4562  -2.1348   4.9694  -2.2744
   2.5550  -7.9616   1.1516   3.4912
   0.0000   0.0000   4.8504   0.5046
   0.0000   0.0000   0.0000   4.4394
The matrix V on exit is 
   0.9136   4.1106  -0.0079   3.5789
  -1.1553  -1.4785  -1.5155  -0.8018
  -2.2167   4.8029   1.3645   2.5202
  -1.0994  -0.6144   0.3970   2.0730
The vector ALPHAR is 
   0.8314  -1.1758   0.8131   0.0000
The vector ALPHAI is 
   0.4372   0.6183   0.0000   0.9164
The vector BETA is 
   0.7071   1.0000   1.4142   2.8284
The matrix Q1 is 
  -0.0098   0.1978   0.2402   0.5274   0.1105  -0.0149  -0.1028   0.7759
  -0.6398   0.2356   0.2765  -0.1301  -0.5351  -0.3078   0.2435   0.0373
   0.1766  -0.4781   0.2657  -0.5415   0.0968  -0.4663  -0.0983   0.3741
   0.3207  -0.1980   0.1141   0.0240  -0.1712   0.2630   0.8513   0.1451
  -0.6551  -0.2956  -0.0288  -0.1169   0.5593   0.3381   0.1753   0.1055
  -0.0246  -0.2759   0.2470  -0.1408  -0.4837   0.6567  -0.4042   0.1172
  -0.0772  -0.0121  -0.8394  -0.1852  -0.2673   0.0046   0.0159   0.4282
   0.1442   0.6884   0.1257  -0.5860   0.2110   0.2699   0.0363   0.1657
The matrix Q2 is 
  -0.2891   0.3096   0.6312   0.6498   0.0000   0.0000   0.0000   0.0000
   0.1887   0.1936  -0.3857   0.3664   0.5660   0.1238  -0.2080  -0.5148
  -0.2492  -0.2877  -0.0874   0.1110  -0.1081  -0.2999   0.6800  -0.5207
  -0.7430  -0.0646  -0.4689   0.1556  -0.2401   0.0181  -0.3724   0.0562
  -0.0999  -0.2026  -0.0355   0.0866   0.5587  -0.6625  -0.0114   0.4349
  -0.4357   0.1209   0.0489  -0.2990   0.5094   0.5191   0.3837   0.1661
  -0.2429   0.4131   0.2549  -0.5525   0.0749  -0.3829  -0.2690  -0.4190
   0.0889   0.7439  -0.3960   0.0697  -0.1821  -0.1988   0.3687   0.2616

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04DD.html000077500000000000000000000211661201767322700160640ustar00rootroot00000000000000 MB04DD - SLICOT Library Routine Documentation

MB04DD

Balancing a real Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To balance a real Hamiltonian matrix,

                [  A   G  ]
           H =  [       T ] ,
                [  Q  -A  ]

  where A is an N-by-N matrix and G, Q are N-by-N symmetric
  matrices. This involves, first, permuting H by a symplectic
  similarity transformation to isolate eigenvalues in the first
  1:ILO-1 elements on the diagonal of A; and second, applying a
  diagonal similarity transformation to rows and columns
  ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm
  as possible. Both steps are optional.
Specification 
      SUBROUTINE MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           ILO, INFO, LDA, LDQG, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), QG(LDQG,*), SCALE(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the operations to be performed on H:
          = 'N':  none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N;
          = 'P':  permute only;
          = 'S':  scale only;
          = 'B':  both permute and scale.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the matrix A of the balanced Hamiltonian. In particular,
          the lower triangular part of the first ILO-1 columns of A
          is zero.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  QG      (input/output) DOUBLE PRECISION array, dimension
                         (LDQG,N+1)
          On entry, the leading N-by-N+1 part of this array must
          contain the lower triangular part of the matrix Q and
          the upper triangular part of the matrix G.
          On exit, the leading N-by-N+1 part of this array contains
          the lower and upper triangular parts of the matrices Q and
          G, respectively, of the balanced Hamiltonian. In
          particular, the lower triangular and diagonal part of the
          first ILO-1 columns of QG is zero.

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= MAX(1,N).

  ILO     (output) INTEGER
          ILO-1 is the number of deflated eigenvalues in the
          balanced Hamiltonian matrix.

  SCALE   (output) DOUBLE PRECISION array of dimension (N)
          Details of the permutations and scaling factors applied to
          H.  For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N,
          then rows and columns P(j) and P(j)+N are interchanged
          with rows and columns j and j+N, respectively. If
          P(j) > N, then row and column P(j)-N are interchanged with
          row and column j+N by a generalized symplectic
          permutation. For j = ILO,...,N the j-th element of SCALE
          contains the factor of the scaling applied to row and
          column j.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Benner, P.
      Symplectic balancing of Hamiltonian matrices.
      SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000.
Further Comments 
  None
Example

Program Text 

*     MB04DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDQG
      PARAMETER        ( LDA = NMAX, LDQG = NMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOB
      INTEGER          I, ILO, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), DUMMY(1), QG(LDQG, NMAX+1),
     $                 SCALE(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANTR, DLAPY2
      EXTERNAL         DLANTR, DLAPY2
*     .. External Subroutines ..
      EXTERNAL         MB04DD
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, JOB
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 30  I = 1, N
               WRITE (NOUT, FMT = 99995) ( A(I,J), J = 1,N )
30          CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 40  I = 1, N
               WRITE (NOUT, FMT = 99995) ( QG(I,J), J = 1,N+1 )
40          CONTINUE
            WRITE (NOUT, FMT = 99993)  ILO
            IF ( ILO.GT.1 ) THEN
                WRITE (NOUT, FMT = 99992) DLAPY2( DLANTR( 'Frobenius',
     $                 'Lower', 'No Unit', N-1, ILO-1, A(2,1), LDA,
     $                 DUMMY ), DLANTR( 'Frobenius', 'Lower', 'No Unit',
     $                 N, ILO-1, QG(1,1), LDQG, DUMMY ) )
            END IF
         END IF
      END IF
*
99999 FORMAT (' MB04DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04DD = ',I2)
99997 FORMAT (' The balanced matrix A is ')
99996 FORMAT (/' The balanced matrix QG is ')
99995 FORMAT (20(1X,F12.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' ILO = ',I4)
99992 FORMAT (/' Norm of subdiagonal blocks: ',G7.2)
      END
Program Data 
MB04DD EXAMPLE PROGRAM DATA
       6       B
         0         0         0         0         0         0
    0.0994         0         0         0         0    0.9696
    0.3248         0         0         0    0.4372    0.8308
         0         0         0    0.0717         0         0
         0         0         0         0         0    0.1976
         0         0         0         0         0         0
         0         0         0         0         0         0         0
         0         0         0         0    0.0651         0         0
         0         0         0         0         0         0         0
         0         0    0.0444         0         0    0.1957         0
    0.8144         0         0         0    0.3652         0    0.9121
    0.9023         0         0         0         0         0    1.0945
Program Results 
 MB04DD EXAMPLE PROGRAM RESULTS

 The balanced matrix A is 
       0.0000       0.0000       0.0000       0.0000       0.0000       0.9696
       0.0000       0.0000       0.0000       0.0000      -0.8144      -0.9023
       0.0000       0.0000       0.0000       0.0000       0.1093       0.2077
       0.0000       0.0000       0.0000       0.0717       0.0000       0.0000
       0.0000       0.0000       0.0000       0.0000       0.0000       0.1976
       0.0000       0.0000       0.0000       0.0000       0.0000       0.0000

 The balanced matrix QG is 
       0.0000       0.0000       0.0994       0.0000       0.0651       0.0000       0.0000
       0.0000       0.0000       0.0000       0.0812       0.0000       0.0000       0.0000
       0.0000       0.0000       0.0000       0.0000       0.0000       0.0000       0.0000
       0.0000       0.0000       0.1776       0.0000       0.0000       0.1957       0.0000
       0.0000       0.0000       0.0000       0.0000       0.3652       0.0000       0.9121
       0.0000       0.0000       0.0000       0.0000       0.0000       0.0000       1.0945

 ILO =    3

 Norm of subdiagonal blocks: 0.0
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04DI.html000077500000000000000000000075121201767322700160700ustar00rootroot00000000000000 MB04DI - SLICOT Library Routine Documentation

MB04DI

Applying the inverse of a balancing transformation for a real Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply the inverse of a balancing transformation, computed by
  the SLICOT Library routines MB04DD or MB04DS, to a 2*N-by-M matrix

            [   V1   ]
            [        ],
            [ sgn*V2 ]

  where sgn is either +1 or -1.
Specification 
      SUBROUTINE MB04DI( JOB, SGN, N, ILO, SCALE, M, V1, LDV1, V2, LDV2,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER         JOB, SGN
      INTEGER           ILO, INFO, LDV1, LDV2, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  SCALE(*), V1(LDV1,*), V2(LDV2,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the type of inverse transformation required:
          = 'N':  do nothing, return immediately;
          = 'P':  do inverse transformation for permutation only;
          = 'S':  do inverse transformation for scaling only;
          = 'B':  do inverse transformations for both permutation
                  and scaling.
          JOB must be the same as the argument JOB supplied to
          MB04DD or MB04DS.

  SGN     CHARACTER*1
          Specifies the sign to use for V2:
          = 'P':  sgn = +1;
          = 'N':  sgn = -1.
Input/Output Parameters 
  N       (input) INTEGER
          The number of rows of the matrices V1 and V2. N >= 0.

  ILO     (input) INTEGER
          The integer ILO determined by MB04DD or MB04DS.
          1 <= ILO <= N+1.

  SCALE   (input) DOUBLE PRECISION array, dimension (N)
          Details of the permutation and scaling factors, as
          returned by MB04DD or MB04DS.

  M       (input) INTEGER
          The number of columns of the matrices V1 and V2.  M >= 0.

  V1      (input/output) DOUBLE PRECISION array, dimension (LDV1,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix V1.
          On exit, the leading N-by-M part of this array is
          overwritten by the updated matrix V1 of the transformed
          matrix.

  LDV1    INTEGER
          The leading dimension of the array V1. LDV1 >= max(1,N).

  V2      (input/output) DOUBLE PRECISION array, dimension (LDV2,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix V2.
          On exit, the leading N-by-M part of this array is
          overwritten by the updated matrix V2 of the transformed
          matrix.

  LDV2    INTEGER
          The leading dimension of the array V2. LDV2 >= max(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Benner, P.
      Symplectic balancing of Hamiltonian matrices.
      SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04DS.html000077500000000000000000000211441201767322700160770ustar00rootroot00000000000000 MB04DS - SLICOT Library Routine Documentation

MB04DS

Balancing a real skew-Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To balance a real skew-Hamiltonian matrix

                [  A   G  ]
           S =  [       T ] ,
                [  Q   A  ]

  where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric
  matrices. This involves, first, permuting S by a symplectic
  similarity transformation to isolate eigenvalues in the first
  1:ILO-1 elements on the diagonal of A; and second, applying a
  diagonal similarity transformation to rows and columns
  ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm
  as possible. Both steps are optional.
Specification 
      SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           ILO, INFO, LDA, LDQG, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), QG(LDQG,*), SCALE(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the operations to be performed on S:
          = 'N':  none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N;
          = 'P':  permute only;
          = 'S':  scale only;
          = 'B':  both permute and scale.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the matrix A of the balanced skew-Hamiltonian. In
          particular, the lower triangular part of the first ILO-1
          columns of A is zero.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  QG      (input/output) DOUBLE PRECISION array, dimension
                         (LDQG,N)
          On entry, the leading N-by-N+1 part of this array must
          contain in columns 1:N the strictly lower triangular part
          of the matrix Q and in columns 2:N+1 the strictly upper
          triangular part of the matrix G. The parts containing the
          diagonal and the first supdiagonal of this array are not
          referenced.
          On exit, the leading N-by-N+1 part of this array contains
          the strictly lower and strictly upper triangular parts of
          the matrices Q and G, respectively, of the balanced
          skew-Hamiltonian. In particular, the strictly lower
          triangular part of the first ILO-1 columns of QG is zero.

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= MAX(1,N).

  ILO     (output) INTEGER
          ILO-1 is the number of deflated eigenvalues in the
          balanced skew-Hamiltonian matrix.

  SCALE   (output) DOUBLE PRECISION array of dimension (N)
          Details of the permutations and scaling factors applied to
          S.  For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N,
          then rows and columns P(j) and P(j)+N are interchanged
          with rows and columns j and j+N, respectively. If
          P(j) > N, then row and column P(j)-N are interchanged with
          row and column j+N by a generalized symplectic
          permutation. For j = ILO,...,N the j-th element of SCALE
          contains the factor of the scaling applied to row and
          column j.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Benner, P.
      Symplectic balancing of Hamiltonian matrices.
      SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000.
Further Comments 
  None
Example

Program Text 

*     MB04DS EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDQG
      PARAMETER        ( LDA = NMAX, LDQG = NMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOB
      INTEGER          I, ILO, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), DUMMY(1), QG(LDQG, NMAX+1),
     $                 SCALE(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANTR, DLAPY2
      EXTERNAL         DLANTR, DLAPY2
*     .. External Subroutines ..
      EXTERNAL         MB04DS
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, JOB
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 30  I = 1, N
               WRITE (NOUT, FMT = 99995) ( A(I,J), J = 1,N )
30          CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 40  I = 1, N
               WRITE (NOUT, FMT = 99995) ( QG(I,J), J = 1,N+1 )
40          CONTINUE
            WRITE (NOUT, FMT = 99993)  ILO
            IF ( ILO.GT.1 ) THEN
                WRITE (NOUT, FMT = 99992) DLAPY2( DLANTR( 'Frobenius',
     $                 'Lower', 'No Unit', N-1, ILO-1, A(2,1), LDA,
     $                 DUMMY ), DLANTR( 'Frobenius', 'Lower', 'No Unit',
     $                 N-1, ILO-1, QG(2,1), LDQG, DUMMY ) )
            END IF
         END IF
      END IF
*
99999 FORMAT (' MB04DS EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04DS = ',I2)
99997 FORMAT (' The balanced matrix A is ')
99996 FORMAT (/' The balanced matrix QG is ')
99995 FORMAT (20(1X,F9.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' ILO = ',I4)
99992 FORMAT (/' Norm of subdiagonal blocks: ',G7.2)
      END
Program Data 
MB04DS EXAMPLE PROGRAM DATA
       6       B
    0.0576         0    0.5208         0    0.7275   -0.7839
    0.1901    0.0439    0.1663    0.0928    0.6756   -0.5030
    0.5962         0    0.4418         0   -0.5955    0.7176
    0.5869         0    0.3939    0.0353    0.6992   -0.0147
    0.2222         0   -0.3663         0    0.5548   -0.4608
         0         0         0         0         0    0.1338
         0         0   -0.9862   -0.4544   -0.4733    0.4435         0
         0         0         0   -0.6927    0.6641    0.4453         0
   -0.3676         0         0         0    0.0841    0.3533         0
         0         0         0         0         0    0.0877         0
    0.9561         0    0.4784         0         0         0         0
   -0.0164   -0.4514   -0.8289   -0.6831   -0.1536         0         0
Program Results 
 MB04DS EXAMPLE PROGRAM RESULTS

 The balanced matrix A is 
    0.1338    0.4514    0.6831    0.8289    0.1536    0.0164
    0.0000    0.0439    0.0928    0.1663    0.6756    0.1901
    0.0000    0.0000    0.0353    0.3939    0.6992    0.5869
    0.0000    0.0000    0.0000    0.4418   -0.5955    0.5962
    0.0000    0.0000    0.0000   -0.3663    0.5548    0.2222
    0.0000    0.0000    0.0000    0.5208    0.7275    0.0576

 The balanced matrix QG is 
    0.0000    0.0000    0.5030    0.0147   -0.7176    0.4608    0.7839
    0.0000    0.0000    0.0000    0.6641   -0.6927    0.4453    0.9862
    0.0000    0.0000    0.0000    0.0000   -0.0841    0.0877    0.4733
    0.0000    0.0000    0.0000    0.0000    0.0000    0.3533    0.4544
    0.0000    0.0000    0.0000    0.4784    0.0000    0.0000   -0.4435
    0.0000    0.0000    0.0000    0.3676   -0.9561    0.0000    0.0000

 ILO =    4

 Norm of subdiagonal blocks: 0.0
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04DY.html000077500000000000000000000255141201767322700161120ustar00rootroot00000000000000 MB04DY - SLICOT Library Routine Documentation

MB04DY

Symplectic scaling of a Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform a symplectic scaling on the Hamiltonian matrix

           ( A    G  )
       H = (       T ),                                          (1)
           ( Q   -A  )

  i.e., perform either the symplectic scaling transformation

                                -1
              ( A'   G'  )   ( D   0 ) ( A   G  ) ( D  0   )
       H' <-- (        T ) = (       ) (      T ) (     -1 ),    (2)
              ( Q'  -A'  )   ( 0   D ) ( Q  -A  ) ( 0  D   )

  where D is a diagonal scaling matrix, or the symplectic norm
  scaling transformation

               ( A''   G''  )    1  (   A   G/tau )
       H'' <-- (          T ) = --- (           T ),             (3)
               ( Q''  -A''  )   tau ( tau Q   -A  )

  where tau is a real scalar.  Note that if tau is not equal to 1,
  then (3) is NOT a similarity transformation.  The eigenvalues
  of H are then tau times the eigenvalues of H''.

  For symplectic scaling (2), D is chosen to give the rows and
  columns of A' approximately equal 1-norms and to give Q' and G'
  approximately equal norms.  (See METHOD below for details.) For
  norm scaling, tau = MAX(1, ||A||, ||G||, ||Q||) where ||.||
  denotes the 1-norm (column sum norm).
Specification 
      SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDQG, N
      CHARACTER         JOBSCL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), D(*), DWORK(*), QG(LDQG,*)
Arguments

Mode Parameters 

  JOBSCL  CHARACTER*1
          Indicates which scaling strategy is used, as follows:
          = 'S'       :  do the symplectic scaling (2);
          = '1' or 'O':  do the 1-norm scaling (3);
          = 'N'       :  do nothing; set INFO and return.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, G, and Q.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On input, if JOBSCL <> 'N', the leading N-by-N part of
          this array must contain the upper left block A of the
          Hamiltonian matrix H in (1).
          On output, if JOBSCL <> 'N', the leading N-by-N part of
          this array contains the leading N-by-N part of the scaled
          Hamiltonian matrix H' in (2) or H'' in (3), depending on
          the setting of JOBSCL.
          If JOBSCL = 'N', this array is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N), if JOBSCL <> 'N';
          LDA >= 1,        if JOBSCL =  'N'.

  QG      (input/output) DOUBLE PRECISION array, dimension
          (LDQG,N+1)
          On input, if JOBSCL <> 'N', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangle of the lower left symmetric block Q of the
          Hamiltonian matrix H in (1), and the N-by-N upper
          triangular part of the submatrix in the columns 2 to N+1
          of this array must contain the upper triangle of the upper
          right symmetric block G of H in (1).
          So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j)
          and G(i,j) = G(j,i) is stored in QG(j,i+1).
          On output, if JOBSCL <> 'N', the leading N-by-N lower
          triangular part of this array contains the lower triangle
          of the lower left symmetric block Q' or Q'', and the
          N-by-N upper triangular part of the submatrix in the
          columns 2 to N+1 of this array contains the upper triangle
          of the upper right symmetric block G' or G'' of the scaled
          Hamiltonian matrix H' in (2) or H'' in (3), depending on
          the setting of JOBSCL.
          If JOBSCL = 'N', this array is not referenced.

  LDQG    INTEGER
          The leading dimension of the array QG.
          LDQG >= MAX(1,N), if JOBSCL <> 'N';
          LDQG >= 1,        if JOBSCL =  'N'.

  D       (output) DOUBLE PRECISION array, dimension (nd)
          If JOBSCL = 'S', then nd = N and D contains the diagonal
          elements of the diagonal scaling matrix in (2).
          If JOBSCL = '1' or 'O', then nd = 1 and D(1) is set to tau
          from (3). In this case, no other elements of D are
          referenced.
          If JOBSCL = 'N', this array is not referenced.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
          If JOBSCL = 'N', this array is not referenced.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, then the i-th argument had an illegal
                value.
Method 
  1. Symplectic scaling (JOBSCL = 'S'):

  First, LAPACK subroutine DGEBAL is used to equilibrate the 1-norms
  of the rows and columns of A using a diagonal scaling matrix D_A.
  Then, H is similarily transformed by the symplectic diagonal
  matrix D1 = diag(D_A,D_A**(-1)).  Next, the off-diagonal blocks of
  the resulting Hamiltonian matrix are equilibrated in the 1-norm
  using the symplectic diagonal matrix D2 of the form

              ( I/rho    0   )
         D2 = (              )
              (   0    rho*I )

  where rho is a real scalar. Thus, in (2), D = D1*D2.

  2. Norm scaling (JOBSCL = '1' or 'O'):

  The norm of the matrices A and G of (1) is reduced by setting
  A := A/tau  and  G := G/(tau**2) where tau is the power of the
  base of the arithmetic closest to MAX(1, ||A||, ||G||, ||Q||) and
  ||.|| denotes the 1-norm.
References 
  [1] Benner, P., Byers, R., and Barth, E.
      Fortran 77 Subroutines for Computing the Eigenvalues of
      Hamiltonian Matrices. I: The Square-Reduced Method.
      ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000.
Numerical Aspects 
  For symplectic scaling, the complexity of the used algorithms is
  hard to estimate and depends upon how well the rows and columns of
  A in (1) are equilibrated.  In one sweep, each row/column of A is
  scaled once, i.e., the cost of one sweep is N**2 multiplications.
  Usually, 3-6 sweeps are enough to equilibrate the norms of the
  rows and columns of a matrix.  Roundoff errors are possible as
  LAPACK routine DGEBAL does NOT use powers of the machine base for
  scaling. The second stage (equilibrating ||G|| and ||Q||) requires
  N**2 multiplications.
  For norm scaling, 3*N**2 + O(N) multiplications are required and
  NO rounding errors occur as all multiplications are performed with
  powers of the machine base.
Further Comments 
  None
Example

Program Text 

*     MB04DY EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDQG
      PARAMETER        ( LDA = NMAX, LDQG = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      CHARACTER*1      JOBSCL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), D(NMAX), DWORK(LDWORK),
     $                 QG(LDQG,NMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04DY
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOBSCL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99998 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J),    J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J),   I = J,N ), J = 1,N )
*        Scale the Hamiltonian matrix.
         CALL MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99997 ) INFO
         ELSE
*           Show the scaled Hamiltonian matrix.
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
              WRITE ( NOUT, FMT = 99993 )  ( A(I,J),    J = 1,N ),
     $           ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N )
10          CONTINUE
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99993 ) (  QG(I,J), J = 1,I-1 ),
     $               ( QG(J,I), J = I,N ), ( -A(J,I),  J = 1,N )
20          CONTINUE
*           Show the scaling factors.
            IF ( LSAME( JOBSCL, 'S' ) ) THEN
               WRITE ( NOUT, FMT = 99995 )
               WRITE ( NOUT, FMT = 99993 ) ( D(I), I = 1,N )
            ELSE IF ( LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) )
     $            THEN
               WRITE ( NOUT, FMT = 99994 )
               WRITE ( NOUT, FMT = 99993 ) D(1)
            END IF
         ENDIF
      END IF
      STOP
*
99999 FORMAT (' MB04DY EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' N is out of range.',/' N = ',I5)
99997 FORMAT (' INFO on exit from MB04DY = ',I2)
99996 FORMAT (/' The scaled Hamiltonian is ')
99995 format (/' The scaling factors are ')
99994 format (/' The scaling factor tau is ')
99993 FORMAT (1X,8(F10.4))
      END
Program Data 
MB04DY EXAMPLE PROGRAM DATA
3 S
-0.4   0.05  0.0007   
-4.7   0.8   0.025   
81.0  29.0  -0.9        
0.0034  0.0014  0.00077 -0.005  0.0004  0.003
-18.0 -12.0  43.0  99.0  420.0  -200.0
Program Results 
 MB04DY EXAMPLE PROGRAM RESULTS


 The scaled Hamiltonian is 
    -0.4000    0.4000    0.3584  418.4403   21.5374    0.1851
    -0.5875    0.8000    1.6000   21.5374   -9.6149    0.0120
     0.1582    0.4531   -0.9000    0.1851    0.0120    0.0014
    -0.0001   -0.0008    0.1789    0.4000    0.5875   -0.1582
    -0.0008    0.0515   13.9783   -0.4000   -0.8000   -0.4531
     0.1789   13.9783 -426.0056   -0.3584   -1.6000    0.9000

 The scaling factors are 
     0.0029    0.0228    1.4595
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04GD.html000077500000000000000000000163211201767322700160640ustar00rootroot00000000000000 MB04GD - SLICOT Library Routine Documentation

MB04GD

RQ factorization with row pivoting of a matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an RQ factorization with row pivoting of a
  real m-by-n matrix A: P*A = R*Q.
Specification 
      SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ), TAU( * )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the m-by-n matrix A.
          On exit,
          if m <= n, the upper triangle of the subarray
          A(1:m,n-m+1:n) contains the m-by-m upper triangular
          matrix R;
          if m >= n, the elements on and above the (m-n)-th
          subdiagonal contain the m-by-n upper trapezoidal matrix R;
          the remaining elements, with the array TAU, represent the
          orthogonal matrix Q as a product of min(m,n) elementary
          reflectors (see METHOD).

  LDA     INTEGER
          The leading dimension of the array A. LDA >= max(1,M).

  JPVT    (input/output) INTEGER array, dimension (M)
          On entry, if JPVT(i) .ne. 0, the i-th row of A is permuted
          to the bottom of P*A (a trailing row); if JPVT(i) = 0,
          the i-th row of A is a free row.
          On exit, if JPVT(i) = k, then the i-th row of P*A
          was the k-th row of A.

  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
          The scalar factors of the elementary reflectors.
Workspace 
  DWORK    DOUBLE PRECISION array, dimension (3*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix Q is represented as a product of elementary reflectors

     Q = H(1) H(2) . . . H(k), where k = min(m,n).

  Each H(i) has the form

     H = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit
  in A(m-k+i,1:n-k+i-1), and tau in TAU(i).

  The matrix P is represented in jpvt as follows: If
     jpvt(j) = i
  then the jth row of P is the ith canonical unit vector.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

*     MB04GD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 10, MMAX = 10 )
      INTEGER          LDA
      PARAMETER        ( LDA = MMAX )
      INTEGER          LDTAU
      PARAMETER        ( LDTAU = MIN(MMAX,NMAX) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*MMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU)
      INTEGER          JPVT(MMAX)
*     .. External Subroutines ..
      EXTERNAL         DLASET, MB04GD
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
            READ ( NIN, FMT = * ) ( JPVT(I), I = 1,M )
*           RQ with row pivoting.
            CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,M )
               WRITE ( NOUT, FMT = 99990 )
               IF ( M.GE.N ) THEN
                  IF ( N.GT.1 )
     $               CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO,
     $                            A(M-N+2,1), LDA )
                ELSE
                   CALL DLASET( 'Full', M, N-M-1, ZERO, ZERO, A, LDA )
                   CALL DLASET( 'Lower', M, M, ZERO, ZERO, A(1,N-M),
     $                          LDA )
               END IF
               DO 20 I = 1, M
                  WRITE ( NOUT, FMT = 99989 ) ( A(I,J), J = 1,N )
   20          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB04GD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04GD = ',I2)
99994 FORMAT (' Row permutations are ',/(20(I3,2X)))
99990 FORMAT (/' The matrix A is ')
99989 FORMAT (20(1X,F8.4))
99972 FORMAT (/' N is out of range.',/' N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 MB04GD EXAMPLE PROGRAM DATA
   6     5 
   1.    2.    6.    3.    5.
  -2.   -1.   -1.    0.   -2.
   5.    5.    1.    5.    1.
  -2.   -1.   -1.    0.   -2.
   4.    8.    4.   20.    4.
  -2.   -1.   -1.    0.   -2.
   0     0     0     0     0     0
Program Results 
 MB04GD EXAMPLE PROGRAM RESULTS

 Row permutations are 
  2    4    6    3    1    5

 The matrix A is 
   0.0000  -1.0517  -1.8646  -1.9712   1.2374
   0.0000  -1.0517  -1.8646  -1.9712   1.2374
   0.0000  -1.0517  -1.8646  -1.9712   1.2374
   0.0000   0.0000   4.6768   0.0466  -7.4246
   0.0000   0.0000   0.0000   6.7059  -5.4801
   0.0000   0.0000   0.0000   0.0000 -22.6274

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04HD.html000077500000000000000000000261711201767322700160710ustar00rootroot00000000000000 MB04HD - SLICOT Library Routine Documentation

MB04HD

Reducing a special real block (anti-)diagonal skew-Hamiltonian/Hamiltonian pencil to generalized Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the transformed matrices A and B, using orthogonal
  matrices Q1 and Q2 for a real N-by-N regular pencil

                 ( A11   0  )     (  0   B12 )
    aA - bB =  a (          ) - b (          ),                  (1)
                 (  0   A22 )     ( B21   0  )

  where A11, A22 and B12 are upper triangular and the generalized
                    -1        -1
  matrix product A11   B12 A22   B21 is upper quasi-triangular,
  such that the matrix Q2' A Q1 is upper triangular and Q2' B Q1 is
  upper quasi-triangular.
Specification 
      SUBROUTINE MB04HD( COMPQ1, COMPQ2, N, A, LDA, B, LDB, Q1, LDQ1,
     $                   Q2, LDQ2, BWORK, IWORK, LIWORK, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ1, COMPQ2
      INTEGER            INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, LIWORK, N
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   Q1( LDQ1, * ), Q2( LDQ2, * )
Arguments

Mode Parameters 

  COMPQ1  CHARACTER*1
          Specifies whether to compute the orthogonal transformation
          matrix Q1, as follows:
          = 'N':  Q1 is not computed;
          = 'I':  the array Q1 is initialized internally to the unit
                  matrix, and the orthogonal matrix Q1 is returned;
          = 'U':  the array Q1 contains an orthogonal matrix Q01 on
                  entry, and the matrix Q01*Q1 is returned, where Q1
                  is the product of the orthogonal transformations
                  that are applied on the right to the pencil
                  aA - bB in (1).

  COMPQ2  CHARACTER*1
          Specifies whether to compute the orthogonal transformation
          matrix Q2, as follows:
          = 'N':  Q2 is not computed;
          = 'I':  the array Q2 is initialized internally to the unit
                  matrix, and the orthogonal matrix Q2 is returned;
          = 'U':  the array Q2 contains an orthogonal matrix Q02 on
                  entry, and the matrix Q02*Q2 is returned, where Q2
                  is the product of the orthogonal transformations
                  that are applied on the left to the pencil aA - bB
                  in (1).
Input/Output Parameters 
  N       (input) INTEGER
          Order of the pencil aA - bB, N has to be even.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
          On entry, the leading N-by-N block diagonal part of this
          array must contain the matrix A in (1). The off-diagonal
          blocks need not be set to zero.
          On exit, the leading N-by-N part of this array contains
          the transformed upper triangular matrix.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1, N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
          On entry, the leading N-by-N block anti-diagonal part of
          this array must contain the matrix B in (1). The diagonal
          blocks need not be set to zero.
          On exit, the leading N-by-N part of this array contains
          the transformed upper quasi-triangular matrix.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1, N).

  Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1, N)
          On entry, if COMPQ1 = 'U', then the leading N-by-N part of
          this array must contain a given matrix Q01, and on exit,
          the leading N-by-N part of this array contains the product
          of the input matrix Q01 and the transformation matrix Q1
          used to transform the matrices A and B.
          On exit, if COMPQ1 = 'I', then the leading N-by-N part of
          this array contains the orthogonal transformation matrix
          Q1.
          If COMPQ1 = 'N' this array is not referenced.

  LDQ1    INTEGER
          The leading dimension of the array Q1.
          LDQ1 >= 1,         if COMPQ1 = 'N';
          LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'.

  Q2      (input/output) DOUBLE PRECISION array, dimension (LDQ2, N)
          On entry, if COMPQ2 = 'U', then the leading N-by-N part of
          this array must contain a given matrix Q02, and on exit,
          the leading N-by-N part of this array contains the product
          of the input matrix Q02 and the transformation matrix Q2
          used to transform the matrices A and B.
          On exit, if COMPQ2 = 'I', then the leading N-by-N part of
          this array contains the orthogonal transformation matrix
          Q2.
          If COMPQ2 = 'N' this array is not referenced.

  LDQ2    INTEGER
          The leading dimension of the array Q2.
          LDQ2 >= 1,         if COMPQ2 = 'N';
          LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'.
Workspace 
  BWORK   LOGICAL array, dimension (N/2)

  IWORK   INTEGER array, dimension (LIWORK)

  LIWORK  INTEGER
          The dimension of the array IWORK.
          LIWORK >= N/2 + 32.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
          On exit, if INFO = -16, DWORK(1) returns the minimum value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 2*N*N + MAX( N/2 + 168, 272 ).
          For good performance LDWORK should be generally larger.

          If LDWORK = -1  a workspace query is assumed; the 
          routine only calculates the optimal size of the DWORK
          array, returns this value as the first entry of the DWORK
          array, and no error message is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0: succesful exit;
          < 0: if INFO = -i, the i-th argument had an illegal value;
          = 1: the periodic QZ algorithm failed to reorder the
               eigenvalues (the problem is very ill-conditioned) in
               the SLICOT Library routine MB03KD;
          = 2: the standard QZ algorithm failed in the LAPACK
               routine DGGEV, called by the SLICOT routine MB03DD;
          = 3: the standard QZ algorithm failed in the LAPACK
               routines DGGES or DHGEQZ, called by the SLICOT
               routines MB03DD or MB03FD;
          = 4: the standard QZ algorithm failed to reorder the
               eigenvalues in the LAPACK routine DTGSEN, called by
               the SLICOT routine MB03DD.
Method 
  First, the periodic QZ algorithm (see also [2] and [3]) is applied
                                  -1        -1
  to the formal matrix product A11   B12 A22   B21 to reorder the
  eigenvalues, i.e., orthogonal matrices V1, V2, V3 and V4 are
  computed such that V2' A11 V1, V2' B12 V3, V4' A22 V3 and
  V4' B21 V1 keep the triangular form, but they can be partitioned
  into 2-by-2 block forms and the last diagonal blocks correspond to
  all nonpositive real eigenvalues of the formal product, and the
  first diagonal blocks correspond to the remaining eigenvalues.

  Second, Q1 = diag(V1, V3), Q2 = diag(V2, V4) and

                   ( AA11 AA12   0    0  )
                   (                     )
                   (   0  AA22   0    0  )
  A := Q2' A Q1 =: (                     ),
                   (   0    0  AA33 AA34 )
                   (                     )
                   (   0    0    0  AA44 )

                   (   0    0  BB13 BB14 )
                   (                     )
                   (   0    0    0  BB24 )
  B := Q2' B Q1 =: (                     ),
                   ( BB31 BB32   0    0  )
                   (                     )
                   (   0  BB42   0    0  )

                         -1          -1
  are set, such that AA22   BB24 AA44   BB42 has only nonpositive
  real eigenvalues.

  Third, the permutation matrix

      (  I  0  0  0  )
      (              )
      (  0  0  I  0  )
  P = (              ),
      (  0  I  0  0  )
      (              )
      (  0  0  0  I  )

  where I denotes the identity matrix of appropriate size, is used
  to transform aA - bB to block upper triangular form

                ( AA11   0  | AA12   0  )
                (           |           )
                (   0  AA33 |   0  AA34 )   ( AA1  *  )
  A := P' A P = (-----------+-----------) = (         ),
                (   0    0  | AA22   0  )   (  0  AA2 )
                (           |           )
                (   0    0  |   0  AA44 )

                (   0  BB13 |   0  BB14 )
                (           |           )
                ( BB31   0  | BB32   0  )   ( BB1  *  )
  B := P' B P = (-----------+-----------) = (         ).
                (   0    0  |   0  BB24 )   (  0  BB2 )
                (           |           )
                (   0    0  | BB42   0  )

  Then, further orthogonal transformations that are provided by
  MB03FD and MB03DD are used to triangularize the subpencil
  aAA1 - bBB1.

  Finally, the subpencil aAA2 - bBB2 is triangularized by applying a
  special permutation matrix.

  See also page 31 in [1] for more details.
References 
  [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
      Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
      Eigenproblems.
      Tech. Rep., Technical University Chemnitz, Germany,
      Nov. 2007.

  [2] Bojanczyk, A., Golub, G. H. and Van Dooren, P.
      The periodic Schur decomposition: algorithms and applications.
      In F.T. Luk (editor), Advanced Signal Processing Algorithms,
      Architectures, and Implementations III, Proc. SPIE Conference,
      vol. 1770, pp. 31-42, 1992.

  [3] Hench, J. J. and Laub, A. J.
      Numerical Solution of the discrete-time periodic Riccati
      equation. IEEE Trans. Automat. Control, 39, 1197-1210, 1994.
Numerical Aspects 
                                                            3
  The algorithm is numerically backward stable and needs O(N ) real
  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04ID.html000077500000000000000000000125461201767322700160730ustar00rootroot00000000000000 MB04ID - SLICOT Library Routine Documentation

MB04ID

QR factorization of a matrix with a lower left-hand side zero triangle

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a QR factorization of an n-by-m matrix A (A = Q * R),
  having a p-by-min(p,m) zero triangle in the lower left-hand side
  corner, as shown below, for n = 8, m = 7, and p = 2:

         [ x x x x x x x ]
         [ x x x x x x x ]
         [ x x x x x x x ]
         [ x x x x x x x ]
     A = [ x x x x x x x ],
         [ x x x x x x x ]
         [ 0 x x x x x x ]
         [ 0 0 x x x x x ]

  and optionally apply the transformations to an n-by-l matrix B
  (from the left). The problem structure is exploited. This
  computation is useful, for instance, in combined measurement and
  time update of one iteration of the time-invariant Kalman filter
  (square root information filter).
Specification 
      SUBROUTINE MB04ID( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, LDB, LDWORK, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), TAU(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of rows of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrix A.  M >= 0.

  P       (input) INTEGER
          The order of the zero triagle.  P >= 0.

  L       (input) INTEGER
          The number of columns of the matrix B.  L >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix A. The elements corresponding to the
          zero P-by-MIN(P,M) lower trapezoidal/triangular part
          (if P > 0) are not referenced.
          On exit, the elements on and above the diagonal of this
          array contain the MIN(N,M)-by-M upper trapezoidal matrix
          R (R is upper triangular, if N >= M) of the QR
          factorization, and the relevant elements below the
          diagonal contain the trailing components (the vectors v,
          see Method) of the elementary reflectors used in the
          factorization.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,L)
          On entry, the leading N-by-L part of this array must
          contain the matrix B.
          On exit, the leading N-by-L part of this array contains
          the updated matrix B.
          If L = 0, this array is not referenced.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,N) if L > 0;
          LDB >= 1        if L = 0.

  TAU     (output) DOUBLE PRECISION array, dimension MIN(N,M)
          The scalar factors of the elementary reflectors used.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,M-1,M-P,L).
          For optimum performance LDWORK should be larger.

          If LDWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          DWORK array, returns this value as the first entry of
          the DWORK array, and no error message related to LDWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine uses min(N,M) Householder transformations exploiting
  the zero pattern of the matrix.  A Householder matrix has the form

                                  ( 1 ),
     H  = I - tau *u *u',    u  = ( v )
      i          i  i  i      i   (  i)

  where v  is an (N-P+I-2)-vector.  The components of v  are stored
         i                                             i
  in the i-th column of A, beginning from the location i+1, and
  tau  is stored in TAU(i).
     i
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04IY.html000077500000000000000000000121211201767322700161050ustar00rootroot00000000000000 MB04IY - SLICOT Library Routine Documentation

MB04IY

Applying the product of elementary reflectors used for QR factorization of a matrix having a lower left zero triangle

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To overwrite the real n-by-m matrix  C  with  Q' * C,  Q * C,
  C * Q',  or  C * Q,  according to the following table

                  SIDE = 'L'     SIDE = 'R'
  TRANS = 'N':      Q * C          C * Q
  TRANS = 'T':      Q'* C          C * Q'

  where  Q  is a real orthogonal matrix defined as the product of
  k elementary reflectors

     Q = H(1) H(2) . . . H(k)

  as returned by SLICOT Library routine MB04ID.  Q  is of order n
  if  SIDE = 'L'  and of order m if  SIDE = 'R'.
Specification 
      SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC,
     $                   DWORK, LDWORK, INFO )
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( * )
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Specify if  Q  or  Q'  is applied from the left or right,
          as follows:
          = 'L':  apply  Q  or  Q'  from the left;
          = 'R':  apply  Q  or  Q'  from the right.

  TRANS   CHARACTER*1
          Specify if  Q  or  Q'  is to be applied, as follows:
          = 'N':  apply  Q   (No transpose);
          = 'T':  apply  Q'  (Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The number of rows of the matrix C.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrix C.  M >= 0.

  K       (input) INTEGER
          The number of elementary reflectors whose product defines
          the matrix Q.
          N >= K >= 0,  if  SIDE = 'L';
          M >= K >= 0,  if  SIDE = 'R'.

  P       (input) INTEGER
          The order of the zero triagle (or the number of rows of
          the zero trapezoid) in the matrix triangularized by SLICOT
          Library routine MB04ID.  P >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
          On input, the elements in the rows  i+1:min(n,n-p-1+i)  of
          the  i-th  column, and  TAU(i),  represent the orthogonal
          reflector  H(i),  so that matrix  Q  is the product of
          elementary reflectors:  Q = H(1) H(2) . . . H(k).
          A is modified by the routine but restored on exit.

  LDA     INTEGER
          The leading dimension of the array  A.
          LDA >= max(1,N),  if  SIDE = 'L';
          LDA >= max(1,M),  if  SIDE = 'R'.

  TAU     (input) DOUBLE PRECISION array, dimension (K)
          The scalar factors of the elementary reflectors.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix  C.
          On exit, the leading N-by-M part of this array contains
          the updated matrix C.

  LDC     INTEGER
          The leading dimension of the array  C.  LDC >= max(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,M),  if  SIDE = 'L';
          LDWORK >= MAX(1,N),  if  SIDE = 'R'.
          For optimum performance LDWORK >= M*NB if SIDE = 'L',
          or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal
          block size.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  If  SIDE = 'L',  each elementary reflector  H(i)  modifies
  n-p  elements of each column of  C,  for  i = 1:p+1,  and
  n-i+1  elements, for  i = p+2:k.
  If  SIDE = 'R',  each elementary reflector  H(i)  modifies
  m-p  elements of each row of  C,  for  i = 1:p+1,  and
  m-i+1  elements, for  i = p+2:k.
Numerical Aspects 
  The implemented method is numerically stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04IZ.html000077500000000000000000000125351201767322700161170ustar00rootroot00000000000000 MB04IZ - SLICOT Library Routine Documentation

MB04IZ

QR factorization of a matrix with a lower left-hand side zero triangle (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a QR factorization of an n-by-m matrix A (A = Q * R),
  having a p-by-min(p,m) zero triangle in the lower left-hand side
  corner, as shown below, for n = 8, m = 7, and p = 2:

         [ x x x x x x x ]
         [ x x x x x x x ]
         [ x x x x x x x ]
         [ x x x x x x x ]
     A = [ x x x x x x x ],
         [ x x x x x x x ]
         [ 0 x x x x x x ]
         [ 0 0 x x x x x ]

  and optionally apply the transformations to an n-by-l matrix B
  (from the left). The problem structure is exploited. This
  computation is useful, for instance, in combined measurement and
  time update of one iteration of the time-invariant Kalman filter
  (square root information filter).
Specification 
      SUBROUTINE MB04IZ( N, M, P, L, A, LDA, B, LDB, TAU, ZWORK, LZWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, LDB, LZWORK, M, N, P
C     .. Array Arguments ..
      COMPLEX*16        A(LDA,*), B(LDB,*), TAU(*), ZWORK(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of rows of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrix A.  M >= 0.

  P       (input) INTEGER
          The order of the zero triagle.  P >= 0.

  L       (input) INTEGER
          The number of columns of the matrix B.  L >= 0.

  A       (input/output) COMPLEX*16 array, dimension (LDA,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix A. The elements corresponding to the
          zero P-by-MIN(P,M) lower trapezoidal/triangular part
          (if P > 0) are not referenced.
          On exit, the elements on and above the diagonal of this
          array contain the MIN(N,M)-by-M upper trapezoidal matrix
          R (R is upper triangular, if N >= M) of the QR
          factorization, and the relevant elements below the
          diagonal contain the trailing components (the vectors v,
          see Method) of the elementary reflectors used in the
          factorization.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) COMPLEX*16 array, dimension (LDB,L)
          On entry, the leading N-by-L part of this array must
          contain the matrix B.
          On exit, the leading N-by-L part of this array contains
          the updated matrix B.
          If L = 0, this array is not referenced.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,N) if L > 0;
          LDB >= 1        if L = 0.

  TAU     (output) COMPLEX*16 array, dimension MIN(N,M)
          The scalar factors of the elementary reflectors used.
Workspace 
  ZWORK   COMPLEX*16 array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) returns the optimal value
          of LZWORK.

  LZWORK  The length of the array ZWORK.
          LZWORK >= MAX(1,M-1,M-P,L).
          For optimum performance LZWORK should be larger.

          If LZWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          ZWORK array, returns this value as the first entry of
          the ZWORK array, and no error message related to LZWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine uses min(N,M) Householder transformations exploiting
  the zero pattern of the matrix.  A Householder matrix has the form

                                  ( 1 ),
     H  = I - tau *u *u',    u  = ( v )
      i          i  i  i      i   (  i)

  where v  is an (N-P+I-2)-vector.  The components of v  are stored
         i                                             i
  in the i-th column of A, beginning from the location i+1, and
  tau  is stored in TAU(i).
     i
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04JD.html000077500000000000000000000121051201767322700160630ustar00rootroot00000000000000 MB04JD - SLICOT Library Routine Documentation

MB04JD

LQ factorization of a matrix with an upper right-hand side zero triangle

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an LQ factorization of an n-by-m matrix A (A = L * Q),
  having a min(n,p)-by-p zero triangle in the upper right-hand side
  corner, as shown below, for n = 8, m = 7, and p = 2:

         [ x x x x x 0 0 ]
         [ x x x x x x 0 ]
         [ x x x x x x x ]
         [ x x x x x x x ]
     A = [ x x x x x x x ],
         [ x x x x x x x ]
         [ x x x x x x x ]
         [ x x x x x x x ]

  and optionally apply the transformations to an l-by-m matrix B
  (from the right). The problem structure is exploited. This
  computation is useful, for instance, in combined measurement and
  time update of one iteration of the time-invariant Kalman filter
  (square root covariance filter).
Specification 
      SUBROUTINE MB04JD( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, LDB, LDWORK, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), TAU(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of rows of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrix A.  M >= 0.

  P       (input) INTEGER
          The order of the zero triagle.  P >= 0.

  L       (input) INTEGER
          The number of rows of the matrix B.  L >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix A. The elements corresponding to the
          zero MIN(N,P)-by-P upper trapezoidal/triangular part
          (if P > 0) are not referenced.
          On exit, the elements on and below the diagonal of this
          array contain the N-by-MIN(N,M) lower trapezoidal matrix
          L (L is lower triangular, if N <= M) of the LQ
          factorization, and the relevant elements above the
          diagonal contain the trailing components (the vectors v,
          see Method) of the elementary reflectors used in the
          factorization.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the matrix B.
          On exit, the leading L-by-M part of this array contains
          the updated matrix B.
          If L = 0, this array is not referenced.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,L).

  TAU     (output) DOUBLE PRECISION array, dimension MIN(N,M)
          The scalar factors of the elementary reflectors used.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  The length of the array DWORK.
          LDWORK >= MAX(1,N-1,N-P,L).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine uses min(N,M) Householder transformations exploiting
  the zero pattern of the matrix.  A Householder matrix has the form

                                  ( 1 ),
     H  = I - tau *u *u',    u  = ( v )
      i          i  i  i      i   (  i)

  where v  is an (M-P+I-2)-vector.  The components of v  are stored
         i                                             i
  in the i-th row of A, beginning from the location i+1, and tau
                                                                i
  is stored in TAU(i).
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04KD.html000077500000000000000000000126441201767322700160740ustar00rootroot00000000000000 MB04KD - SLICOT Library Routine Documentation

MB04KD

QR factorization of a special structured block matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate a QR factorization of the first block column and
  apply the orthogonal transformations (from the left) also to the
  second block column of a structured matrix, as follows
                       _
         [ R   0 ]   [ R   C ]
    Q' * [       ] = [       ]
         [ A   B ]   [ 0   D ]
              _
  where R and R are upper triangular. The matrix A can be full or
  upper trapezoidal/triangular. The problem structure is exploited.
  This computation is useful, for instance, in combined measurement
  and time update of one iteration of the Kalman filter (square
  root information filter).
Specification 
      SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC,
     $                   TAU, DWORK )
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(*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Indicates if the matrix A is or not triangular as follows:
          = 'U':  Matrix A is upper trapezoidal/triangular;
          = 'F':  Matrix A is full.
Input/Output Parameters 
  N       (input) INTEGER                 _
          The order of the matrices R and R.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrices B, C and D.  M >= 0.

  P       (input) INTEGER
          The number of rows of the matrices A, B and D.  P >= 0.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the upper triangular matrix R.
          On exit, the leading N-by-N upper triangular part of this
                                                     _
          array contains the upper triangular matrix R.
          The strict lower triangular part of this array is not
          referenced.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, if UPLO = 'F', the leading P-by-N part of this
          array must contain the matrix A. If UPLO = 'U', the
          leading MIN(P,N)-by-N part of this array must contain the
          upper trapezoidal (upper triangular if P >= N) matrix A,
          and the elements below the diagonal are not referenced.
          On exit, the leading P-by-N part (upper trapezoidal or
          triangular, if UPLO = 'U') of this array contains the
          trailing components (the vectors v, see Method) of the
          elementary reflectors used in the factorization.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,P).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading P-by-M part of this array must
          contain the matrix B.
          On exit, the leading P-by-M part of this array contains
          the computed matrix D.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,P).

  C       (output) DOUBLE PRECISION array, dimension (LDC,M)
          The leading N-by-M part of this array contains the
          computed matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The scalar factors of the elementary reflectors used.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Method 
  The routine uses N Householder transformations exploiting the zero
  pattern of the block matrix.  A Householder matrix has the form

                                  ( 1 ),
     H  = I - tau *u *u',    u  = ( v )
      i          i  i  i      i   (  i)

  where v  is a P-vector, if UPLO = 'F', or an min(i,P)-vector, if
         i
  UPLO = 'U'.  The components of v  are stored in the i-th column
                                  i
  of A, and tau  is stored in TAU(i).
               i
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04LD.html000077500000000000000000000126171201767322700160750ustar00rootroot00000000000000 MB04LD - SLICOT Library Routine Documentation

MB04LD

LQ factorization of a special structured block matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate an LQ factorization of the first block row and apply
  the orthogonal transformations (from the right) also to the second
  block row of a structured matrix, as follows
                     _
     [ L   A ]     [ L   0 ]
     [       ]*Q = [       ]
     [ 0   B ]     [ C   D ]
              _
  where L and L are lower triangular. The matrix A can be full or
  lower trapezoidal/triangular. The problem structure is exploited.
  This computation is useful, for instance, in combined measurement
  and time update of one iteration of the Kalman filter (square
  root covariance filter).
Specification 
      SUBROUTINE MB04LD( UPLO, N, M, P, L, LDL, A, LDA, B, LDB, C, LDC,
     $                   TAU, DWORK )
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(*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Indicates if the matrix A is or not triangular as follows:
          = 'L':  Matrix A is lower trapezoidal/triangular;
          = 'F':  Matrix A is full.
Input/Output Parameters 
  N       (input) INTEGER                 _
          The order of the matrices L and L.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrices A, B and D.  M >= 0.

  P       (input) INTEGER
          The number of rows of the matrices B, C and D.  P >= 0.

  L       (input/output) DOUBLE PRECISION array, dimension (LDL,N)
          On entry, the leading N-by-N lower triangular part of this
          array must contain the lower triangular matrix L.
          On exit, the leading N-by-N lower triangular part of this
                                                     _
          array contains the lower triangular matrix L.
          The strict upper triangular part of this array is not
          referenced.

  LDL     INTEGER
          The leading dimension of array L.  LDL >= MAX(1,N).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
          On entry, if UPLO = 'F', the leading N-by-M part of this
          array must contain the matrix A. If UPLO = 'L', the
          leading N-by-MIN(N,M) part of this array must contain the
          lower trapezoidal (lower triangular if N <= M) matrix A,
          and the elements above the diagonal are not referenced.
          On exit, the leading N-by-M part (lower trapezoidal or
          triangular, if UPLO = 'L') of this array contains the
          trailing components (the vectors v, see Method) of the
          elementary reflectors used in the factorization.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading P-by-M part of this array must
          contain the matrix B.
          On exit, the leading P-by-M part of this array contains
          the computed matrix D.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,P).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array contains the
          computed matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The scalar factors of the elementary reflectors used.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Method 
  The routine uses N Householder transformations exploiting the zero
  pattern of the block matrix.  A Householder matrix has the form

                                  ( 1 ),
     H  = I - tau *u *u',    u  = ( v )
      i          i  i  i      i   (  i)

  where v  is an M-vector, if UPLO = 'F', or an min(i,M)-vector, if
         i
  UPLO = 'L'.  The components of v  are stored in the i-th row of A,
                                  i
  and tau  is stored in TAU(i).
         i
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04MD.html000077500000000000000000000142621201767322700160740ustar00rootroot00000000000000 MB04MD - SLICOT Library Routine Documentation

MB04MD

Balancing a general real matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the 1-norm of a general real matrix A by balancing.
  This involves diagonal similarity transformations applied
  iteratively to A to make the rows and columns as close in norm as
  possible.

  This routine can be used instead LAPACK Library routine DGEBAL,
  when no reduction of the 1-norm of the matrix is possible with
  DGEBAL, as for upper triangular matrices. LAPACK Library routine
  DGEBAK, with parameters ILO = 1, IHI = N, and JOB = 'S', should
  be used to apply the backward transformation.
Specification 
      SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   MAXRED
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), SCALE( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  MAXRED  (input/output) DOUBLE PRECISION
          On entry, the maximum allowed reduction in the 1-norm of
          A (in an iteration) if zero rows or columns are
          encountered.
          If MAXRED > 0.0, MAXRED must be larger than one (to enable
          the norm reduction).
          If MAXRED <= 0.0, then the value 10.0 for MAXRED is
          used.
          On exit, if the 1-norm of the given matrix A is non-zero,
          the ratio between the 1-norm of the given matrix and the
          1-norm of the balanced matrix. Usually, this ratio will be
          larger than one, but it can sometimes be one, or even less
          than one (for instance, for some companion matrices).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the input matrix A.
          On exit, the leading N-by-N part of this array contains
          the balanced matrix.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  SCALE   (output) DOUBLE PRECISION array, dimension (N)
          The scaling factors applied to A.  If D(j) is the scaling
          factor applied to row and column j, then SCALE(j) = D(j),
          for j = 1,...,N.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Balancing consists of applying a diagonal similarity
  transformation inv(D) * A * D to make the 1-norms of each row
  of A and its corresponding column nearly equal.

  Information about the diagonal matrix D is returned in the vector
  SCALE.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MB04MD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      DOUBLE PRECISION MAXRED
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), SCALE(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB04MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, MAXRED
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Balance matrix A.
         CALL MB04MD( N, MAXRED, A, LDA, SCALE, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) ( SCALE(I), I = 1,N )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04MD = ',I2)
99997 FORMAT (' The balanced matrix is ')
99996 FORMAT (20(1X,F10.4))
99994 FORMAT (/' SCALE is ',/20(1X,F10.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB04MD EXAMPLE PROGRAM DATA
   4    0.0
   1.0   0.0   0.0   0.0
 300.0 400.0 500.0 600.0
   1.0   2.0   0.0   0.0
   1.0   1.0   1.0   1.0
Program Results 
 MB04MD EXAMPLE PROGRAM RESULTS

 The balanced matrix is 
     1.0000     0.0000     0.0000     0.0000
    30.0000   400.0000    50.0000    60.0000
     1.0000    20.0000     0.0000     0.0000
     1.0000    10.0000     1.0000     1.0000

 SCALE is 
     1.0000    10.0000     1.0000     1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04ND.html000077500000000000000000000136761201767322700161050ustar00rootroot00000000000000 MB04ND - SLICOT Library Routine Documentation

MB04ND

RQ factorization of a special structured block matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate an RQ factorization of the first block row and
  apply the orthogonal transformations (from the right) also to the
  second block row of a structured matrix, as follows
                           _
    [ A   R ]        [ 0   R ]
    [       ] * Q' = [ _   _ ]
    [ C   B ]        [ C   B ]
              _
  where R and R are upper triangular. The matrix A can be full or
  upper trapezoidal/triangular. The problem structure is exploited.
Specification 
      SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC,
     $                   TAU, DWORK )
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(*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Indicates if the matrix A is or not triangular as follows:
          = 'U':  Matrix A is upper trapezoidal/triangular;
          = 'F':  Matrix A is full.
Input/Output Parameters 
  N       (input) INTEGER                 _
          The order of the matrices R and R.  N >= 0.

  M       (input) INTEGER
          The number of rows of the matrices B and C.  M >= 0.

  P       (input) INTEGER
          The number of columns of the matrices A and C.  P >= 0.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the upper triangular matrix R.
          On exit, the leading N-by-N upper triangular part of this
                                                     _
          array contains the upper triangular matrix R.
          The strict lower triangular part of this array is not
          referenced.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,P)
          On entry, if UPLO = 'F', the leading N-by-P part of this
          array must contain the matrix A. For UPLO = 'U', if
          N <= P, the upper triangle of the subarray A(1:N,P-N+1:P)
          must contain the N-by-N upper triangular matrix A, and if
          N >= P, the elements on and above the (N-P)-th subdiagonal
          must contain the N-by-P upper trapezoidal matrix A.
          On exit, if UPLO = 'F', the leading N-by-P part of this
          array contains the trailing components (the vectors v, see
          METHOD) of the elementary reflectors used in the
          factorization. If UPLO = 'U', the upper triangle of the
          subarray A(1:N,P-N+1:P) (if N <= P), or the elements on
          and above the (N-P)-th subdiagonal (if N >= P), contain
          the trailing components (the vectors v, see METHOD) of the
          elementary reflectors used in the factorization.
          The remaining elements are not referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix B.
          On exit, the leading M-by-N part of this array contains
                              _
          the computed matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,P)
          On entry, the leading M-by-P part of this array must
          contain the matrix C.
          On exit, the leading M-by-P part of this array contains
                              _
          the computed matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The scalar factors of the elementary reflectors used.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (MAX(N-1,M))
Method 
  The routine uses N Householder transformations exploiting the zero
  pattern of the block matrix.  A Householder matrix has the form

                                  ( 1 )
     H  = I - tau *u *u',    u  = ( v ),
      i          i  i  i      i   (  i)

  where v  is a P-vector, if UPLO = 'F', or a min(N-i+1,P)-vector,
         i
  if UPLO = 'U'.  The components of v  are stored in the i-th row
                                     i
  of A, and tau  is stored in TAU(i), i = N,N-1,...,1.
               i
  In-line code for applying Householder transformations is used
  whenever possible (see MB04NY routine).
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04NY.html000077500000000000000000000067761201767322700161350ustar00rootroot00000000000000 MB04NY - SLICOT Library Routine Documentation

MB04NY

Applying an elementary reflector (using in-line code for a low order) to a matrix C = ( A B ), from the right, where A has one column

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply a real elementary reflector H to a real m-by-(n+1)
  matrix C = [ A  B ], from the right, where A has one column. H is
  represented in the form
                                     ( 1 )
        H = I - tau * u *u',    u  = (   ),
                                     ( v )
  where tau is a real scalar and v is a real n-vector.

  If tau = 0, then H is taken to be the unit matrix.

  In-line code is used if H has order < 11.
Specification 
      SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK )
C     .. Scalar Arguments ..
      INTEGER           INCV, LDA, LDB, M, N
      DOUBLE PRECISION  TAU
C     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA, * ), B( LDB, * ), DWORK( * ), V( * )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrices A and B.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix B.  N >= 0.

  V       (input) DOUBLE PRECISION array, dimension
          (1+(N-1)*ABS( INCV ))
          The vector v in the representation of H.

  INCV    (input) INTEGER
          The increment between the elements of v.  INCV <> 0.

  TAU     (input) DOUBLE PRECISION
          The scalar factor of the elementary reflector H.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,1)
          On entry, the leading M-by-1 part of this array must
          contain the matrix A.
          On exit, the leading M-by-1 part of this array contains
          the updated matrix A (the first column of C * H).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix B.
          On exit, the leading M-by-N part of this array contains
          the updated matrix B (the last n columns of C * H).

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (M)
          DWORK is not referenced if H has order less than 11.
Method 
  The routine applies the elementary reflector H, taking the special
  structure of C into account.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04OD.html000077500000000000000000000220301201767322700160660ustar00rootroot00000000000000 MB04OD - SLICOT Library Routine Documentation

MB04OD

QR factorization of a special structured block matrix (variant)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate a QR factorization of the first block column and
  apply the orthogonal transformations (from the left) also to the
  second block column of a structured matrix, as follows
                       _   _
         [ R   B ]   [ R   B ]
    Q' * [       ] = [     _ ]
         [ A   C ]   [ 0   C ]
              _
  where R and R are upper triangular. The matrix A can be full or
  upper trapezoidal/triangular. The problem structure is exploited.
Specification 
      SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC,
     $                   TAU, DWORK )
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(*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Indicates if the matrix A is or not triangular as follows:
          = 'U':  Matrix A is upper trapezoidal/triangular;
          = 'F':  Matrix A is full.
Input/Output Parameters 
  N       (input) INTEGER                 _
          The order of the matrices R and R.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrices B and C.  M >= 0.

  P       (input) INTEGER
          The number of rows of the matrices A and C.  P >= 0.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the upper triangular matrix R.
          On exit, the leading N-by-N upper triangular part of this
                                                     _
          array contains the upper triangular matrix R.
          The strict lower triangular part of this array is not
          referenced.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, if UPLO = 'F', the leading P-by-N part of this
          array must contain the matrix A. If UPLO = 'U', the
          leading MIN(P,N)-by-N part of this array must contain the
          upper trapezoidal (upper triangular if P >= N) matrix A,
          and the elements below the diagonal are not referenced.
          On exit, the leading P-by-N part (upper trapezoidal or
          triangular, if UPLO = 'U') of this array contains the
          trailing components (the vectors v, see Method) of the
          elementary reflectors used in the factorization.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,P).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix B.
          On exit, the leading N-by-M part of this array contains
                              _
          the computed matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
          On entry, the leading P-by-M part of this array must
          contain the matrix C.
          On exit, the leading P-by-M part of this array contains
                              _
          the computed matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The scalar factors of the elementary reflectors used.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (MAX(N-1,M))
Method 
  The routine uses N Householder transformations exploiting the zero
  pattern of the block matrix.  A Householder matrix has the form

                                  ( 1 )
     H  = I - tau *u *u',    u  = ( v ),
      i          i  i  i      i   (  i)

  where v  is a P-vector, if UPLO = 'F', or a min(i,P)-vector, if
         i
  UPLO = 'U'.  The components of v  are stored in the i-th column
                                  i
  of A, and tau  is stored in TAU(i).
               i
  In-line code for applying Householder transformations is used
  whenever possible (see MB04OY routine).
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

*     MB04OD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        (ZERO  = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, PMAX
      PARAMETER        ( MMAX = 20, NMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDR
      PARAMETER        ( LDA = PMAX, LDB = NMAX, LDC = PMAX,
     $                   LDR = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX-1,MMAX ) )
*     .. Local Scalars ..
      CHARACTER*1      UPLO
      INTEGER          I, J, M, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX),
     $                 DWORK(LDWORK), R(LDR,NMAX), TAU(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB04OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, UPLO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,N ), I = 1,N )
               READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,P )
*              Compute and apply QR factorization.
               CALL MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C,
     $                      LDC,  TAU, DWORK )
*
               WRITE ( NOUT, FMT = 99997 )
               DO 40 I = 1, N
                  DO 20 J = 1, I-1
                     R(I,J) = ZERO
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99996 ) ( R(I,J), J = 1,N )
   40          CONTINUE
               IF ( M.GT.0 ) THEN
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   60             CONTINUE
                  IF ( P.GT.0 ) THEN
                     WRITE ( NOUT, FMT = 99994 )
                     DO 80 I = 1, P
                        WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M )
   80                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04OD EXAMPLE PROGRAM RESULTS',/1X)
99997 FORMAT (' The updated matrix R is ')
99996 FORMAT (20(1X,F10.4))
99995 FORMAT (' The updated matrix B is ')
99994 FORMAT (' The updated matrix C is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 MB04OD EXAMPLE PROGRAM DATA
   3     2     2     F
   3.    2.    1.
   0.    2.    1.
   0.    0.    1.
   2.    3.    1.
   4.    6.    5.
   3.    2.
   1.    3.
   3.    2.
   1.    3.
   3.    2.
Program Results 
 MB04OD EXAMPLE PROGRAM RESULTS

 The updated matrix R is 
    -5.3852    -6.6850    -4.6424
     0.0000    -2.8828    -2.0694
     0.0000     0.0000    -1.7793
 The updated matrix B is 
    -4.2710    -3.7139
    -0.1555    -2.1411
    -1.6021     0.9398
 The updated matrix C is 
     0.5850     1.0141
    -2.7974    -3.1162

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04OW.html000077500000000000000000000131431201767322700161160ustar00rootroot00000000000000 MB04OW - SLICOT Library Routine Documentation

MB04OW

Rank-one update of a Cholesky factorization (variant)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the QR factorization

     ( U  ) = Q*( R ),  where  U = ( U1  U2 ),  R = ( R1  R2 ),
     ( x' )     ( 0 )              ( 0   T  )       ( 0   R3 )

  where U and R are (m+n)-by-(m+n) upper triangular matrices, x is
  an m+n element vector, U1 is m-by-m, T is n-by-n, stored
  separately, and Q is an (m+n+1)-by-(m+n+1) orthogonal matrix.

  The matrix ( U1 U2 ) must be supplied in the m-by-(m+n) upper
  trapezoidal part of the array A and this is overwritten by the
  corresponding part ( R1 R2 ) of R. The remaining upper triangular
  part of R, R3, is overwritten on the array T.

  The transformations performed are also applied to the (m+n+1)-by-p
  matrix ( B' C' d )' (' denotes transposition), where B, C, and d'
  are m-by-p, n-by-p, and 1-by-p matrices, respectively.
Specification 
      SUBROUTINE MB04OW( M, N, P, A, LDA, T, LDT, X, INCX, B, LDB,
     $                   C, LDC, D, INCD )
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(*)
Arguments

Input/Output Parameters 

  M      (input) INTEGER
         The number of rows of the matrix ( U1  U2 ).  M >= 0.

  N      (input) INTEGER
         The order of the matrix T.  N >= 0.

  P      (input) INTEGER
         The number of columns of the matrices B and C.  P >= 0.

  A      (input/output) DOUBLE PRECISION array, dimension (LDA,N)
         On entry, the leading M-by-(M+N) upper trapezoidal part of
         this array must contain the upper trapezoidal matrix
         ( U1 U2 ).
         On exit, the leading M-by-(M+N) upper trapezoidal part of
         this array contains the upper trapezoidal matrix ( R1 R2 ).
         The strict lower triangle of A is not referenced.

  LDA    INTEGER
         The leading dimension of the array A.  LDA >= max(1,M).

  T      (input/output) DOUBLE PRECISION array, dimension (LDT,N)
         On entry, the leading N-by-N upper triangular part of this
         array must contain the upper triangular matrix T.
         On exit, the leading N-by-N upper triangular part of this
         array contains the upper triangular matrix R3.
         The strict lower triangle of T is not referenced.

  LDT    INTEGER
         The leading dimension of the array T.  LDT >= max(1,N).

  X      (input/output) DOUBLE PRECISION array, dimension
         (1+(M+N-1)*INCX), if M+N > 0, or dimension (0), if M+N = 0.
         On entry, the incremented array X must contain the
         vector x. On exit, the content of X is changed.

  INCX   (input) INTEGER
         Specifies the increment for the elements of X.  INCX > 0.

  B      (input/output) DOUBLE PRECISION array, dimension (LDB,P)
         On entry, the leading M-by-P part of this array must
         contain the matrix B.
         On exit, the leading M-by-P part of this array contains
         the transformed matrix B.
         If M = 0 or P = 0, this array is not referenced.

  LDB    INTEGER
         The leading dimension of the array B.
         LDB >= max(1,M), if P > 0;
         LDB >= 1,        if P = 0.

  C      (input/output) DOUBLE PRECISION array, dimension (LDC,P)
         On entry, the leading N-by-P part of this array must
         contain the matrix C.
         On exit, the leading N-by-P part of this array contains
         the transformed matrix C.
         If N = 0 or P = 0, this array is not referenced.

  LDC    INTEGER
         The leading dimension of the array C.
         LDC >= max(1,N), if P > 0;
         LDC >= 1,        if P = 0.

  D      (input/output) DOUBLE PRECISION array, dimension
         (1+(P-1)*INCD), if P > 0, or dimension (0), if P = 0.
         On entry, the incremented array D must contain the
         vector d.
         On exit, this incremented array contains the transformed
         vector d.
         If P = 0, this array is not referenced.

  INCD   (input) INTEGER
         Specifies the increment for the elements of D.  INCD > 0.
Method 
  Let q = m+n. The matrix Q is formed as a sequence of plane
  rotations in planes (1, q+1), (2, q+1), ..., (q, q+1), the
  rotation in the (j, q+1)th plane, Q(j), being chosen to
  annihilate the jth element of x.
Numerical Aspects 
  The algorithm requires 0((M+N)*(M+N+P)) operations and is backward
  stable.
Further Comments 
  For P = 0, this routine produces the same result as SLICOT Library
  routine MB04OX, but matrix T may not be stored in the array A.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04OX.html000077500000000000000000000052371201767322700161240ustar00rootroot00000000000000 MB04OX - SLICOT Library Routine Documentation

MB04OX

Rank-one update of a Cholesky factorization

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the QR factorization

     (U ) = Q*(R),
     (x')     (0)

  where U and R are n-by-n upper triangular matrices, x is an
  n element vector and Q is an (n+1)-by-(n+1) orthogonal matrix.

  U must be supplied in the n-by-n upper triangular part of the
  array A and this is overwritten by R.
Specification 
      SUBROUTINE MB04OX( N, A, LDA, X, INCX )
C     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), X(*)
Arguments

Input/Output Parameters 

  N      (input) INTEGER
         The number of elements of X and the order of the square
         matrix A.  N >= 0.

  A      (input/output) DOUBLE PRECISION array, dimension (LDA,N)
         On entry, the leading N-by-N upper triangular part of this
         array must contain the upper triangular matrix U.
         On exit, the leading N-by-N upper triangular part of this
         array contains the upper triangular matrix R.
         The strict lower triangle of A is not referenced.

  LDA    INTEGER
         The leading dimension of the array A.  LDA >= max(1,N).

  X      (input/output) DOUBLE PRECISION array, dimension
         (1+(N-1)*INCX)
         On entry, the incremented array X must contain the
         vector x. On exit, the content of X is changed.

  INCX   (input) INTEGER.
         Specifies the increment for the elements of X.  INCX > 0.
Method 
  The matrix Q is formed as a sequence of plane rotations in planes
  (1, n+1), (2, n+1), ..., (n, n+1), the rotation in the (j, n+1)th
  plane, Q(j), being chosen to annihilate the jth element of x.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04OY.html000077500000000000000000000066041201767322700161240ustar00rootroot00000000000000 MB04OY - SLICOT Library Routine Documentation

MB04OY

Applying an elementary reflector (using in-line code for a low order) to a matrix C = trans( trans(A) trans(B) ), from the left, where A has one row

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply a real elementary reflector H to a real (m+1)-by-n
  matrix C = [ A ], from the left, where A has one row. H is
             [ B ]
  represented in the form
                                     ( 1 )
        H = I - tau * u *u',    u  = (   ),
                                     ( v )
  where tau is a real scalar and v is a real m-vector.

  If tau = 0, then H is taken to be the unit matrix.

  In-line code is used if H has order < 11.
Specification 
      SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK )
C     .. Scalar Arguments ..
      INTEGER           LDA, LDB, M, N
      DOUBLE PRECISION  TAU
C     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA, * ), B( LDB, * ), DWORK( * ), V( * )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrix B.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrices A and B.  N >= 0.

  V       (input) DOUBLE PRECISION array, dimension (M)
          The vector v in the representation of H.

  TAU     (input) DOUBLE PRECISION
          The scalar factor of the elementary reflector H.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading 1-by-N part of this array must
          contain the matrix A.
          On exit, the leading 1-by-N part of this array contains
          the updated matrix A (the first row of H * C).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= 1.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix B.
          On exit, the leading M-by-N part of this array contains
          the updated matrix B (the last m rows of H * C).

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
          DWORK is not referenced if H has order less than 11.
Method 
  The routine applies the elementary reflector H, taking the special
  structure of C into account.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04PB.html000077500000000000000000000362731201767322700161030ustar00rootroot00000000000000 MB04PB - SLICOT Library Routine Documentation

MB04PB

Computation of the Paige/Van Loan (PVL) form of a Hamiltonian matrix (block algorithm)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce a Hamiltonian matrix,

                [  A   G  ]
           H =  [       T ] ,
                [  Q  -A  ]

  where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices,
  to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U
  is computed so that

            T       [  Aout   Gout  ]
           U H U =  [             T ] ,
                    [  Qout  -Aout  ]

  where Aout is upper Hessenberg and Qout is diagonal.
  Blocked version.
Specification 
      SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           ILO, INFO, LDA, LDQG, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  ILO     (input) INTEGER
          It is assumed that A is already upper triangular and Q is
          zero in rows and columns 1:ILO-1. ILO is normally set by a
          previous call to MB04DD; otherwise it should be set to 1.
          1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the matrix Aout and, in the zero part of Aout,
          information about the elementary reflectors used to
          compute the PVL factorization.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  QG      (input/output) DOUBLE PRECISION array, dimension
                         (LDQG,N+1)
          On entry, the leading N-by-N+1 part of this array must
          contain the lower triangular part of the matrix Q and
          the upper triangular part of the matrix G.
          On exit, the leading N-by-N+1 part of this array contains
          the diagonal of the matrix Qout, the upper triangular part
          of the matrix Gout and, in the zero parts of Qout,
          information about the elementary reflectors used to
          compute the PVL factorization.

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= MAX(1,N).

  CS      (output) DOUBLE PRECISION array, dimension (2N-2)
          On exit, the first 2N-2 elements of this array contain the
          cosines and sines of the symplectic Givens rotations used
          to compute the PVL factorization.

  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
          On exit, the first N-1 elements of this array contain the
          scalar factors of some of the elementary reflectors.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK, 8*N*NB + 3*NB, where NB is the optimal
          block size determined by the function UE01MD.
          On exit, if  INFO = -10,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N-1).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix U is represented as a product of symplectic reflectors
  and Givens rotators

  U = diag( H(1),H(1) )     G(1)   diag( F(1),F(1) )
      diag( H(2),H(2) )     G(2)   diag( F(2),F(2) )
                             ....
      diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ).

  Each H(i) has the form

        H(i) = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in
  QG(i+2:n,i), and tau in QG(i+1,i).

  Each F(i) has the form

        F(i) = I - nu * w * w'

  where nu is a real scalar, and w is a real vector with
  w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in
  A(i+2:n,i), and nu in TAU(i).

  Each G(i) is a Givens rotator acting on rows i+1 and n+i+1,
  where the cosine is stored in CS(2*i-1) and the sine in
  CS(2*i).
Numerical Aspects 
  The algorithm requires O(N**3) floating point operations and is
  strongly backward stable.
References 
  [1] C. F. VAN LOAN:
      A symplectic method for approximating all the eigenvalues of
      a Hamiltonian matrix.
      Linear Algebra and its Applications, 61, pp. 233-251, 1984.

  [2] D. KRESSNER:
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Further Comments 
  None
Example

Program Text 

*     MB04PB/MB04WP EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE, TWO
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, NBMAX
      PARAMETER        ( NMAX = 7, NBMAX = 3 )
      INTEGER          LDA, LDQG, LDRES, LDU1, LDU2, LDWORK
      PARAMETER        ( LDA  = NMAX, LDQG = NMAX, LDRES = NMAX,
     $                   LDU1 = NMAX, LDU2 = NMAX,
     $                   LDWORK = 8*NBMAX*NMAX + 3*NBMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), CS(2*NMAX), DWORK(LDWORK),
     $                 QG(LDQG, NMAX+1), RES(LDRES,3*NMAX+1), TAU(NMAX),
     $                 U1(LDU1,NMAX), U2(LDU2, NMAX)
*     .. External Functions ..
      DOUBLE PRECISION MA02ID, MA02JD
      EXTERNAL         MA02ID, MA02JD
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DLASET, DSCAL, DSYMM, DSYR,
     $                 DSYR2K, DTRMM, MB04PB, MB04WP
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES )
         CALL MB04PB( N, 1, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK,
     $                INFO )
         INFO = 0
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            CALL DLACPY( 'Lower', N, N, A, LDA, U1, LDU1 )
            CALL DLACPY( 'Lower', N, N, QG, LDQG, U2, LDU2 )
            CALL MB04WP( N, 1, U1, LDU1, U2, LDU2, CS, TAU, DWORK,
     $                   LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               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, QG(2,1),
     $                         LDQG )
               WRITE ( NOUT, FMT = 99996 )
               DO 10  I = 1, N
                  WRITE (NOUT, FMT = 99993)
     $                  ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N )
10             CONTINUE
               DO 20  I = 1, N
                  WRITE (NOUT, FMT = 99993)
     $                  ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N )
20             CONTINUE
               WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., .FALSE., N,
     $                 U1, LDU1, U2, LDU2, RES, LDRES )
               WRITE ( NOUT, FMT = 99995 )
               DO 30  I = 1, N
                  WRITE (NOUT, FMT = 99993) ( A(I,J), J = 1,N )
30             CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 40  I = 1, N
                  WRITE (NOUT, FMT = 99993) ( QG(I,J), J = 1,N+1 )
40             CONTINUE
C
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U1, LDU1, A, LDA, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U1, LDU1, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                     U2, LDU2, A, LDA, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                     RES, LDRES, U2, LDU2, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DSYMM ( 'Right', 'Upper', N, N, ONE, QG(1,2), LDQG,
     $                      U1, LDU1, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U2, LDU2, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DLACPY( 'All', N, N, U2, LDU2, RES, LDRES )
               DO 50 I = 1, N
                   CALL DSCAL( N, QG(I,I), RES(1,I), 1 )
50             CONTINUE
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U1, LDU1, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U2, LDU2, A, LDA, ZERO, RES, LDRES )
               CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U1, LDU1, ONE, RES(1,2*N+1), LDRES )
               CALL DSCAL( N, ONE/TWO, QG(1,2), LDQG+1 )
               CALL DLACPY( 'Full', N, N, U2, LDU2, RES, LDRES )
               CALL DTRMM(  'Right', 'Upper' , 'No Transpose',
     $                      'Not unit', N, N, ONE, QG(1,2), LDQG,
     $                       RES, LDRES )
               CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U2, LDU2, ONE, RES(1,2*N+1), LDRES )
               DO 60  I = 1, N
                  CALL DSYR( 'Lower', N, -QG(I,I), U1(1,I), 1,
     $                       RES(1,2*N+1), LDRES )
60             CONTINUE
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U1, LDU1, A, LDA, ZERO, RES, LDRES )
               CALL DSYR2K( 'Upper', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U2, LDU2, ONE, RES(1,2*N+2), LDRES )
               CALL DLACPY( 'Full', N, N, U1, LDU1, RES, LDRES )
               CALL DTRMM(  'Right', 'Upper' , 'No Transpose',
     $                      'Not unit', N, N, ONE, QG(1,2), LDQG,
     $                       RES, LDRES )
               CALL DSYR2K( 'Upper', 'No Transpose', N, N, -ONE, RES,
     $                      LDRES, U1, LDU1, ONE, RES(1,2*N+2), LDRES )
               DO 70  I = 1, N
                  CALL DSYR( 'Upper', N, QG(I,I), U2(1,I), 1,
     $                       RES(1,2*N+2), LDRES )
70             CONTINUE
C
               WRITE ( NOUT, FMT = 99990 )  MA02ID( 'Hamiltonian',
     $                'Frobenius', N, RES(1,N+1), LDRES, RES(1,2*N+1),
     $                LDRES, DWORK )
            END IF
         END IF
      END IF
*
99999 FORMAT (' TMB04PB EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04PB = ',I2)
99997 FORMAT (' INFO on exit from MB04WP = ',I2)
99996 FORMAT (' The symplectic orthogonal factor U is ')
99995 FORMAT (/' The reduced matrix A is ')
99994 FORMAT (/' The reduced matrix QG is ')
99993 FORMAT (20(1X,F9.4))
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2)
99990 FORMAT (/' Residual: || H - U*R*U'' ||_F = ',G7.2)
      END
Program Data 
MB04PB EXAMPLE PROGRAM DATA
        5
    0.9501    0.7621    0.6154    0.4057    0.0579
    0.2311    0.4565    0.7919    0.9355    0.3529
    0.6068    0.0185    0.9218    0.9169    0.8132
    0.4860    0.8214    0.7382    0.4103    0.0099
    0.8913    0.4447    0.1763    0.8936    0.1389
    0.3869    0.4055    0.2140    1.0224    1.1103    0.7016
    1.3801    0.7567    1.4936    1.2913    0.9515    1.1755
    0.7993    1.7598    1.6433    1.0503    0.8839    1.1010
    1.2019    1.1956    0.9346    0.6824    0.7590    1.1364
    0.8780    0.9029    1.6565    1.1022    0.7408    0.3793
Program Results 
 TMB04PB EXAMPLE PROGRAM RESULTS

 The symplectic orthogonal factor U is 
    1.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.0927    0.2098    0.5594   -0.0226    0.0000    0.5538    0.3184    0.2519   -0.4031
    0.0000   -0.2435    0.4745   -0.6362   -0.2542    0.0000    0.3207   -0.2455    0.0595   -0.2819
    0.0000   -0.1950   -0.1770   -0.1519   -0.2857    0.0000    0.4823    0.4122   -0.2060    0.6173
    0.0000   -0.3576   -0.0480    0.2302    0.4512    0.0000    0.3523   -0.6047   -0.3110    0.1635
    0.0000    0.0000    0.0000    0.0000    0.0000    1.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.5538   -0.3184   -0.2519    0.4031    0.0000   -0.0927    0.2098    0.5594   -0.0226
    0.0000   -0.3207    0.2455   -0.0595    0.2819    0.0000   -0.2435    0.4745   -0.6362   -0.2542
    0.0000   -0.4823   -0.4122    0.2060   -0.6173    0.0000   -0.1950   -0.1770   -0.1519   -0.2857
    0.0000   -0.3523    0.6047    0.3110   -0.1635    0.0000   -0.3576   -0.0480    0.2302    0.4512

 Orthogonality of U: || U'*U - I ||_F = .77E-15

 The reduced matrix A is 
    0.9501   -1.5494    0.5268    0.3187   -0.6890
   -2.4922    2.0907   -1.3598    0.5682    0.5618
    0.0000   -1.7723    0.3960   -0.2624   -0.3709
    0.0000    0.0000   -0.2648    0.2136   -0.3226
    0.0000    0.0000    0.0000   -0.2308    0.2319

 The reduced matrix QG is 
    0.3869    0.4055    0.0992    0.5237   -0.4110   -0.4861
    0.0000   -3.7784   -4.1609    0.3614    0.3606   -0.0696
    0.0000    0.0000    1.2192   -0.0848    0.2007    0.3735
    0.0000    0.0000    0.0000   -0.8646    0.1538   -0.1970
    0.0000    0.0000    0.0000    0.0000   -0.4527    0.0743

 Residual: || H - U*R*U' ||_F = .33E-14

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04PU.html000077500000000000000000000353541201767322700161250ustar00rootroot00000000000000 MB04PU - SLICOT Library Routine Documentation

MB04PU

Computation of the Paige/Van Loan (PVL) form of a Hamiltonian matrix (unblocked algorithm)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce a Hamiltonian matrix,

                [  A   G  ]
           H =  [       T ] ,
                [  Q  -A  ]

  where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices,
  to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U
  is computed so that

            T       [  Aout   Gout  ]
           U H U =  [             T ] ,
                    [  Qout  -Aout  ]

  where Aout is upper Hessenberg and Qout is diagonal.
  Unblocked version.
Specification 
      SUBROUTINE MB04PU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           ILO, INFO, LDA, LDQG, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  ILO     (input) INTEGER
          It is assumed that A is already upper triangular and Q is
          zero in rows and columns 1:ILO-1. ILO is normally set by a
          previous call to MB04DD; otherwise it should be set to 1.
          1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the matrix Aout and, in the zero part of Aout,
          information about the elementary reflectors used to
          compute the PVL factorization.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  QG      (input/output) DOUBLE PRECISION array, dimension
                         (LDQG,N+1)
          On entry, the leading N-by-N+1 part of this array must
          contain the lower triangular part of the matrix Q and
          the upper triangular part of the matrix G.
          On exit, the leading N-by-N+1 part of this array contains
          the diagonal of the matrix Qout, the upper triangular part
          of the matrix Gout and, in the zero parts of Qout,
          information about the elementary reflectors used to
          compute the PVL factorization.

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= MAX(1,N).

  CS      (output) DOUBLE PRECISION array, dimension (2N-2)
          On exit, the first 2N-2 elements of this array contain the
          cosines and sines of the symplectic Givens rotations used
          to compute the PVL factorization.

  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
          On exit, the first N-1 elements of this array contain the
          scalar factors of some of the elementary reflectors.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -10,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N-1).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix U is represented as a product of symplectic reflectors
  and Givens rotators

  U = diag( H(1),H(1) )     G(1)   diag( F(1),F(1) )
      diag( H(2),H(2) )     G(2)   diag( F(2),F(2) )
                             ....
      diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ).

  Each H(i) has the form

        H(i) = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in
  QG(i+2:n,i), and tau in QG(i+1,i).

  Each F(i) has the form

        F(i) = I - nu * w * w'

  where nu is a real scalar, and w is a real vector with
  w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in
  A(i+2:n,i), and nu in TAU(i).

  Each G(i) is a Givens rotator acting on rows i+1 and n+i+1,
  where the cosine is stored in CS(2*i-1) and the sine in
  CS(2*i).
Numerical Aspects 
  The algorithm requires 40/3 N**3 + O(N) floating point operations
  and is strongly backward stable.
References 
  [1] C. F. VAN LOAN:
      A symplectic method for approximating all the eigenvalues of
      a Hamiltonian matrix.
      Linear Algebra and its Applications, 61, pp. 233-251, 1984.
Further Comments 
  None
Example

Program Text 

*     MB04PU/MB04WP EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE, TWO
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDQG, LDRES, LDU1, LDU2, LDWORK
      PARAMETER        ( LDA  = NMAX, LDQG = NMAX, LDRES  = NMAX,
     $                   LDU1 = NMAX, LDU2 = NMAX, LDWORK = 2*NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), CS(2*NMAX), DWORK(LDWORK),
     $                 QG(LDQG, NMAX+1), RES(LDRES,3*NMAX+1), TAU(NMAX),
     $                 U1(LDU1,NMAX), U2(LDU2, NMAX)
*     .. External Functions ..
      DOUBLE PRECISION MA02ID, MA02JD
      EXTERNAL         MA02ID, MA02JD
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DLASET, DSCAL, DSYMM, DSYR,
     $                 DSYR2K, DTRMM, MB04PU, MB04WP
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES )
         CALL MB04PU( N, 1, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK,
     $                INFO )
         INFO = 0
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            CALL DLACPY( 'Lower', N, N, A, LDA, U1, LDU1 )
            CALL DLACPY( 'Lower', N, N, QG, LDQG, U2, LDU2 )
            CALL MB04WP( N, 1, U1, LDU1, U2, LDU2, CS, TAU, DWORK,
     $                   LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               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, QG(2,1),
     $                         LDQG )
               WRITE ( NOUT, FMT = 99996 )
               DO 10  I = 1, N
                  WRITE (NOUT, FMT = 99993)
     $                  ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N )
10             CONTINUE
               DO 20  I = 1, N
                  WRITE (NOUT, FMT = 99993)
     $                  ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N )
20             CONTINUE
               WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., .FALSE., N,
     $                 U1, LDU1, U2, LDU2, RES, LDRES )
               WRITE ( NOUT, FMT = 99995 )
               DO 30  I = 1, N
                  WRITE (NOUT, FMT = 99993) ( A(I,J), J = 1,N )
30             CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 40  I = 1, N
                  WRITE (NOUT, FMT = 99993) ( QG(I,J), J = 1,N+1 )
40             CONTINUE
C
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U1, LDU1, A, LDA, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U1, LDU1, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                     U2, LDU2, A, LDA, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                     RES, LDRES, U2, LDU2, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DSYMM ( 'Right', 'Upper', N, N, ONE, QG(1,2), LDQG,
     $                      U1, LDU1, ZERO, RES, LDRES )
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U2, LDU2, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DLACPY( 'All', N, N, U2, LDU2, RES, LDRES )
               DO 50 I = 1, N
                   CALL DSCAL( N, QG(I,I), RES(1,I), 1 )
50             CONTINUE
               CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE,
     $                     RES, LDRES, U1, LDU1, ONE, RES(1,N+1),
     $                     LDRES )
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U2, LDU2, A, LDA, ZERO, RES, LDRES )
               CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U1, LDU1, ONE, RES(1,2*N+1), LDRES )
               CALL DSCAL( N, ONE/TWO, QG(1,2), LDQG+1 )
               CALL DLACPY( 'Full', N, N, U2, LDU2, RES, LDRES )
               CALL DTRMM(  'Right', 'Upper' , 'No Transpose',
     $                      'Not unit', N, N, ONE, QG(1,2), LDQG,
     $                       RES, LDRES )
               CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U2, LDU2, ONE, RES(1,2*N+1), LDRES )
               DO 60  I = 1, N
                  CALL DSYR( 'Lower', N, -QG(I,I), U1(1,I), 1,
     $                       RES(1,2*N+1), LDRES )
60             CONTINUE
               CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $                     U1, LDU1, A, LDA, ZERO, RES, LDRES )
               CALL DSYR2K( 'Upper', 'No Transpose', N, N, ONE, RES,
     $                      LDRES, U2, LDU2, ONE, RES(1,2*N+2), LDRES )
               CALL DLACPY( 'Full', N, N, U1, LDU1, RES, LDRES )
               CALL DTRMM(  'Right', 'Upper' , 'No Transpose',
     $                      'Not unit', N, N, ONE, QG(1,2), LDQG,
     $                       RES, LDRES )
               CALL DSYR2K( 'Upper', 'No Transpose', N, N, -ONE, RES,
     $                      LDRES, U1, LDU1, ONE, RES(1,2*N+2), LDRES )
               DO 70  I = 1, N
                  CALL DSYR( 'Upper', N, QG(I,I), U2(1,I), 1,
     $                       RES(1,2*N+2), LDRES )
70             CONTINUE
C
               WRITE ( NOUT, FMT = 99990 )  MA02ID( 'Hamiltonian',
     $                'Frobenius', N, RES(1,N+1), LDRES, RES(1,2*N+1),
     $                LDRES, DWORK )
            END IF
         END IF
      END IF
*
99999 FORMAT (' TMB04PU EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04PU = ',I2)
99997 FORMAT (' INFO on exit from MB04WP = ',I2)
99996 FORMAT (' The symplectic orthogonal factor U is ')
99995 FORMAT (/' The reduced matrix A is ')
99994 FORMAT (/' The reduced matrix QG is ')
99993 FORMAT (20(1X,F9.4))
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2)
99990 FORMAT (/' Residual: || H - U*R*U'' ||_F = ',G7.2)
      END
Program Data 
MB04PU EXAMPLE PROGRAM DATA
        5
    0.9501    0.7621    0.6154    0.4057    0.0579
    0.2311    0.4565    0.7919    0.9355    0.3529
    0.6068    0.0185    0.9218    0.9169    0.8132
    0.4860    0.8214    0.7382    0.4103    0.0099
    0.8913    0.4447    0.1763    0.8936    0.1389
    0.4055    0.3869    1.3801    0.7993    1.2019    0.8780
    0.2140    1.4936    0.7567    1.7598    1.1956    0.9029
    1.0224    1.2913    1.0503    1.6433    0.9346    1.6565
    1.1103    0.9515    0.8839    0.7590    0.6824    1.1022
    0.7016    1.1755    1.1010    1.1364    0.3793    0.7408
Program Results 
 TMB04PU EXAMPLE PROGRAM RESULTS

 The symplectic orthogonal factor U is 
    1.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.1119    0.7763   -0.2005   -0.0001    0.0000    0.1036   -0.2783   -0.2583    0.4356
    0.0000   -0.2937    0.2320    0.4014    0.5541    0.0000    0.4949    0.1187   -0.0294   -0.3632
    0.0000   -0.2352   -0.2243   -0.7056   -0.0500    0.0000    0.5374    0.3102   -0.0893    0.0318
    0.0000   -0.4314   -0.0354    0.2658   -0.6061    0.0000    0.3396   -0.3230    0.3931    0.0207
    0.0000    0.0000    0.0000    0.0000    0.0000    1.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.1036    0.2783    0.2583   -0.4356    0.0000   -0.1119    0.7763   -0.2005   -0.0001
    0.0000   -0.4949   -0.1187    0.0294    0.3632    0.0000   -0.2937    0.2320    0.4014    0.5541
    0.0000   -0.5374   -0.3102    0.0893   -0.0318    0.0000   -0.2352   -0.2243   -0.7056   -0.0500
    0.0000   -0.3396    0.3230   -0.3931   -0.0207    0.0000   -0.4314   -0.0354    0.2658   -0.6061

 Orthogonality of U: || U'*U - I ||_F = .16E-14

 The reduced matrix A is 
    0.9501   -1.8690    0.8413   -0.0344   -0.0817
   -2.0660    2.7118   -1.6646    0.7606   -0.0285
    0.0000   -2.4884    0.4115   -0.4021    0.3964
    0.0000    0.0000   -0.5222    0.1767   -0.3081
    0.0000    0.0000    0.0000    0.1915   -0.3426

 The reduced matrix QG is 
    0.4055    0.3869   -0.4295    0.9242   -0.7990   -0.0268
    0.0000   -3.0834   -2.5926    0.0804    0.1386   -0.1630
    0.0000    0.0000    1.3375    0.9618   -0.0263    0.1829
    0.0000    0.0000    0.0000   -0.3556    0.6662    0.2123
    0.0000    0.0000    0.0000    0.0000    0.1337   -0.8622

 Residual: || H - U*R*U' ||_F = .60E-14
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04PY.html000077500000000000000000000067141201767322700161270ustar00rootroot00000000000000 MB04PY - SLICOT Library Routine Documentation

MB04PY

Applying an elementary reflector (using in-line code for a low order) to a matrix, from either the left or the right

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply a real elementary reflector H to a real m-by-n matrix
  C, from either the left or the right. H is represented in the form
                                     ( 1 )
        H = I - tau * u *u',    u  = (   ),
                                     ( v )
  where tau is a real scalar and v is a real vector.

  If tau = 0, then H is taken to be the unit matrix.

  In-line code is used if H has order < 11.
Specification 
      SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK )
C     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            LDC, M, N
      DOUBLE PRECISION   TAU
C     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), DWORK( * ), V( * )
Arguments

Mode Parameters 

  SIDE    CHARACTER*1
          Indicates whether the elementary reflector should be
          applied from the left or from the right, as follows:
          = 'L':  Compute H * C;
          = 'R':  Compute C * H.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix C.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix C.  N >= 0.

  V       (input) DOUBLE PRECISION array, dimension
          (M-1), if SIDE = 'L', or
          (N-1), if SIDE = 'R'.
          The vector v in the representation of H.

  TAU     (input) DOUBLE PRECISION
          The scalar factor of the elementary reflector H.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix C.
          On exit, the leading M-by-N part of this array contains
          the matrix H * C, if SIDE = 'L', or C * H, if SIDE = 'R'.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N), if SIDE = 'L', or
                                            (M), if SIDE = 'R'.
          DWORK is not referenced if H has order less than 11.
Method 
  The routine applies the elementary reflector H, taking its special
  structure into account. The multiplications by the first component
  of u (which is 1) are avoided, to increase the efficiency.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04QB.html000077500000000000000000000166351201767322700161040ustar00rootroot00000000000000 MB04QB - SLICOT Library Routine Documentation

MB04QB

Applying a product of symplectic reflectors and Givens rotators to two general real matrices

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To overwrite general real m-by-n matrices C and D, or their
  transposes, with

            [ op(C) ]
      Q  *  [       ]   if TRANQ = 'N', or
            [ op(D) ]

       T    [ op(C) ]
      Q  *  [       ]   if TRANQ = 'T',
            [ op(D) ]

  where Q is defined as the product of symplectic reflectors and
  Givens rotators,

      Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
          diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
                            ....
          diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).

  Blocked version.
Specification 
      SUBROUTINE MB04QB( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K,
     $                   V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK,
     $                   LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  TRANC   CHARACTER*1
          Specifies the form of op( C ) as follows:
          = 'N':  op( C ) = C;
          = 'T':  op( C ) = C';
          = 'C':  op( C ) = C'.

  TRAND   CHARACTER*1
          Specifies the form of op( D ) as follows:
          = 'N':  op( D ) = D;
          = 'T':  op( D ) = D';
          = 'C':  op( D ) = D'.

  TRANQ   CHARACTER*1
          = 'N':  apply Q;
          = 'T':  apply Q'.

  STOREV  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder reflectors contained in V are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.

  STOREW  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder reflectors contained in W are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrices op(C) and op(D).
          M >= 0.

  N       (input) INTEGER
          The number of columns of the matrices op(C) and op(D).
          N >= 0.

  K       (input) INTEGER
          The number of elementary reflectors whose product defines
          the matrix Q.  M >= K >= 0.

  V       (input) DOUBLE PRECISION array, dimension
                  (LDV,K) if STOREV = 'C',
                  (LDV,M) if STOREV = 'R'
          On entry with STOREV = 'C', the leading M-by-K part of
          this array must contain in its columns the vectors which
          define the elementary reflectors F(i).
          On entry with STOREV = 'R', the leading K-by-M part of
          this array must contain in its rows the vectors which
          define the elementary reflectors F(i).

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= MAX(1,M),  if STOREV = 'C';
          LDV >= MAX(1,K),  if STOREV = 'R'.

  W       (input) DOUBLE PRECISION array, dimension
                  (LDW,K) if STOREW = 'C',
                  (LDW,M) if STOREW = 'R'
          On entry with STOREW = 'C', the leading M-by-K part of
          this array must contain in its columns the vectors which
          define the elementary reflectors H(i).
          On entry with STOREW = 'R', the leading K-by-M part of
          this array must contain in its rows the vectors which
          define the elementary reflectors H(i).

  LDW     INTEGER
          The leading dimension of the array W.
          LDW >= MAX(1,M),  if STOREW = 'C';
          LDW >= MAX(1,K),  if STOREW = 'R'.

  C       (input/output) DOUBLE PRECISION array, dimension
                  (LDC,N) if TRANC = 'N',
                  (LDC,M) if TRANC = 'T' or TRANC = 'C'
          On entry with TRANC = 'N', the leading M-by-N part of
          this array must contain the matrix C.
          On entry with TRANC = 'C' or TRANC = 'T', the leading
          N-by-M part of this array must contain the transpose of
          the matrix C.
          On exit with TRANC = 'N', the leading M-by-N part of
          this array contains the updated matrix C.
          On exit with TRANC = 'C' or TRANC = 'T', the leading
          N-by-M part of this array contains the transpose of the
          updated matrix C.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= MAX(1,M),  if TRANC = 'N';
          LDC >= MAX(1,N),  if TRANC = 'T' or TRANC = 'C'.

  D       (input/output) DOUBLE PRECISION array, dimension
                  (LDD,N) if TRAND = 'N',
                  (LDD,M) if TRAND = 'T' or TRAND = 'C'
          On entry with TRAND = 'N', the leading M-by-N part of
          this array must contain the matrix D.
          On entry with TRAND = 'C' or TRAND = 'T', the leading
          N-by-M part of this array must contain the transpose of
          the matrix D.
          On exit with TRAND = 'N', the leading M-by-N part of
          this array contains the updated matrix D.
          On exit with TRAND = 'C' or TRAND = 'T', the leading
          N-by-M part of this array contains the transpose of the
          updated matrix D.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= MAX(1,M),  if TRAND = 'N';
          LDD >= MAX(1,N),  if TRAND = 'T' or TRAND = 'C'.

  CS      (input) DOUBLE PRECISION array, dimension (2*K)
          On entry, the first 2*K elements of this array must
          contain the cosines and sines of the symplectic Givens
          rotators G(i).

  TAU     (input) DOUBLE PRECISION array, dimension (K)
          On entry, the first K elements of this array must
          contain the scalar factors of the elementary reflectors
          F(i).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -20,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Kressner, D.
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04QC.html000077500000000000000000000173151201767322700161010ustar00rootroot00000000000000 MB04QC - SLICOT Library Routine Documentation

MB04QC

Premultiplying a real matrix with an orthogonal symplectic block reflector

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply the orthogonal symplectic block reflector

           [  I+V*T*V'  V*R*S*V'  ]
      Q =  [                      ]
           [ -V*R*S*V'  I+V*T*V'  ]

  or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from
  the left.
  The k-by-k upper triangular blocks of the matrices

                              [ S1 ]       [ T11 T12 T13 ]
      R  = [ R1 R2 R3 ],  S = [ S2 ],  T = [ T21 T22 T23 ],
                              [ S3 ]       [ T31 T32 T33 ]

  with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular,
  are stored rowwise in the arrays RS and T, respectively.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  STRUCT  CHARACTER*1
          Specifies the structure of the first blocks of A and B:
          = 'Z':  the leading K-by-N submatrices of op(A) and op(B)
                  are (implicitly) assumed to be zero;
          = 'N';  no structure to mention.

  TRANA   CHARACTER*1
          Specifies the form of op( A ) as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.

  TRANB   CHARACTER*1
          Specifies the form of op( B ) as follows:
          = 'N':  op( B ) = B;
          = 'T':  op( B ) = B';
          = 'C':  op( B ) = B'.

  DIRECT  CHARACTER*1
          This is a dummy argument, which is reserved for future
          extensions of this subroutine. Not referenced.

  TRANQ   CHARACTER*1
          = 'N':  apply Q;
          = 'T':  apply Q'.

  STOREV  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder reflectors contained in V are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.

  STOREW  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder reflectors contained in W are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrices op(A) and op(B).
          M >= 0.

  N       (input) INTEGER
          The number of columns of the matrices op(A) and op(B).
          N >= 0.

  K       (input) INTEGER
          The order of the triangular matrices defining R, S and T.
          M >= K >= 0.

  V       (input) DOUBLE PRECISION array, dimension
                  (LDV,K) if STOREV = 'C',
                  (LDV,M) if STOREV = 'R'
          On entry with STOREV = 'C', the leading M-by-K part of
          this array must contain in its columns the vectors which
          define the elementary reflector used to form parts of Q.
          On entry with STOREV = 'R', the leading K-by-M part of
          this array must contain in its rows the vectors which
          define the elementary reflector used to form parts of Q.

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= MAX(1,M),  if STOREV = 'C';
          LDV >= MAX(1,K),  if STOREV = 'R'.

  W       (input) DOUBLE PRECISION array, dimension
                  (LDW,K) if STOREW = 'C',
                  (LDW,M) if STOREW = 'R'
          On entry with STOREW = 'C', the leading M-by-K part of
          this array must contain in its columns the vectors which
          define the elementary reflector used to form parts of Q.
          On entry with STOREW = 'R', the leading K-by-M part of
          this array must contain in its rows the vectors which
          define the elementary reflector used to form parts of Q.

  LDW     INTEGER
          The leading dimension of the array W.
          LDW >= MAX(1,M),  if STOREW = 'C';
          LDW >= MAX(1,K),  if STOREW = 'R'.

  RS      (input) DOUBLE PRECISION array, dimension (K,6*K)
          On entry, the leading K-by-6*K part of this array must
          contain the upper triangular matrices defining the factors
          R and S of the symplectic block reflector Q. The
          (strictly) lower portions of this array are not
          referenced.

  LDRS    INTEGER
          The leading dimension of the array RS.  LDRS >= MAX(1,K).

  T       (input) DOUBLE PRECISION array, dimension (K,9*K)
          On entry, the leading K-by-9*K part of this array must
          contain the upper triangular matrices defining the factor
          T of the symplectic block reflector Q. The (strictly)
          lower portions of this array are not referenced.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= MAX(1,K).

  A       (input/output) DOUBLE PRECISION array, dimension
                  (LDA,N) if TRANA = 'N',
                  (LDA,M) if TRANA = 'C' or TRANA = 'T'
          On entry with TRANA = 'N', the leading M-by-N part of this
          array must contain the matrix A.
          On entry with TRANA = 'T' or TRANA = 'C', the leading
          N-by-M part of this array must contain the matrix A.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,M),  if TRANA = 'N';
          LDA >= MAX(1,N),  if TRANA = 'C' or TRANA = 'T'.

  B       (input/output) DOUBLE PRECISION array, dimension
                  (LDB,N) if TRANB = 'N',
                  (LDB,M) if TRANB = 'C' or TRANB = 'T'
          On entry with TRANB = 'N', the leading M-by-N part of this
          array must contain the matrix B.
          On entry with TRANB = 'T' or TRANB = 'C', the leading
          N-by-M part of this array must contain the matrix B.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,M),  if TRANB = 'N';
          LDB >= MAX(1,N),  if TRANB = 'C' or TRANB = 'T'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK), where
          LDWORK >= 8*N*K,   if STRUCT = 'Z',
          LDWORK >= 9*N*K,   if STRUCT = 'N'.
References 
  [1] Kressner, D.
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Numerical Aspects 
  The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating
  point operations if STRUCT = 'Z' and additional ( 12*K + 2 )*K*N
  floating point operations if STRUCT = 'N'.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04QF.html000077500000000000000000000135671201767322700161110ustar00rootroot00000000000000 MB04QF - SLICOT Library Routine Documentation

MB04QF

Forming the triangular block factors of a symplectic block reflector

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To form the triangular block factors R, S and T of a symplectic
  block reflector SH, which is defined as a product of 2k
  concatenated Householder reflectors and k Givens rotators,

      SH = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
           diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
                             ....
           diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).

  The upper triangular blocks of the matrices

                              [ S1 ]       [ T11 T12 T13 ]
      R  = [ R1 R2 R3 ],  S = [ S2 ],  T = [ T21 T22 T23 ],
                              [ S3 ]       [ T31 T32 T33 ]

  with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular,
  are stored rowwise in the arrays RS and T, respectively.
Specification 
      SUBROUTINE MB04QF( DIRECT, STOREV, STOREW, N, K, V, LDV, W, LDW,
     $                   CS, TAU, RS, LDRS, T, LDT, DWORK )
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,*)
Arguments

Mode Parameters 

  DIRECT  CHARACTER*1
          This is a dummy argument, which is reserved for future
          extensions of this subroutine. Not referenced.

  STOREV  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder F(i) reflectors are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.

  STOREW  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder H(i) reflectors are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the Householder reflectors F(i) and H(i).
          N >= 0.

  K       (input) INTEGER
          The number of Givens rotators.  K >= 1.

  V       (input) DOUBLE PRECISION array, dimension
                  (LDV,K) if STOREV = 'C',
                  (LDV,N) if STOREV = 'R'
          On entry with STOREV = 'C', the leading N-by-K part of
          this array must contain in its i-th column the vector
          which defines the elementary reflector F(i).
          On entry with STOREV = 'R', the leading K-by-N part of
          this array must contain in its i-th row the vector
          which defines the elementary reflector F(i).

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= MAX(1,N),  if STOREV = 'C';
          LDV >= K,         if STOREV = 'R'.

  W       (input) DOUBLE PRECISION array, dimension
                  (LDW,K) if STOREW = 'C',
                  (LDW,N) if STOREW = 'R'
          On entry with STOREW = 'C', the leading N-by-K part of
          this array must contain in its i-th column the vector
          which defines the elementary reflector H(i).
          On entry with STOREV = 'R', the leading K-by-N part of
          this array must contain in its i-th row the vector
          which defines the elementary reflector H(i).

  LDW     INTEGER
          The leading dimension of the array W.
          LDW >= MAX(1,N),  if STOREW = 'C';
          LDW >= K,         if STOREW = 'R'.

  CS      (input) DOUBLE PRECISION array, dimension (2*K)
          On entry, the first 2*K elements of this array must
          contain the cosines and sines of the symplectic Givens
          rotators G(i).

  TAU     (input) DOUBLE PRECISION array, dimension (K)
          On entry, the first K elements of this array must
          contain the scalar factors of the elementary reflectors
          F(i).

  RS      (output) DOUBLE PRECISION array, dimension (K,6*K)
          On exit, the leading K-by-6*K part of this array contains
          the upper triangular matrices defining the factors R and
          S of the symplectic block reflector SH. The (strictly)
          lower portions of this array are not used.

  LDRS    INTEGER
          The leading dimension of the array RS.  LDRS >= K.

  T       (output) DOUBLE PRECISION array, dimension (K,9*K)
          On exit, the leading K-by-9*K part of this array contains
          the upper triangular matrices defining the factor T of the
          symplectic block reflector SH. The (strictly) lower
          portions of this array are not used.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= K.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (3*K)
References 
  [1] Kressner, D.
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Numerical Aspects 
  The algorithm requires ( 4*K - 2 )*K*N + 19/3*K*K*K + 1/2*K*K
  + 43/6*K - 4 floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04QU.html000077500000000000000000000163511201767322700161220ustar00rootroot00000000000000 MB04QU - SLICOT Library Routine Documentation

MB04QU

Applying a product of symplectic reflectors and Givens rotators to two general real matrices (unblocked version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To overwrite general real m-by-n matrices C and D, or their
  transposes, with

            [ op(C) ]
      Q  *  [       ]   if TRANQ = 'N', or
            [ op(D) ]

       T    [ op(C) ]
      Q  *  [       ]   if TRANQ = 'T',
            [ op(D) ]

  where Q is defined as the product of symplectic reflectors and
  Givens rotators,

      Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
          diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
                            ....
          diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).

  Unblocked version.
Specification 
      SUBROUTINE MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K,
     $                   V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK,
     $                   LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  TRANC   CHARACTER*1
          Specifies the form of op( C ) as follows:
          = 'N':  op( C ) = C;
          = 'T':  op( C ) = C';
          = 'C':  op( C ) = C'.

  STOREV  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder reflectors contained in V are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.

  STOREW  CHARACTER*1
          Specifies how the vectors which define the concatenated
          Householder reflectors contained in W are stored:
          = 'C':  columnwise;
          = 'R':  rowwise.

  TRAND   CHARACTER*1
          Specifies the form of op( D ) as follows:
          = 'N':  op( D ) = D;
          = 'T':  op( D ) = D';
          = 'C':  op( D ) = D'.

  TRANQ   CHARACTER*1
          = 'N':  apply Q;
          = 'T':  apply Q'.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrices op(C) and op(D).
          M >= 0.

  N       (input) INTEGER
          The number of columns of the matrices op(C) and op(D).
          N >= 0.

  K       (input) INTEGER
          The number of elementary reflectors whose product defines
          the matrix Q.  M >= K >= 0.

  V       (input) DOUBLE PRECISION array, dimension
                  (LDV,K) if STOREV = 'C',
                  (LDV,M) if STOREV = 'R'
          On entry with STOREV = 'C', the leading M-by-K part of
          this array must contain in its columns the vectors which
          define the elementary reflectors F(i).
          On entry with STOREV = 'R', the leading K-by-M part of
          this array must contain in its rows the vectors which
          define the elementary reflectors F(i).

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= MAX(1,M),  if STOREV = 'C';
          LDV >= MAX(1,K),  if STOREV = 'R'.

  W       (input) DOUBLE PRECISION array, dimension
                  (LDW,K) if STOREW = 'C',
                  (LDW,M) if STOREW = 'R'
          On entry with STOREW = 'C', the leading M-by-K part of
          this array must contain in its columns the vectors which
          define the elementary reflectors H(i).
          On entry with STOREW = 'R', the leading K-by-M part of
          this array must contain in its rows the vectors which
          define the elementary reflectors H(i).

  LDW     INTEGER
          The leading dimension of the array W.
          LDW >= MAX(1,M),  if STOREW = 'C';
          LDW >= MAX(1,K),  if STOREW = 'R'.

  C       (input/output) DOUBLE PRECISION array, dimension
                  (LDC,N) if TRANC = 'N',
                  (LDC,M) if TRANC = 'T' or TRANC = 'C'
          On entry with TRANC = 'N', the leading M-by-N part of
          this array must contain the matrix C.
          On entry with TRANC = 'C' or TRANC = 'T', the leading
          N-by-M part of this array must contain the transpose of
          the matrix C.
          On exit with TRANC = 'N', the leading M-by-N part of
          this array contains the updated matrix C.
          On exit with TRANC = 'C' or TRANC = 'T', the leading
          N-by-M part of this array contains the transpose of the
          updated matrix C.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= MAX(1,M),  if TRANC = 'N';
          LDC >= MAX(1,N),  if TRANC = 'T' or TRANC = 'C'.

  D       (input/output) DOUBLE PRECISION array, dimension
                  (LDD,N) if TRAND = 'N',
                  (LDD,M) if TRAND = 'T' or TRAND = 'C'
          On entry with TRAND = 'N', the leading M-by-N part of
          this array must contain the matrix D.
          On entry with TRAND = 'C' or TRAND = 'T', the leading
          N-by-M part of this array must contain the transpose of
          the matrix D.
          On exit with TRAND = 'N', the leading M-by-N part of
          this array contains the updated matrix D.
          On exit with TRAND = 'C' or TRAND = 'T', the leading
          N-by-M part of this array contains the transpose of the
          updated matrix D.

  LDD     INTEGER
          The leading dimension of the array D.
          LDD >= MAX(1,M),  if TRAND = 'N';
          LDD >= MAX(1,N),  if TRAND = 'T' or TRAND = 'C'.

  CS      (input) DOUBLE PRECISION array, dimension (2*K)
          On entry, the first 2*K elements of this array must
          contain the cosines and sines of the symplectic Givens
          rotators G(i).

  TAU     (input) DOUBLE PRECISION array, dimension (K)
          On entry, the first K elements of this array must
          contain the scalar factors of the elementary reflectors
          F(i).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -20,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04SU.html000077500000000000000000000127131201767322700161220ustar00rootroot00000000000000 MB04SU - SLICOT Library Routine Documentation

MB04SU

Symplectic QR decomposition of a real 2M-by-N matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a symplectic QR decomposition of a real 2M-by-N matrix
  [A; B],

            [ A ]             [ R11  R12 ]
            [   ] = Q * R = Q [          ],
            [ B ]             [ R21  R22 ]

  where Q is a symplectic orthogonal matrix, R11 is upper triangular
  and R21 is strictly upper triangular.
  If [A; B] is symplectic then, theoretically, R21 = 0 and
  R22 = inv(R11)^T. Unblocked version.
Specification 
      SUBROUTINE MB04SU( M, N, A, LDA, B, LDB, CS, TAU, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), CS(*), DWORK(*), TAU(*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of A and B. M >= 0.

  N       (input) INTEGER
          The number of columns of A and B. N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix A.
          On exit, the leading M-by-N part of this array contains
          the matrix [ R11  R12 ] and, in the zero parts of R,
          information about the elementary reflectors used to
          compute the symplectic QR decomposition.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,M).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix B.
          On exit, the leading M-by-N part of this array contains
          the matrix [ R21  R22 ] and, in the zero parts of B,
          information about the elementary reflectors used to
          compute the symplectic QR decomposition.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,M).

  CS      (output) DOUBLE PRECISION array, dimension (2 * min(M,N))
          On exit, the first 2*min(M,N) elements of this array
          contain the cosines and sines of the symplectic Givens
          rotations used to compute the symplectic QR decomposition.

  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
          On exit, the first min(M,N) elements of this array
          contain the scalar factors of some of the elementary
          reflectors.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -10,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix Q is represented as a product of symplectic reflectors
  and Givens rotators

  Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
      diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
                        ....
      diag( H(k),H(k) ) G(k) diag( F(k),F(k) ),

  where k = min(m,n).

  Each H(i) has the form

        H(i) = I - tau * w * w'

  where tau is a real scalar, and w is a real vector with
  w(1:i-1) = 0 and w(i) = 1; w(i+1:m) is stored on exit in
  B(i+1:m,i), and tau in B(i,i).

  Each F(i) has the form

        F(i) = I - nu * v * v'

  where nu is a real scalar, and v is a real vector with
  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
  A(i+1:m,i), and nu in TAU(i).

  Each G(i) is a Givens rotator acting on rows i of A and B,
  where the cosine is stored in CS(2*i-1) and the sine in
  CS(2*i).
References 
  [1] Bunse-Gerstner, A.
      Matrix factorizations for symplectic QR-like methods.
      Linear Algebra Appl., 83, pp. 49-77, 1986.

  [2] Byers, R.
      Hamiltonian and Symplectic Algorithms for the Algebraic
      Riccati Equation.
      Ph.D. Dissertation, Center for Applied Mathematics,
      Cornell University, Ithaca, NY, 1983.
Numerical Aspects 
  The algorithm requires
     8*M*N*N - 8/3*N*N*N +  2*M*N + 6*N*N + 8/3*N,  if M >= N,
     8*M*M*N - 8/3*M*M*M + 14*M*N - 6*M*M + 8/3*N,  if M <= N,
  floating point operations and is numerically backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04TB.html000077500000000000000000000575731201767322700161150ustar00rootroot00000000000000 MB04TB - SLICOT Library Routine Documentation

MB04TB

Symplectic URV decomposition of a real 2N-by-2N matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a symplectic URV (SURV) decomposition of a real
  2N-by-2N matrix H,

         [ op(A)   G   ]                 [ op(R11)   R12   ]
     H = [             ] = U R V'  = U * [                 ] * V' ,
         [  Q    op(B) ]                 [   0     op(R22) ]

  where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real
  N-by-N upper triangular matrix, op(R22) is a real N-by-N lower
  Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic
  matrices. Blocked version.
Specification 
      SUBROUTINE MB04TB( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG,
     $                   Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op( A ) as follows:
          = 'N':  op( A ) = A;
          = 'T':  op( A ) = A';
          = 'C':  op( A ) = A'.

  TRANB   CHARACTER*1
          Specifies the form of op( B ) as follows:
          = 'N':  op( B ) = B;
          = 'T':  op( B ) = B';
          = 'C':  op( B ) = B'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  ILO     (input) INTEGER
          It is assumed that op(A) is already upper triangular,
          op(B) is lower triangular and Q is zero in rows and
          columns 1:ILO-1. ILO is normally set by a previous call
          to MB04DD; otherwise it should be set to 1.
          1 <= ILO <= N, if N > 0; ILO=1, if N=0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the triangular matrix R11, and in the zero part
          information about the elementary reflectors used to
          compute the SURV decomposition.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix B.
          On exit, the leading N-by-N part of this array contains
          the Hessenberg matrix R22, and in the zero part
          information about the elementary reflectors used to
          compute the SURV decomposition.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix G.
          On exit, the leading N-by-N part of this array contains
          the matrix R12.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix Q.
          On exit, the leading N-by-N part of this array contains
          information about the elementary reflectors used to
          compute the SURV decomposition.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= MAX(1,N).

  CSL     (output) DOUBLE PRECISION array, dimension (2N)
          On exit, the first 2N elements of this array contain the
          cosines and sines of the symplectic Givens rotations
          applied from the left-hand side used to compute the SURV
          decomposition.

  CSR     (output) DOUBLE PRECISION array, dimension (2N-2)
          On exit, the first 2N-2 elements of this array contain the
          cosines and sines of the symplectic Givens rotations
          applied from the right-hand side used to compute the SURV
          decomposition.

  TAUL    (output) DOUBLE PRECISION array, dimension (N)
          On exit, the first N elements of this array contain the
          scalar factors of some of the elementary reflectors
          applied form the left-hand side.

  TAUR    (output) DOUBLE PRECISION array, dimension (N-1)
          On exit, the first N-1 elements of this array contain the
          scalar factors of some of the elementary reflectors
          applied form the right-hand side.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK, (16*N + 5)*NB, where NB is the optimal
          block size determined by the function UE01MD.
          On exit, if  INFO = -16,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrices U and V are represented as products of symplectic
  reflectors and Givens rotators

  U = diag( HU(1),HU(1) )  GU(1)  diag( FU(1),FU(1) )
      diag( HU(2),HU(2) )  GU(2)  diag( FU(2),FU(2) )
                           ....
      diag( HU(n),HU(n) )  GU(n)  diag( FU(n),FU(n) ),

  V = diag( HV(1),HV(1) )       GV(1)   diag( FV(1),FV(1) )
      diag( HV(2),HV(2) )       GV(2)   diag( FV(2),FV(2) )
                                ....
      diag( HV(n-1),HV(n-1) )  GV(n-1)  diag( FV(n-1),FV(n-1) ).

  Each HU(i) has the form

        HU(i) = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in
  Q(i+1:n,i), and tau in Q(i,i).

  Each FU(i) has the form

        FU(i) = I - nu * w * w'

  where nu is a real scalar, and w is a real vector with
  w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in
  A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The
  scalar nu is stored in TAUL(i).

  Each GU(i) is a Givens rotator acting on rows i and n+i,
  where the cosine is stored in CSL(2*i-1) and the sine in
  CSL(2*i).

  Each HV(i) has the form

        HV(i) = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in
  Q(i,i+2:n), and tau in Q(i,i+1).

  Each FV(i) has the form

        FV(i) = I - nu * w * w'

  where nu is a real scalar, and w is a real vector with
  w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in
  B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise.
  The scalar nu is stored in TAUR(i).

  Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1,
  where the cosine is stored in CSR(2*i-1) and the sine in
  CSR(2*i).
Numerical Aspects 
  The algorithm requires 80/3*N**3 + ( 64*NB + 77 )*N**2 +
  ( -16*NB + 48 )*NB*N + O(N) floating point operations, where
  NB is the used block size, and is numerically backward stable.
References 
  [1] Benner, P., Mehrmann, V., and Xu, H.
      A numerically stable, structure preserving method for
      computing the eigenvalues of real Hamiltonian or symplectic
      pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998.

  [2] Kressner, D.
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Further Comments 
  None
Example

Program Text 

*     MB04TB/MB04WR EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NBMAX, NMAX
      PARAMETER        ( NBMAX = 64, NMAX = 421 )
      INTEGER          LDA, LDB, LDG, LDQ, LDRES, LDU1, LDU2, LDV1,
     $                 LDV2, LDWORK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDG = NMAX, LDQ = NMAX,
     $                   LDRES = NMAX, LDU1 = NMAX, LDU2 = NMAX,
     $                   LDV1 = NMAX, LDV2 = NMAX,
     $                   LDWORK = NBMAX*( 16*NMAX + 1 ) )
*     .. Local Scalars ..
      CHARACTER*1      TRANA, TRANB, TRANV1
      INTEGER          I, INFO, J, N
      DOUBLE PRECISION TEMP
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), B(LDB, NMAX), CSL(2*NMAX),
     $                 CSR(2*NMAX), DWORK(LDWORK), G(LDG, NMAX),
     $                 Q(LDQ, NMAX), RES(LDRES,5*NMAX), TAUL(NMAX),
     $                 TAUR(NMAX), U1(LDU1, NMAX), U2(LDU2, NMAX),
     $                 V1(LDV1, NMAX), V2(LDV2, NMAX)
*     .. External Functions ..
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLANGE, DLAPY2, MA02JD
      EXTERNAL         DLANGE, DLAPY2, LSAME, MA02JD
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DLASET, MB04TB, MB04WR
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, TRANA, TRANB
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, A, LDA, RES, LDRES )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, B, LDB, RES(1,N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, G, LDG, RES(1,2*N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, Q, LDQ, RES(1,3*N+1), LDRES )
         CALL MB04TB( TRANA, TRANB, N, 1, A, LDA, B, LDB, G, LDG, Q,
     $                LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            CALL DLACPY( 'All', N, N, A, LDA, U1, LDU1 )
            CALL DLACPY( 'All', N, N, Q, LDQ, U2, LDU2 )
            CALL MB04WR( 'U', TRANA, N, 1, U1, LDU1, U2, LDU2, CSL,
     $                   TAUL, DWORK, LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               CALL DLACPY( 'All', N, N, Q, LDQ, V2, LDV2 )
               CALL DLACPY( 'All', N, N, B, LDB, V1, LDV1 )
               CALL MB04WR( 'V', TRANB, N, 1, V1, LDV1, V2, LDV2,
     $                      CSR, TAUR, DWORK, LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  IF ( LSAME( TRANA, 'N' ) ) THEN
                     DO 10  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N )
10                   CONTINUE
                     DO 20  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N )
20                   CONTINUE
                     WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE.,
     $                       .FALSE., N, U1, LDU1, U2, LDU2,
     $                       RES(1,4*N+1), LDRES )
                  ELSE
                     DO 30  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( U1(J,I), J = 1,N ), ( U2(I,J), J = 1,N )
30                   CONTINUE
                     DO 40  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -U2(I,J), J = 1,N ), ( U1(J,I), J = 1,N )
40                   CONTINUE
                     WRITE ( NOUT, FMT = 99991 ) MA02JD( .TRUE.,
     $                       .FALSE., N, U1, LDU1, U2, LDU2,
     $                       RES(1,4*N+1), LDRES )
                  END IF
                  WRITE ( NOUT, FMT = 99995 )
                  CALL DLASET( 'All', N, N, ZERO, ZERO, Q, LDQ )
                  IF ( LSAME( TRANA, 'N' ) ) THEN
                     CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO,
     $                            A(2,1), LDA )
                     DO 50  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( A(I,J), J = 1,N ), ( G(I,J), J = 1,N )
50                   CONTINUE
                  ELSE
                     CALL DLASET( 'Upper', N-1, N-1, ZERO, ZERO,
     $                            A(1,2), LDA )
                     DO 60  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( A(J,I), J = 1,N ), ( G(I,J), J = 1,N )
60                   CONTINUE
                  END IF
                  IF ( LSAME( TRANB, 'N' ) ) THEN
                     IF ( N.GT.1 ) THEN
                        CALL DLASET( 'Upper', N-2, N-2, ZERO, ZERO,
     $                               B(1,3), LDB )
                     END IF
                     DO 70  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( Q(I,J), J = 1,N ), ( B(I,J), J = 1,N )
70                   CONTINUE
                  ELSE
                     IF ( N.GT.1 ) THEN
C                        CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO,
C     $                               B(3,1), LDB )
                     END IF
                     DO 80  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( Q(I,J), J = 1,N ), ( B(J,I), J = 1,N )
80                   CONTINUE
                  END IF
C
                  IF ( LSAME( TRANB, 'N' ) ) THEN
                     TRANV1 = 'T'
                  ELSE
                     TRANV1 = 'N'
                  END IF
                  CALL DGEMM( TRANA, TRANV1, N, N, N, ONE, RES, LDRES,
     $                        V1, LDV1, ZERO, RES(1,4*N+1), LDRES )
                  CALL DGEMM( 'No Transpose', 'Transpose', N, N, N,
     $                        -ONE, RES(1,2*N+1), LDRES, V2, LDV2, ONE,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANA, TRANA, N, N, N, -ONE, U1, LDU1,
     $                        A, LDA, ONE, RES(1,4*N+1), LDRES )
                  TEMP = DLANGE( 'Frobenius', N, N, RES(1,4*N+1),
     $                           LDRES, DWORK )
                  CALL DGEMM( TRANA, 'Transpose', N, N, N, ONE, RES,
     $                        LDRES, V2, LDV2, ZERO, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE,
     $                        RES(1,2*N+1), LDRES, V1, LDV1, ONE,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANA, 'No Transpose', N, N, N, -ONE,
     $                        U1, LDU1, G, LDG, ONE, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( 'No Transpose', TRANB, N, N, N, -ONE,
     $                        U2, LDU2, B, LDB, ONE, RES(1,4*N+1),
     $                        LDRES )
                  TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N,
     $                                 RES(1,4*N+1), LDRES, DWORK ) )
                  CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE,
     $                        RES(1,3*N+1), LDRES, V1, LDV1, ZERO,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANB, 'Transpose', N, N, N, -ONE,
     $                        RES(1,N+1), LDRES, V2, LDV2, ONE,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( 'No Transpose', TRANA, N, N, N, ONE,
     $                        U2, LDU2, A, LDA, ONE, RES(1,4*N+1),
     $                        LDRES )
                  TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N,
     $                                 RES(1,4*N+1), LDRES, DWORK ) )
                  CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                        RES(1,3*N+1), LDRES, V2, LDV2, ZERO,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANB, TRANV1, N, N, N, ONE, RES(1,N+1),
     $                        LDRES, V1, LDV1, ONE, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N,
     $                        ONE, U2, LDU2, G, LDG, ONE, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( TRANA, TRANB, N, N, N, -ONE, U1, LDU1,
     $                        B, LDB, ONE, RES(1,4*N+1), LDRES )
                  TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N,
     $                                 RES(1,4*N+1), LDRES, DWORK ) )
                  WRITE ( NOUT, FMT = 99990 ) TEMP
C
                  WRITE ( NOUT, FMT = 99994 )
                  IF ( LSAME( TRANB, 'N' ) ) THEN
                     DO 90  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( V1(J,I), J = 1,N ), ( V2(J,I), J = 1,N )
90                   CONTINUE
                     DO 100  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -V2(J,I), J = 1,N ), ( V1(J,I), J = 1,N )
100                  CONTINUE
                     WRITE ( NOUT, FMT = 99989 ) MA02JD( .TRUE.,
     $                       .TRUE., N, V1, LDV1, V2, LDV2,
     $                       RES(1,4*N+1), LDRES )
                  ELSE
                     DO 110  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( V1(I,J), J = 1,N ), ( V2(J,I), J = 1,N )
110                  CONTINUE
                     DO 120  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -V2(J,I), J = 1,N ), ( V1(I,J), J = 1,N )
120                  CONTINUE
                     WRITE ( NOUT, FMT = 99989 ) MA02JD( .FALSE.,
     $                       .TRUE., N, V1, LDV1, V2, LDV2,
     $                       RES(1,4*N+1), LDRES )
                  END IF
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB04TB EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04TB = ',I2)
99997 FORMAT (' INFO on exit from MB04WR = ',I2)
99996 FORMAT (' The orthogonal symplectic factor U is ')
99995 FORMAT (/' The factor R is ')
99994 FORMAT (/' The orthogonal symplectic factor V is ')
99993 FORMAT (20(1X,F9.4))
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2)
99990 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2)
99989 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2)
      END
Program Data 
MB04TB EXAMPLE PROGRAM DATA
        5       N       N
    0.4643    0.3655    0.6853    0.5090    0.3718
    0.3688    0.6460    0.4227    0.6798    0.5135
    0.7458    0.5043    0.9419    0.9717    0.9990
    0.7140    0.4941    0.7802    0.5272    0.1220
    0.7418    0.0339    0.7441    0.0436    0.6564
   -0.4643   -0.3688   -0.7458   -0.7140   -0.7418
   -0.3655   -0.6460   -0.5043   -0.4941   -0.0339
   -0.6853   -0.4227   -0.9419   -0.7802   -0.7441
   -0.5090   -0.6798   -0.9717   -0.5272   -0.0436
   -0.3718   -0.5135   -0.9990   -0.1220   -0.6564
    0.7933    1.5765    1.0711    1.0794    0.8481
    1.5765    0.1167    1.5685    0.8756    0.5037
    1.0711    1.5685    0.9902    0.3858    0.2109
    1.0794    0.8756    0.3858    1.8834    1.4338
    0.8481    0.5037    0.2109    1.4338    0.1439
    1.0786    1.5264    1.1721    1.5343    0.4756
    1.5264    0.8644    0.6872    1.1379    0.6499
    1.1721    0.6872    1.5194    1.1197    1.0158
    1.5343    1.1379    1.1197    0.6612    0.2004
    0.4756    0.6499    1.0158    0.2004    1.2188
Program Results 
 MB04TB EXAMPLE PROGRAM RESULTS

 The orthogonal symplectic factor U is 
   -0.1513    0.0756   -0.0027    0.1694   -0.2999    0.3515   -0.4843    0.6545   -0.1995   -0.1627
   -0.1202    0.2320    0.1662   -0.2835   -0.0508    0.4975    0.3319   -0.2686   -0.4186   -0.4649
   -0.2431    0.2724    0.3439    0.3954    0.0236    0.3820   -0.2863   -0.4324    0.3706    0.1984
   -0.2327   -0.1509   -0.3710   -0.1240   -0.0393    0.5000    0.3659    0.1429    0.0493    0.6015
   -0.2418   -0.2928   -0.0836   -0.5549    0.4824    0.1550   -0.4441   -0.0396    0.2376   -0.1702
   -0.3515    0.4843   -0.6545    0.1995    0.1627   -0.1513    0.0756   -0.0027    0.1694   -0.2999
   -0.4975   -0.3319    0.2686    0.4186    0.4649   -0.1202    0.2320    0.1662   -0.2835   -0.0508
   -0.3820    0.2863    0.4324   -0.3706   -0.1984   -0.2431    0.2724    0.3439    0.3954    0.0236
   -0.5000   -0.3659   -0.1429   -0.0493   -0.6015   -0.2327   -0.1509   -0.3710   -0.1240   -0.0393
   -0.1550    0.4441    0.0396   -0.2376    0.1702   -0.2418   -0.2928   -0.0836   -0.5549    0.4824

 Orthogonality of U: || U^T U - I ||_F = .24E-14

 The factor R is 
   -3.0684    4.6724   -0.2613   -0.1996    0.0208   -0.1071   -0.1355   -0.1400    0.4652   -0.5032
    0.0000   -1.8037   -0.0301   -0.1137    0.1771    0.0277    0.3929    0.5424    0.5220   -0.4843
    0.0000    0.0000   -0.7617   -0.1874    0.2557    0.1244   -0.0012    0.4091    0.5123   -0.3522
    0.0000    0.0000    0.0000   -0.6931   -0.4293   -0.3718    0.1542   -0.3635    0.0336   -0.9832
    0.0000    0.0000    0.0000    0.0000    0.6469    0.2074    0.0266    0.2028    0.1995    0.2517
    0.0000    0.0000    0.0000    0.0000    0.0000    2.6325   -4.7377    0.0000    0.0000    0.0000
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.2702    0.9347   -1.1210    0.0000    0.0000
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.3219   -0.5394    0.1748   -0.4788    0.0000
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.1431   -0.1021    0.4974   -0.3565   -0.6402
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.1622   -0.2368    0.6126   -0.7369    0.6915

 Residual: || H*V - U*R ||_F = .87E-14

 The orthogonal symplectic factor V is 
    1.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.4740    0.6013   -0.2299   -0.4282    0.0000    0.0061   -0.1732    0.3134    0.2220
    0.0000   -0.5553   -0.2623    0.6622   -0.3042    0.0000   -0.0382    0.2453   -0.1662    0.0509
    0.0000   -0.5563    0.0322   -0.1431    0.4461    0.0000   -0.0665   -0.4132   -0.3100   -0.4457
    0.0000   -0.3872   -0.4022   -0.4194    0.3541    0.0000   -0.0406    0.3820    0.3006    0.3861
    0.0000    0.0000    0.0000    0.0000    0.0000    1.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.0061    0.1732   -0.3134   -0.2220    0.0000   -0.4740    0.6013   -0.2299   -0.4282
    0.0000    0.0382   -0.2453    0.1662   -0.0509    0.0000   -0.5553   -0.2623    0.6622   -0.3042
    0.0000    0.0665    0.4132    0.3100    0.4457    0.0000   -0.5563    0.0322   -0.1431    0.4461
    0.0000    0.0406   -0.3820   -0.3006   -0.3861    0.0000   -0.3872   -0.4022   -0.4194    0.3541

 Orthogonality of V: || V^T V - I ||_F = .14E-14

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04TS.html000077500000000000000000000565001201767322700161230ustar00rootroot00000000000000 MB04TS - SLICOT Library Routine Documentation

MB04TS

Symplectic URV decomposition of a real 2N-by-2N matrix (unblocked version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a symplectic URV (SURV) decomposition of a real
  2N-by-2N matrix H:

          [ op(A)   G   ]        T       [ op(R11)   R12   ]    T
      H = [             ] = U R V  = U * [                 ] * V ,
          [  Q    op(B) ]                [   0     op(R22) ]

  where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real
  N-by-N upper triangular matrix, op(R22) is a real N-by-N lower
  Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic
  matrices. Unblocked version.
Specification 
      SUBROUTINE MB04TS( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG,
     $                   Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op( A ) as follows:
          = 'N': op( A ) = A;
          = 'T': op( A ) = A';
          = 'C': op( A ) = A'.

  TRANB   CHARACTER*1
          Specifies the form of op( B ) as follows:
          = 'N': op( B ) = B;
          = 'T': op( B ) = B';
          = 'C': op( B ) = B'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A. N >= 0.

  ILO     (input) INTEGER
          It is assumed that op(A) is already upper triangular,
          op(B) is lower triangular and Q is zero in rows and
          columns 1:ILO-1. ILO is normally set by a previous call
          to MB04DD; otherwise it should be set to 1.
          1 <= ILO <= N, if N > 0; ILO=1, if N=0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the triangular matrix R11, and in the zero part
          information about the elementary reflectors used to
          compute the SURV decomposition.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix B.
          On exit, the leading N-by-N part of this array contains
          the Hessenberg matrix R22, and in the zero part
          information about the elementary reflectors used to
          compute the SURV decomposition.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix G.
          On exit, the leading N-by-N part of this array contains
          the matrix R12.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix Q.
          On exit, the leading N-by-N part of this array contains
          information about the elementary reflectors used to
          compute the SURV decomposition.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDG >= MAX(1,N).

  CSL     (output) DOUBLE PRECISION array, dimension (2N)
          On exit, the first 2N elements of this array contain the
          cosines and sines of the symplectic Givens rotations
          applied from the left-hand side used to compute the SURV
          decomposition.

  CSR     (output) DOUBLE PRECISION array, dimension (2N-2)
          On exit, the first 2N-2 elements of this array contain the
          cosines and sines of the symplectic Givens rotations
          applied from the right-hand side used to compute the SURV
          decomposition.

  TAUL    (output) DOUBLE PRECISION array, dimension (N)
          On exit, the first N elements of this array contain the
          scalar factors of some of the elementary reflectors
          applied from the left-hand side.

  TAUR    (output) DOUBLE PRECISION array, dimension (N-1)
          On exit, the first N-1 elements of this array contain the
          scalar factors of some of the elementary reflectors
          applied from the right-hand side.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -16,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrices U and V are represented as products of symplectic
  reflectors and Givens rotators

  U = diag( HU(1),HU(1) )  GU(1)  diag( FU(1),FU(1) )
      diag( HU(2),HU(2) )  GU(2)  diag( FU(2),FU(2) )
                           ....
      diag( HU(n),HU(n) )  GU(n)  diag( FU(n),FU(n) ),

  V = diag( HV(1),HV(1) )       GV(1)   diag( FV(1),FV(1) )
      diag( HV(2),HV(2) )       GV(2)   diag( FV(2),FV(2) )
                                ....
      diag( HV(n-1),HV(n-1) )  GV(n-1)  diag( FV(n-1),FV(n-1) ).

  Each HU(i) has the form

        HU(i) = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in
  Q(i+1:n,i), and tau in Q(i,i).

  Each FU(i) has the form

        FU(i) = I - nu * w * w'

  where nu is a real scalar, and w is a real vector with
  w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in
  A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The
  scalar nu is stored in TAUL(i).

  Each GU(i) is a Givens rotator acting on rows i and n+i,
  where the cosine is stored in CSL(2*i-1) and the sine in
  CSL(2*i).

  Each HV(i) has the form

        HV(i) = I - tau * v * v'

  where tau is a real scalar, and v is a real vector with
  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in
  Q(i,i+2:n), and tau in Q(i,i+1).

  Each FV(i) has the form

        FV(i) = I - nu * w * w'

  where nu is a real scalar, and w is a real vector with
  w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in
  B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise.
  The scalar nu is stored in TAUR(i).

  Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1,
  where the cosine is stored in CSR(2*i-1) and the sine in
  CSR(2*i).
Numerical Aspects 
  The algorithm requires 80/3 N**3 + 20 N**2 + O(N) floating point
  operations and is numerically backward stable.
References 
  [1] Benner, P., Mehrmann, V., and Xu, H.
      A numerically stable, structure preserving method for
      computing the eigenvalues of real Hamiltonian or symplectic
      pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998.
Further Comments 
  None
Example

Program Text 

*     MB04TS/MB04WR EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 200 )
      INTEGER          LDA, LDB, LDG, LDQ, LDRES, LDU1, LDU2, LDV1,
     $                 LDV2, LDWORK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDG = NMAX, LDQ = NMAX,
     $                   LDRES = NMAX, LDU1 = NMAX, LDU2 = NMAX,
     $                   LDV1 = NMAX, LDV2 = NMAX, LDWORK = NMAX )
*     .. Local Scalars ..
      CHARACTER*1      TRANA, TRANB, TRANV1
      INTEGER          I, INFO, J, N
      DOUBLE PRECISION TEMP
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), B(LDB, NMAX), CSL(2*NMAX),
     $                 CSR(2*NMAX), DWORK(LDWORK), G(LDG,NMAX),
     $                 Q(LDQ,NMAX), RES(LDRES,5*NMAX), TAUL(NMAX),
     $                 TAUR(NMAX), U1(LDU1,NMAX), U2(LDU2, NMAX),
     $                 V1(LDV1, NMAX), V2(LDV2,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLANGE, DLAPY2, MA02JD
      EXTERNAL         DLANGE, DLAPY2, LSAME, MA02JD
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DLASET, MB04TS, MB04WR
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, TRANA, TRANB
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, A, LDA, RES, LDRES )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, B, LDB, RES(1,N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, G, LDG, RES(1,2*N+1), LDRES )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'All', N, N, Q, LDQ, RES(1,3*N+1), LDRES )
         CALL MB04TS( TRANA, TRANB, N, 1, A, LDA, B, LDB, G, LDG, Q,
     $                LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            CALL DLACPY( 'All', N, N, A, LDA, U1, LDU1 )
            CALL DLACPY( 'All', N, N, Q, LDQ, U2, LDU2 )
            CALL MB04WR( 'U', TRANA, N, 1, U1, LDU1, U2, LDU2, CSL,
     $                   TAUL, DWORK, LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               CALL DLACPY( 'All', N, N, Q, LDQ, V2, LDV2 )
               CALL DLACPY( 'All', N, N, B, LDB, V1, LDV1 )
               CALL MB04WR( 'V', TRANB, N, 1, V1, LDV1, V2, LDV2,
     $                      CSR, TAUR, DWORK, LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  IF ( LSAME( TRANA, 'N' ) ) THEN
                     DO 10  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N )
10                   CONTINUE
                     DO 20  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N )
20                   CONTINUE
                     WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE.,
     $                       .FALSE., N, U1, LDU1, U2, LDU2,
     $                       RES(1,4*N+1), LDRES )
                  ELSE
                     DO 30  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( U1(J,I), J = 1,N ), ( U2(I,J), J = 1,N )
30                   CONTINUE
                     DO 40  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -U2(I,J), J = 1,N ), ( U1(J,I), J = 1,N )
40                   CONTINUE
                     WRITE ( NOUT, FMT = 99991 ) MA02JD( .TRUE.,
     $                       .FALSE., N, U1, LDU1, U2, LDU2,
     $                       RES(1,4*N+1), LDRES )
                  END IF
                  WRITE ( NOUT, FMT = 99995 )
                  CALL DLASET( 'All', N, N, ZERO, ZERO, Q, LDQ )
                  IF ( LSAME( TRANA, 'N' ) ) THEN
                     CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO,
     $                            A(2,1), LDA )
                     DO 50  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( A(I,J), J = 1,N ), ( G(I,J), J = 1,N )
50                   CONTINUE
                  ELSE
                     CALL DLASET( 'Upper', N-1, N-1, ZERO, ZERO,
     $                            A(1,2), LDA )
                     DO 60  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( A(J,I), J = 1,N ), ( G(I,J), J = 1,N )
60                   CONTINUE
                  END IF
                  IF ( LSAME( TRANB, 'N' ) ) THEN
                     IF ( N.GT.1 ) THEN
                        CALL DLASET( 'Upper', N-2, N-2, ZERO, ZERO,
     $                               B(1,3), LDB )
                     END IF
                     DO 70  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( Q(I,J), J = 1,N ), ( B(I,J), J = 1,N )
70                   CONTINUE
                  ELSE
                     IF ( N.GT.1 ) THEN
                        CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO,
     $                               B(3,1), LDB )
                     END IF
                     DO 80  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( Q(I,J), J = 1,N ), ( B(J,I), J = 1,N )
80                   CONTINUE
                  END IF
C
                  IF ( LSAME( TRANB, 'N' ) ) THEN
                     TRANV1 = 'T'
                  ELSE
                     TRANV1 = 'N'
                  END IF
                  CALL DGEMM( TRANA, TRANV1, N, N, N, ONE, RES, LDRES,
     $                        V1, LDV1, ZERO, RES(1,4*N+1), LDRES )
                  CALL DGEMM( 'No Transpose', 'Transpose', N, N, N,
     $                        -ONE, RES(1,2*N+1), LDRES, V2, LDV2, ONE,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANA, TRANA, N, N, N, -ONE, U1, LDU1,
     $                        A, LDA, ONE, RES(1,4*N+1), LDRES )
                  TEMP = DLANGE( 'Frobenius', N, N, RES(1,4*N+1),
     $                           LDRES, DWORK )
                  CALL DGEMM( TRANA, 'Transpose', N, N, N, ONE, RES,
     $                        LDRES, V2, LDV2, ZERO, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE,
     $                        RES(1,2*N+1), LDRES, V1, LDV1, ONE,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANA, 'No Transpose', N, N, N, -ONE,
     $                        U1, LDU1, G, LDG, ONE, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( 'No Transpose', TRANB, N, N, N, -ONE,
     $                        U2, LDU2, B, LDB, ONE, RES(1,4*N+1),
     $                        LDRES )
                  TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N,
     $                                 RES(1,4*N+1), LDRES, DWORK ) )
                  CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE,
     $                        RES(1,3*N+1), LDRES, V1, LDV1, ZERO,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANB, 'Transpose', N, N, N, -ONE,
     $                        RES(1,N+1), LDRES, V2, LDV2, ONE,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( 'No Transpose', TRANA, N, N, N, ONE,
     $                        U2, LDU2, A, LDA, ONE, RES(1,4*N+1),
     $                        LDRES )
                  TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N,
     $                                 RES(1,4*N+1), LDRES, DWORK ) )
                  CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE,
     $                        RES(1,3*N+1), LDRES, V2, LDV2, ZERO,
     $                        RES(1,4*N+1), LDRES )
                  CALL DGEMM( TRANB, TRANV1, N, N, N, ONE, RES(1,N+1),
     $                        LDRES, V1, LDV1, ONE, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N,
     $                        ONE, U2, LDU2, G, LDG, ONE, RES(1,4*N+1),
     $                        LDRES )
                  CALL DGEMM( TRANA, TRANB, N, N, N, -ONE, U1, LDU1,
     $                        B, LDB, ONE, RES(1,4*N+1), LDRES )
                  TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N,
     $                                 RES(1,4*N+1), LDRES, DWORK ) )
                  WRITE ( NOUT, FMT = 99990 ) TEMP
C
                  WRITE ( NOUT, FMT = 99994 )
                  IF ( LSAME( TRANB, 'N' ) ) THEN
                     DO 90  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( V1(J,I), J = 1,N ), ( V2(J,I), J = 1,N )
90                   CONTINUE
                     DO 100  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -V2(J,I), J = 1,N ), ( V1(J,I), J = 1,N )
100                  CONTINUE
                     WRITE ( NOUT, FMT = 99989 ) MA02JD( .TRUE.,
     $                       .TRUE., N, V1, LDV1, V2, LDV2,
     $                       RES(1,4*N+1), LDRES )
                  ELSE
                     DO 110  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( V1(I,J), J = 1,N ), ( V2(J,I), J = 1,N )
110                  CONTINUE
                     DO 120  I = 1, N
                        WRITE (NOUT, FMT = 99993)
     $                     ( -V2(J,I), J = 1,N ), ( V1(I,J), J = 1,N )
120                  CONTINUE
                     WRITE ( NOUT, FMT = 99989 ) MA02JD( .FALSE.,
     $                       .TRUE., N, V1, LDV1, V2, LDV2,
     $                       RES(1,4*N+1), LDRES )
                  END IF
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB04TS EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04TS = ',I2)
99997 FORMAT (' INFO on exit from MB04WR = ',I2)
99996 FORMAT (' The orthogonal symplectic factor U is ')
99995 FORMAT (/' The factor R is ')
99994 FORMAT (/' The orthogonal symplectic factor V is ')
99993 FORMAT (20(1X,F9.4))
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2)
99990 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2)
99989 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2)
      END
Program Data 
MB04TB EXAMPLE PROGRAM DATA
        5       N       N
    0.4643    0.3655    0.6853    0.5090    0.3718
    0.3688    0.6460    0.4227    0.6798    0.5135
    0.7458    0.5043    0.9419    0.9717    0.9990
    0.7140    0.4941    0.7802    0.5272    0.1220
    0.7418    0.0339    0.7441    0.0436    0.6564
   -0.4643   -0.3688   -0.7458   -0.7140   -0.7418
   -0.3655   -0.6460   -0.5043   -0.4941   -0.0339
   -0.6853   -0.4227   -0.9419   -0.7802   -0.7441
   -0.5090   -0.6798   -0.9717   -0.5272   -0.0436
   -0.3718   -0.5135   -0.9990   -0.1220   -0.6564
    0.7933    1.5765    1.0711    1.0794    0.8481
    1.5765    0.1167    1.5685    0.8756    0.5037
    1.0711    1.5685    0.9902    0.3858    0.2109
    1.0794    0.8756    0.3858    1.8834    1.4338
    0.8481    0.5037    0.2109    1.4338    0.1439
    1.0786    1.5264    1.1721    1.5343    0.4756
    1.5264    0.8644    0.6872    1.1379    0.6499
    1.1721    0.6872    1.5194    1.1197    1.0158
    1.5343    1.1379    1.1197    0.6612    0.2004
    0.4756    0.6499    1.0158    0.2004    1.2188
Program Results 
 MB04TS EXAMPLE PROGRAM RESULTS

 The orthogonal symplectic factor U is 
   -0.1513    0.0756   -0.0027    0.1694   -0.2999    0.3515   -0.4843    0.6545   -0.1995   -0.1627
   -0.1202    0.2320    0.1662   -0.2835   -0.0508    0.4975    0.3319   -0.2686   -0.4186   -0.4649
   -0.2431    0.2724    0.3439    0.3954    0.0236    0.3820   -0.2863   -0.4324    0.3706    0.1984
   -0.2327   -0.1509   -0.3710   -0.1240   -0.0393    0.5000    0.3659    0.1429    0.0493    0.6015
   -0.2418   -0.2928   -0.0836   -0.5549    0.4824    0.1550   -0.4441   -0.0396    0.2376   -0.1702
   -0.3515    0.4843   -0.6545    0.1995    0.1627   -0.1513    0.0756   -0.0027    0.1694   -0.2999
   -0.4975   -0.3319    0.2686    0.4186    0.4649   -0.1202    0.2320    0.1662   -0.2835   -0.0508
   -0.3820    0.2863    0.4324   -0.3706   -0.1984   -0.2431    0.2724    0.3439    0.3954    0.0236
   -0.5000   -0.3659   -0.1429   -0.0493   -0.6015   -0.2327   -0.1509   -0.3710   -0.1240   -0.0393
   -0.1550    0.4441    0.0396   -0.2376    0.1702   -0.2418   -0.2928   -0.0836   -0.5549    0.4824

 Orthogonality of U: || U^T U - I ||_F = .24E-14

 The factor R is 
   -3.0684    4.6724   -0.2613   -0.1996    0.0208   -0.1071   -0.1355   -0.1400    0.4652   -0.5032
    0.0000   -1.8037   -0.0301   -0.1137    0.1771    0.0277    0.3929    0.5424    0.5220   -0.4843
    0.0000    0.0000   -0.7617   -0.1874    0.2557    0.1244   -0.0012    0.4091    0.5123   -0.3522
    0.0000    0.0000    0.0000   -0.6931   -0.4293   -0.3718    0.1542   -0.3635    0.0336   -0.9832
    0.0000    0.0000    0.0000    0.0000    0.6469    0.2074    0.0266    0.2028    0.1995    0.2517
    0.0000    0.0000    0.0000    0.0000    0.0000    2.6325   -4.7377    0.0000    0.0000    0.0000
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.2702    0.9347   -1.1210    0.0000    0.0000
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.3219   -0.5394    0.1748   -0.4788    0.0000
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.1431   -0.1021    0.4974   -0.3565   -0.6402
    0.0000    0.0000    0.0000    0.0000    0.0000   -0.1622   -0.2368    0.6126   -0.7369    0.6915

 Residual: || H*V - U*R ||_F = .87E-14

 The orthogonal symplectic factor V is 
    1.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.4740    0.6013   -0.2299   -0.4282    0.0000    0.0061   -0.1732    0.3134    0.2220
    0.0000   -0.5553   -0.2623    0.6622   -0.3042    0.0000   -0.0382    0.2453   -0.1662    0.0509
    0.0000   -0.5563    0.0322   -0.1431    0.4461    0.0000   -0.0665   -0.4132   -0.3100   -0.4457
    0.0000   -0.3872   -0.4022   -0.4194    0.3541    0.0000   -0.0406    0.3820    0.3006    0.3861
    0.0000    0.0000    0.0000    0.0000    0.0000    1.0000    0.0000    0.0000    0.0000    0.0000
    0.0000   -0.0061    0.1732   -0.3134   -0.2220    0.0000   -0.4740    0.6013   -0.2299   -0.4282
    0.0000    0.0382   -0.2453    0.1662   -0.0509    0.0000   -0.5553   -0.2623    0.6622   -0.3042
    0.0000    0.0665    0.4132    0.3100    0.4457    0.0000   -0.5563    0.0322   -0.1431    0.4461
    0.0000    0.0406   -0.3820   -0.3006   -0.3861    0.0000   -0.3872   -0.4022   -0.4194    0.3541

 Orthogonality of V: || V^T V - I ||_F = .14E-14
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04TU.html000077500000000000000000000033171201767322700161230ustar00rootroot00000000000000 MB04TU - SLICOT Library Routine Documentation

MB04TU

Applying a row-permuted Givens transformation to two row vectors

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the Givens transformation, defined by C (cos) and S
  (sin), and interchange the vectors involved, i.e.

     |X(i)|    | 0   1 |   | C   S |   |X(i)|
     |    | := |       | x |       | x |    |, i = 1,...N.
     |Y(i)|    | 1   0 |   |-S   C |   |Y(i)|

  REMARK. This routine is a modification of DROT from BLAS.
          This routine is called only by the SLICOT routines MB04TX
          and MB04VX.
Numerical Aspects 
  The algorithm is backward stable.
Specification 
      SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S )
C     .. Scalar Arguments ..
      INTEGER           INCX, INCY, N
      DOUBLE PRECISION  C, S
C     .. Array Arguments ..
      DOUBLE PRECISION  X(*), Y(*)
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04UD.html000077500000000000000000000263521201767322700161070ustar00rootroot00000000000000 MB04UD - SLICOT Library Routine Documentation

MB04UD

Column echelon form by unitary transformations for a rectangular matrix (added functionality)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal transformations Q and Z such that the
  transformed pencil Q'(sE-A)Z has the E matrix in column echelon
  form, where E and A are M-by-N matrices.
Specification 
      SUBROUTINE MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ,
     $                   Z, LDZ, RANKE, ISTAIR, TOL, DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOBQ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Q the unitary row permutations, as follows:
          = 'N':  Do not form Q;
          = 'I':  Q is initialized to the unit matrix and the
                  unitary row permutation matrix Q is returned;
          = 'U':  The given matrix Q is updated by the unitary
                  row permutations used in the reduction.

  JOBZ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Z the unitary column transformations, as follows:
          = 'N':  Do not form Z;
          = 'I':  Z is initialized to the unit matrix and the
                  unitary transformation matrix Z is returned;
          = 'U':  The given matrix Z is updated by the unitary
                  transformations used in the reduction.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows in the matrices A, E and the order of
          the matrix Q.  M >= 0.

  N       (input) INTEGER
          The number of columns in the matrices A, E and the order
          of the matrix Z.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the A matrix of the pencil sE-A.
          On exit, the leading M-by-N part of this array contains
          the unitary transformed matrix Q' * A * Z.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading M-by-N part of this array must
          contain the E matrix of the pencil sE-A, to be reduced to
          column echelon form.
          On exit, the leading M-by-N part of this array contains
          the unitary transformed matrix Q' * E * Z, which is in
          column echelon form.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,M).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
          On entry, if JOBQ = 'U', then the leading M-by-M part of
          this array must contain a given matrix Q (e.g. from a
          previous call to another SLICOT routine), and on exit, the
          leading M-by-M part of this array contains the product of
          the input matrix Q and the row permutation matrix used to
          transform the rows of matrix E.
          On exit, if JOBQ = 'I', then the leading M-by-M part of
          this array contains the matrix of accumulated unitary
          row transformations performed.
          If JOBQ = 'N', the array Q is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDQ = 1 and
          declare this array to be Q(1,1) in the calling program).

  LDQ     INTEGER
          The leading dimension of array Q. If JOBQ = 'U' or
          JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
          On entry, if JOBZ = 'U', then the leading N-by-N part of
          this array must contain a given matrix Z (e.g. from a
          previous call to another SLICOT routine), and on exit, the
          leading N-by-N part of this array contains the product of
          the input matrix Z and the column transformation matrix
          used to transform the columns of matrix E.
          On exit, if JOBZ = 'I', then the leading N-by-N part of
          this array contains the matrix of accumulated unitary
          column transformations performed.
          If JOBZ = 'N', the array Z is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDZ = 1 and
          declare this array to be Z(1,1) in the calling program).

  LDZ     INTEGER
          The leading dimension of array Z. If JOBZ = 'U' or
          JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.

  RANKE   (output) INTEGER
          The computed rank of the unitary transformed matrix E.

  ISTAIR  (output) INTEGER array, dimension (M)
          This array contains information on the column echelon form
          of the unitary transformed matrix E. Specifically,
          ISTAIR(i) = +j if the first non-zero element E(i,j)
          is a corner point and -j otherwise, for i = 1,2,...,M.
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance below which matrix elements are considered
          to be zero. If the user sets TOL to be less than (or
          equal to) zero then the tolerance is taken as
          EPS * MAX(ABS(E(I,J))), where EPS is the machine
          precision (see LAPACK Library routine DLAMCH),
          I = 1,2,...,M and J = 1,2,...,N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension MAX(M,N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given an M-by-N matrix pencil sE-A with E not necessarily regular,
  the routine computes a unitary transformed pencil Q'(sE-A)Z such
  that the matrix Q' * E * Z is in column echelon form (trapezoidal
  form).  Further details can be found in [1].

  [An M-by-N matrix E with rank(E) = r is said to be in column
  echelon form if the following conditions are satisfied:
  (a) the first (N - r) columns contain only zero elements; and
  (b) if E(i(k),k) is the last nonzero element in column k for
      k = N-r+1,...,N, i.e. E(i(k),k) <> 0 and E(j,k) = 0 for
      j > i(k), then 1 <= i(N-r+1) < i(N-r+2) < ... < i(N) <= M.]
References 
  [1] Beelen, Th. and Van Dooren, P.
      An improved algorithm for the computation of Kronecker's
      canonical form of a singular pencil.
      Linear Algebra and Applications, 105, pp. 9-65, 1988.
Numerical Aspects 
  It is shown in [1] that the algorithm is numerically backward
  stable. The operations count is proportional to (MAX(M,N))**3.
Further Comments 
  None
Example

Program Text 

*     MB04UD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDE, LDQ, LDZ
      PARAMETER        ( LDA = MMAX, LDE = MMAX, LDQ = MMAX,
     $                   LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX,MMAX ) )
*     PARAMETER        ( LDWORK = NMAX+MMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, RANKE
      CHARACTER*1      JOBQ, JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX),
     $                 Q(LDQ,MMAX), Z(LDZ,NMAX)
      INTEGER          ISTAIR(MMAX)
*     .. External Subroutines ..
      EXTERNAL         MB04UD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, TOL
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M )
         JOBQ = 'N'
         JOBZ = 'N'
*        Reduce E to column echelon form and compute Q'*A*Z.
         CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ,
     $                RANKE, ISTAIR, TOL, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99991 )
            DO 10 I = 1, M
               WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99997 )
            DO 100 I = 1, M
               WRITE ( NOUT, FMT = 99996 ) ( E(I,J), J = 1,N )
  100       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) RANKE
            WRITE ( NOUT, FMT = 99994 ) ( ISTAIR(I), I = 1,M )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04UD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04UD = ',I2)
99997 FORMAT (' The transformed matrix E is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The computed rank of E = ',I2)
99994 FORMAT (/' ISTAIR is ',/20(1X,I5))
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (' The transformed matrix A is ')
      END
Program Data 
 MB04UD EXAMPLE PROGRAM DATA
   4     4     0.0
   2.0  0.0  2.0 -2.0
   0.0 -2.0  0.0  2.0
   2.0  0.0 -2.0  0.0
   2.0 -2.0  0.0  2.0
   1.0  0.0  1.0 -1.0
   0.0 -1.0  0.0  1.0
   1.0  0.0 -1.0  0.0
   1.0 -1.0  0.0  1.0
Program Results 
 MB04UD EXAMPLE PROGRAM RESULTS

 The transformed matrix A is 
   0.5164   1.0328   1.1547  -2.3094
   0.0000  -2.5820   0.0000  -1.1547
   0.0000   0.0000  -3.4641   0.0000
   0.0000   0.0000   0.0000  -3.4641
 The transformed matrix E is 
   0.2582   0.5164   0.5774  -1.1547
   0.0000  -1.2910   0.0000  -0.5774
   0.0000   0.0000  -1.7321   0.0000
   0.0000   0.0000   0.0000  -1.7321

 The computed rank of E =  4

 ISTAIR is 
     1     2     3     4

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04VD.html000077500000000000000000000467201201767322700161110ustar00rootroot00000000000000 MB04VD - SLICOT Library Routine Documentation

MB04VD

Upper block triangular form for a rectangular pencil sE-A, with E in column echelon form (added functionality)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal transformations Q and Z such that the
  transformed pencil Q'(sE-A)Z is in upper block triangular form,
  where E is an M-by-N matrix in column echelon form (see SLICOT
  Library routine MB04UD) and A is an M-by-N matrix.

  If MODE = 'B', then the matrices A and E are transformed into the
  following generalized Schur form by unitary transformations Q1
  and Z1 :

                   | sE(eps,inf)-A(eps,inf) |      X     |
     Q1'(sE-A)Z1 = |------------------------|------------|.   (1)
                   |            O           | sE(r)-A(r) |

  The pencil sE(eps,inf)-A(eps,inf) is in staircase form, and it
  contains all Kronecker column indices and infinite elementary
  divisors of the pencil sE-A. The pencil sE(r)-A(r) contains all
  Kronecker row indices and elementary divisors of sE-A.
  Note: X is a pencil.

  If MODE = 'T', then the submatrices having full row and column
  rank in the pencil sE(eps,inf)-A(eps,inf) in (1) are
  triangularized by applying unitary transformations Q2 and Z2 to
  Q1'*(sE-A)*Z1.

  If MODE = 'S', then the pencil sE(eps,inf)-A(eps,inf) in (1) is
  separated into sE(eps)-A(eps) and sE(inf)-A(inf) by applying
  unitary transformations Q3 and Z3 to Q2'*Q1'*(sE-A)*Z1*Z2.

  This gives

             | sE(eps)-A(eps) |        X       |      X     |
             |----------------|----------------|------------|
             |        O       | sE(inf)-A(inf) |      X     |
  Q'(sE-A)Z =|=================================|============| (2)
             |                                 |            |
             |                O                | sE(r)-A(r) |

  where Q = Q1*Q2*Q3 and Z = Z1*Z2*Z3.
  Note: the pencil sE(r)-A(r) is not reduced further.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  MODE    CHARACTER*1
          Specifies the desired structure of the transformed
          pencil Q'(sE-A)Z to be computed as follows:
          = 'B':  Basic reduction given by (1);
          = 'T':  Further reduction of (1) to triangular form;
          = 'S':  Further separation of sE(eps,inf)-A(eps,inf)
                  in (1) into the two pencils in (2).

  JOBQ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Q the orthogonal row transformations, as follows:
          = 'N':  Do not form Q;
          = 'I':  Q is initialized to the unit matrix and the
                  orthogonal transformation matrix Q is returned;
          = 'U':  The given matrix Q is updated by the orthogonal
                  row transformations used in the reduction.

  JOBZ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Z the orthogonal column transformations, as
          follows:
          = 'N':  Do not form Z;
          = 'I':  Z is initialized to the unit matrix and the
                  orthogonal transformation matrix Z is returned;
          = 'U':  The given matrix Z is updated by the orthogonal
                  transformations used in the reduction.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows in the matrices A, E and the order of
          the matrix Q.  M >= 0.

  N       (input) INTEGER
          The number of columns in the matrices A, E and the order
          of the matrix Z.  N >= 0.

  RANKE   (input) INTEGER
          The rank of the matrix E in column echelon form.
          RANKE >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix to be row compressed.
          On exit, the leading M-by-N part of this array contains
          the matrix that has been row compressed while keeping
          matrix E in column echelon form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading M-by-N part of this array must
          contain the matrix in column echelon form to be
          transformed equivalent to matrix A.
          On exit, the leading M-by-N part of this array contains
          the matrix that has been transformed equivalent to matrix
          A.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,M).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
          On entry, if JOBQ = 'U', then the leading M-by-M part of
          this array must contain a given matrix Q (e.g. from a
          previous call to another SLICOT routine), and on exit, the
          leading M-by-M part of this array contains the product of
          the input matrix Q and the row transformation matrix used
          to transform the rows of matrices A and E.
          On exit, if JOBQ = 'I', then the leading M-by-M part of
          this array contains the matrix of accumulated orthogonal
          row transformations performed.
          If JOBQ = 'N', the array Q is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDQ = 1 and
          declare this array to be Q(1,1) in the calling program).

  LDQ     INTEGER
          The leading dimension of array Q. If JOBQ = 'U' or
          JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
          On entry, if JOBZ = 'U', then the leading N-by-N part of
          this array must contain a given matrix Z (e.g. from a
          previous call to another SLICOT routine), and on exit, the
          leading N-by-N part of this array contains the product of
          the input matrix Z and the column transformation matrix
          used to transform the columns of matrices A and E.
          On exit, if JOBZ = 'I', then the leading N-by-N part of
          this array contains the matrix of accumulated orthogonal
          column transformations performed.
          If JOBZ = 'N', the array Z is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDZ = 1 and
          declare this array to be Z(1,1) in the calling program).

  LDZ     INTEGER
          The leading dimension of array Z. If JOBZ = 'U' or
          JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.

  ISTAIR  (input/output) INTEGER array, dimension (M)
          On entry, this array must contain information on the
          column echelon form of the unitary transformed matrix E.
          Specifically, ISTAIR(i) must be set to +j if the first
          non-zero element E(i,j) is a corner point and -j
          otherwise, for i = 1,2,...,M.
          On exit, this array contains no useful information.

  NBLCKS  (output) INTEGER
          The number of submatrices having full row rank greater
          than or equal to 0 detected in matrix A in the pencil
          sE(x)-A(x),
             where  x = eps,inf  if MODE = 'B' or 'T',
             or     x = eps      if MODE = 'S'.

  NBLCKI  (output) INTEGER
          If MODE = 'S', the number of diagonal submatrices in the
          pencil sE(inf)-A(inf). If MODE = 'B' or 'T' then
          NBLCKI = 0.

  IMUK    (output) INTEGER array, dimension (MAX(N,M+1))
          The leading NBLCKS elements of this array contain the
          column dimensions mu(1),...,mu(NBLCKS) of the submatrices
          having full column rank in the pencil sE(x)-A(x),
             where  x = eps,inf  if MODE = 'B' or 'T',
             or     x = eps      if MODE = 'S'.

  INUK    (output) INTEGER array, dimension (MAX(N,M+1))
          The leading NBLCKS elements of this array contain the
          row dimensions nu(1),...,nu(NBLCKS) of the submatrices
          having full row rank in the pencil sE(x)-A(x),
             where  x = eps,inf  if MODE = 'B' or 'T',
             or     x = eps      if MODE = 'S'.

  IMUK0   (output) INTEGER array, dimension (limuk0),
          where limuk0 = N if MODE = 'S' and 1, otherwise.
          If MODE = 'S', then the leading NBLCKI elements of this
          array contain the dimensions mu0(1),...,mu0(NBLCKI)
          of the square diagonal submatrices in the pencil
          sE(inf)-A(inf).
          Otherwise, IMUK0 is not referenced and can be supplied
          as a dummy array.

  MNEI    (output) INTEGER array, dimension (3)
          If MODE = 'B' or 'T' then
          MNEI(1) contains the row dimension of
                  sE(eps,inf)-A(eps,inf);
          MNEI(2) contains the column dimension of
                  sE(eps,inf)-A(eps,inf);
          MNEI(3) = 0.
          If MODE = 'S', then
          MNEI(1) contains the row    dimension of sE(eps)-A(eps);
          MNEI(2) contains the column dimension of sE(eps)-A(eps);
          MNEI(3) contains the order of the regular pencil
                  sE(inf)-A(inf).
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance below which matrix elements are considered
          to be zero. If the user sets TOL to be less than (or
          equal to) zero then the tolerance is taken as
          EPS * MAX( ABS(A(I,J)), ABS(E(I,J)) ), where EPS is the
          machine precision (see LAPACK Library routine DLAMCH),
          I = 1,2,...,M and J = 1,2,...,N.
Workspace 
  IWORK   INTEGER array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
          > 0:  if incorrect rank decisions were revealed during the
                triangularization phase. This failure is not likely
                to occur. The possible values are:
          = 1:  if incorrect dimensions of a full column rank
                submatrix;
          = 2:  if incorrect dimensions of a full row rank
                submatrix.
Method 
  Let sE - A be an arbitrary pencil. Prior to calling the routine,
  this pencil must be transformed into a pencil with E in column
  echelon form. This may be accomplished by calling the SLICOT
  Library routine MB04UD. Depending on the value of MODE,
  submatrices of A and E are then reduced to one of the forms
  described above. Further details can be found in [1].
References 
  [1] Beelen, Th. and Van Dooren, P.
      An improved algorithm for the computation of Kronecker's
      canonical form of a singular pencil.
      Linear Algebra and Applications, 105, pp. 9-65, 1988.
Numerical Aspects 
  It is shown in [1] that the algorithm is numerically backward
  stable. The operations count is proportional to (MAX(M,N))**3.
Further Comments 
  The difference mu(k)-nu(k), for k = 1,2,...,NBLCKS, is the number
  of elementary Kronecker blocks of size k x (k+1).

  If MODE = 'B' or 'T' on entry, then the difference nu(k)-mu(k+1),
  for k = 1,2,...,NBLCKS, is the number of infinite elementary
  divisors of degree k (with mu(NBLCKS+1) = 0).

  If MODE = 'S' on entry, then the difference mu0(k)-mu0(k+1),
  for k = 1,2,...,NBLCKI, is the number of infinite elementary
  divisors of degree k (with mu0(NBLCKI+1) = 0).
  In the pencil sE(r)-A(r), the pencils sE(f)-A(f) and
  sE(eta)-A(eta) can be separated by pertransposing the pencil
  sE(r)-A(r) and calling the routine with MODE set to 'B'. The
  result has got to be pertransposed again. (For more details see
  [1]).
Example

Program Text 

*     MB04VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDE, LDQ, LDZ
      PARAMETER        ( LDA  = MMAX, LDE = MMAX, LDQ = MMAX,
     $                   LDZ = NMAX )
      INTEGER          LINUK
      PARAMETER        ( LINUK = MAX( NMAX,MMAX+1 ) )
*     PARAMETER        ( LINUK = NMAX+MMAX+1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX,MMAX ) )
*     PARAMETER        ( LDWORK = NMAX+MMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, NBLCKI, NBLCKS, RANKE
      CHARACTER*1      JOBQ, JOBZ, MODE
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX),
     $                 Q(LDQ,MMAX), Z(LDZ,NMAX)
      INTEGER          IMUK(LINUK), IMUK0(NMAX), INUK(LINUK),
     $                 ISTAIR(MMAX), IWORK(LIWORK), MNEI(3)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04UD, MB04VD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, TOL, MODE
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99984 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M )
         JOBQ = 'I'
         JOBZ = 'I'
*        Reduce E to column echelon form and compute Q'*A*Z.
         CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ,
     $                RANKE, ISTAIR, TOL, DWORK, INFO )
         JOBQ = 'U'
         JOBZ = 'U'
*
         IF ( INFO.EQ.0 ) THEN
*           Compute a unitary transformed pencil Q'*(s*E-A)*Z.
            CALL 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 )
*
            IF ( INFO.EQ.0 ) THEN
               WRITE ( NOUT, FMT = 99996 )
               WRITE ( NOUT, FMT = 99995 )
               DO 140 I = 1, M
                  WRITE ( NOUT, FMT = 99994 ) ( Q(I,J), J = 1,M )
  140          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 160 I = 1, M
                  WRITE ( NOUT, FMT = 99994 ) ( E(I,J), J = 1,N )
  160          CONTINUE
               WRITE ( NOUT, FMT = 99992 )
               DO 180 I = 1, M
                  WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N )
  180          CONTINUE
               WRITE ( NOUT, FMT = 99991 )
               DO 200 I = 1, N
                  WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N )
  200          CONTINUE
               WRITE ( NOUT, FMT = 99990 ) NBLCKS
               IF ( .NOT. LSAME( MODE, 'S' ) ) THEN
                  WRITE ( NOUT, FMT = 99989 ) ( IMUK(I),  I = 1,NBLCKS )
                  WRITE ( NOUT, FMT = 99988 ) ( INUK(I),  I = 1,NBLCKS )
               ELSE
                  WRITE ( NOUT, FMT = 99987 ) ( IMUK(I),  I = 1,NBLCKS )
                  WRITE ( NOUT, FMT = 99986 ) ( INUK(I),  I = 1,NBLCKS )
                  WRITE ( NOUT, FMT = 99982 ) ( IMUK0(I), I = 1,NBLCKI )
                  WRITE ( NOUT, FMT = 99985 ) ( MNEI(I),  I = 1,3 )
               END IF
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99997 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04VD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04VD = ',I2)
99997 FORMAT (' INFO on exit from MB04UD = ',I2)
99996 FORMAT (' The unitary transformed pencil is Q''*(s*E-A)*Z, where',
     $          /)
99995 FORMAT (' Matrix Q',/)
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' Matrix E',/)
99992 FORMAT (/' Matrix A',/)
99991 FORMAT (/' Matrix Z',/)
99990 FORMAT (/' The number of submatrices having full row rank detect',
     $       'ed in matrix A = ',I3)
99989 FORMAT (/' The column dimensions of the submatrices having full ',
     $       'column rank in the pencil',/' sE(eps,inf) - A(eps,inf) a',
     $       're',/20(1X,I5))
99988 FORMAT (/' The row dimensions of the submatrices having full row',
     $       ' rank in the pencil',/' sE(eps,inf) - A(eps,inf) are',
     $       /20(1X,I5))
99987 FORMAT (/' The column dimensions of the submatrices having full ',
     $       'column rank in the pencil',/' sE(eps) - A(eps) are',
     $       /20(1X,I5))
99986 FORMAT (/' The row dimensions of the submatrices having full row',
     $       ' rank in the pencil',/' sE(eps) - A(eps) are',/20(1X,I5))
99985 FORMAT (/' MNEI is ',/20(1X,I5))
99984 FORMAT (/' M is out of range.',/' M = ',I5)
99983 FORMAT (/' N is out of range.',/' N = ',I5)
99982 FORMAT (/' The orders of the diagonal submatrices in the pencil ',
     $       'sE(inf) - A(inf) are',/20(1X,I5))
      END
Program Data 
 MB04VD EXAMPLE PROGRAM DATA
   2     4     0.0     S
   1.0  0.0 -1.0  0.0
   1.0  1.0  0.0 -1.0
   0.0 -1.0  0.0  0.0
   0.0 -1.0  0.0  0.0
Program Results 
 MB04VD EXAMPLE PROGRAM RESULTS

 The unitary transformed pencil is Q'*(s*E-A)*Z, where

 Matrix Q

   0.7071  -0.7071
   0.7071   0.7071

 Matrix E

   0.0000   0.0000  -1.1547   0.8165
   0.0000   0.0000   0.0000   0.0000

 Matrix A

   0.0000   1.7321   0.5774  -0.4082
   0.0000   0.0000   0.0000  -1.2247

 Matrix Z

   0.5774   0.8165   0.0000   0.0000
   0.0000   0.0000   0.8165  -0.5774
   0.5774  -0.4082  -0.4082  -0.5774
   0.5774  -0.4082   0.4082   0.5774

 The number of submatrices having full row rank detected in matrix A =   2

 The column dimensions of the submatrices having full column rank in the pencil
 sE(eps) - A(eps) are
     2     1

 The row dimensions of the submatrices having full row rank in the pencil
 sE(eps) - A(eps) are
     1     0

 The orders of the diagonal submatrices in the pencil sE(inf) - A(inf) are
     1

 MNEI is 
     1     3     1

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04WD.html000077500000000000000000000137311201767322700161060ustar00rootroot00000000000000 MB04WD - SLICOT Library Routine Documentation

MB04WD

Generating an orthogonal basis spanning an isotropic subspace

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate a matrix Q with orthogonal columns (spanning an
  isotropic subspace), which is defined as the first n columns
  of a product of symplectic reflectors and Givens rotators,

      Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
          diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
                            ....
          diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).

  The matrix Q is returned in terms of its first 2*M rows

                   [  op( Q1 )   op( Q2 ) ]
               Q = [                      ].
                   [ -op( Q2 )   op( Q1 ) ]

  Blocked version of the SLICOT Library routine MB04WU.
Specification 
      SUBROUTINE MB04WD( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2,
     $                   CS, TAU, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  TRANQ1  CHARACTER*1
          Specifies the form of op( Q1 ) as follows:
          = 'N':  op( Q1 ) = Q1;
          = 'T':  op( Q1 ) = Q1';
          = 'C':  op( Q1 ) = Q1'.

  TRANQ2  CHARACTER*1
          Specifies the form of op( Q2 ) as follows:
          = 'N':  op( Q2 ) = Q2;
          = 'T':  op( Q2 ) = Q2';
          = 'C':  op( Q2 ) = Q2'.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrices Q1 and Q2. M >= 0.

  N       (input) INTEGER
          The number of columns of the matrices Q1 and Q2.
          M >= N >= 0.

  K       (input) INTEGER
          The number of symplectic Givens rotators whose product
          partly defines the matrix Q. N >= K >= 0.

  Q1      (input/output) DOUBLE PRECISION array, dimension
                  (LDQ1,N) if TRANQ1 = 'N',
                  (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C'
          On entry with TRANQ1 = 'N', the leading M-by-K part of
          this array must contain in its i-th column the vector
          which defines the elementary reflector F(i).
          On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
          K-by-M part of this array must contain in its i-th row
          the vector which defines the elementary reflector F(i).
          On exit with TRANQ1 = 'N', the leading M-by-N part of this
          array contains the matrix Q1.
          On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
          N-by-M part of this array contains the matrix Q1'.

  LDQ1    INTEGER
          The leading dimension of the array Q1.
          LDQ1 >= MAX(1,M),  if TRANQ1 = 'N';
          LDQ1 >= MAX(1,N),  if TRANQ1 = 'T' or TRANQ1 = 'C'.

  Q2      (input/output) DOUBLE PRECISION array, dimension
                  (LDQ2,N) if TRANQ2 = 'N',
                  (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C'
          On entry with TRANQ2 = 'N', the leading M-by-K part of
          this array must contain in its i-th column the vector
          which defines the elementary reflector H(i) and, on the
          diagonal, the scalar factor of H(i).
          On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
          K-by-M part of this array must contain in its i-th row the
          vector which defines the elementary reflector H(i) and, on
          the diagonal, the scalar factor of H(i).
          On exit with TRANQ2 = 'N', the leading M-by-N part of this
          array contains the matrix Q2.
          On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
          N-by-M part of this array contains the matrix Q2'.

  LDQ2    INTEGER
          The leading dimension of the array Q2.
          LDQ2 >= MAX(1,M),  if TRANQ2 = 'N';
          LDQ2 >= MAX(1,N),  if TRANQ2 = 'T' or TRANQ2 = 'C'.

  CS      (input) DOUBLE PRECISION array, dimension (2*K)
          On entry, the first 2*K elements of this array must
          contain the cosines and sines of the symplectic Givens
          rotators G(i).

  TAU     (input) DOUBLE PRECISION array, dimension (K)
          On entry, the first K elements of this array must
          contain the scalar factors of the elementary reflectors
          F(i).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK, MAX(M+N,8*N*NB + 15*NB*NB), where NB is
          the optimal block size determined by the function UE01MD.
          On exit, if  INFO = -13,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,M+N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Kressner, D.
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04WP.html000077500000000000000000000113331201767322700161160ustar00rootroot00000000000000 MB04WP - SLICOT Library Routine Documentation

MB04WP

Generating an orthogonal symplectic matrix which performed the reduction in MB04PU

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate an orthogonal symplectic matrix U, which is defined as
  a product of symplectic reflectors and Givens rotators

  U = diag( H(1),H(1) )      G(1)  diag( F(1),F(1) )
      diag( H(2),H(2) )      G(2)  diag( F(2),F(2) )
                             ....
      diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ).

  as returned by MB04PU. The matrix U is returned in terms of its
  first N rows

                   [  U1   U2 ]
               U = [          ].
                   [ -U2   U1 ]
Specification 
      SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           ILO, INFO, LDU1, LDU2, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), U1(LDU1,*), U2(LDU2,*), TAU(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrices U1 and U2.  N >= 0.

  ILO     (input) INTEGER
          ILO must have the same value as in the previous call of
          MB04PU. U is equal to the unit matrix except in the
          submatrix
          U([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]).
          1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.

  U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
          On entry, the leading N-by-N part of this array must
          contain in its i-th column the vector which defines the
          elementary reflector F(i).
          On exit, the leading N-by-N part of this array contains
          the matrix U1.

  LDU1    INTEGER
          The leading dimension of the array U1.  LDU1 >= MAX(1,N).

  U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
          On entry, the leading N-by-N part of this array must
          contain in its i-th column the vector which defines the
          elementary reflector H(i) and, on the subdiagonal, the
          scalar factor of H(i).
          On exit, the leading N-by-N part of this array contains
          the matrix U2.

  LDU2    INTEGER
          The leading dimension of the array U2.  LDU2 >= MAX(1,N).

  CS      (input) DOUBLE PRECISION array, dimension (2N-2)
          On entry, the first 2N-2 elements of this array must
          contain the cosines and sines of the symplectic Givens
          rotators G(i).

  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
          On entry, the first N-1 elements of this array must
          contain the scalar factors of the elementary reflectors
          F(i).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -10,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK. LDWORK >= MAX(1,2*(N-ILO)).
          For optimum performance LDWORK should be larger. (See
          SLICOT Library routine MB04WD).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Numerical Aspects 
  The algorithm requires O(N**3) floating point operations and is
  strongly backward stable.
References 
  [1] C. F. VAN LOAN:
      A symplectic method for approximating all the eigenvalues of
      a Hamiltonian matrix.
      Linear Algebra and its Applications, 61, pp. 233-251, 1984.

  [2] D. KRESSNER:
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04WR.html000077500000000000000000000161741201767322700161300ustar00rootroot00000000000000 MB04WR - SLICOT Library Routine Documentation

MB04WR

Generating orthogonal symplectic matrices defined as products of symplectic reflectors and Givens rotators

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate orthogonal symplectic matrices U or V, defined as
  products of symplectic reflectors and Givens rotators

  U = diag( HU(1),HU(1) )  GU(1)  diag( FU(1),FU(1) )
      diag( HU(2),HU(2) )  GU(2)  diag( FU(2),FU(2) )
                           ....
      diag( HU(n),HU(n) )  GU(n)  diag( FU(n),FU(n) ),

  V = diag( HV(1),HV(1) )       GV(1)   diag( FV(1),FV(1) )
      diag( HV(2),HV(2) )       GV(2)   diag( FV(2),FV(2) )
                                ....
      diag( HV(n-1),HV(n-1) )  GV(n-1)  diag( FV(n-1),FV(n-1) ),

  as returned by the SLICOT Library routines MB04TS or MB04TB. The
  matrices U and V are returned in terms of their first N/2 rows:

              [  U1   U2 ]           [  V1   V2 ]
          U = [          ],      V = [          ].
              [ -U2   U1 ]           [ -V2   V1 ]
Specification 
      SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS,
     $                   TAU, DWORK, LDWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  JOB     CHARACTER*1
          Specifies whether the matrix U or the matrix V is
          required:
          = 'U':  generate U;
          = 'V':  generate V.

  TRANS   CHARACTER*1
          If  JOB = 'U'  then TRANS must have the same value as
          the argument TRANA in the previous call of MB04TS or
          MB04TB.
          If  JOB = 'V'  then TRANS must have the same value as
          the argument TRANB in the previous call of MB04TS or
          MB04TB.

  N       (input) INTEGER
          The order of the matrices Q1 and Q2. N >= 0.

  ILO     (input) INTEGER
          ILO must have the same value as in the previous call of
          MB04TS or MB04TB. U and V are equal to the unit matrix
          except in the submatrices
          U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and
          V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]),
          respectively.
          1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.

  Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1,N)
          On entry, if  JOB = 'U'  and  TRANS = 'N'  then the
          leading N-by-N part of this array must contain in its i-th
          column the vector which defines the elementary reflector
          FU(i).
          If  JOB = 'U'  and  TRANS = 'T'  or  TRANS = 'C' then the
          leading N-by-N part of this array must contain in its i-th
          row the vector which defines the elementary reflector
          FU(i).
          If  JOB = 'V'  and  TRANS = 'N'  then the leading N-by-N
          part of this array must contain in its i-th row the vector
          which defines the elementary reflector FV(i).
          If  JOB = 'V'  and  TRANS = 'T'  or  TRANS = 'C' then the
          leading N-by-N part of this array must contain in its i-th
          column the vector which defines the elementary reflector
          FV(i).
          On exit, if  JOB = 'U'  and  TRANS = 'N'  then the leading
          N-by-N part of this array contains the matrix U1.
          If  JOB = 'U'  and  TRANS = 'T'  or  TRANS = 'C' then the
          leading N-by-N part of this array contains the matrix
          U1**T.
          If  JOB = 'V'  and  TRANS = 'N'  then the leading N-by-N
          part of this array contains the matrix V1**T.
          If  JOB = 'V'  and  TRANS = 'T'  or  TRANS = 'C' then the
          leading N-by-N part of this array contains the matrix V1.

  LDQ1    INTEGER
          The leading dimension of the array Q1.  LDQ1 >= MAX(1,N).

  Q2      (input/output) DOUBLE PRECISION array, dimension (LDQ2,N)
          On entry, if  JOB = 'U'  then the leading N-by-N part of
          this array must contain in its i-th column the vector
          which defines the elementary reflector HU(i).
          If  JOB = 'V'  then the leading N-by-N part of this array
          must contain in its i-th row the vector which defines the
          elementary reflector HV(i).
          On exit, if  JOB = 'U'  then the leading N-by-N part of
          this array contains the matrix U2.
          If  JOB = 'V'  then the leading N-by-N part of this array
          contains the matrix V2**T.

  LDQ2    INTEGER
          The leading dimension of the array Q2.  LDQ2 >= MAX(1,N).

  CS      (input) DOUBLE PRECISION array, dimension (2N)
          On entry, if  JOB = 'U'  then the first 2N elements of
          this array must contain the cosines and sines of the
          symplectic Givens rotators GU(i).
          If  JOB = 'V'  then the first 2N-2 elements of this array
          must contain the cosines and sines of the symplectic
          Givens rotators GV(i).

  TAU     (input) DOUBLE PRECISION array, dimension (N)
          On entry, if  JOB = 'U'  then the first N elements of
          this array must contain the scalar factors of the
          elementary reflectors FU(i).
          If  JOB = 'V'  then the first N-1 elements of this array
          must contain the scalar factors of the elementary
          reflectors FV(i).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -12,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,2*(N-ILO+1)).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Benner, P., Mehrmann, V., and Xu, H.
      A numerically stable, structure preserving method for
      computing the eigenvalues of real Hamiltonian or symplectic
      pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998.

  [2] Kressner, D.
      Block algorithms for orthogonal symplectic factorizations.
      BIT, 43 (4), pp. 775-790, 2003.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04WU.html000077500000000000000000000135241201767322700161270ustar00rootroot00000000000000 MB04WU - SLICOT Library Routine Documentation

MB04WU

Generating an orthogonal basis spanning an isotropic subspace (unblocked version)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To generate a matrix Q with orthogonal columns (spanning an
  isotropic subspace), which is defined as the first n columns
  of a product of symplectic reflectors and Givens rotators,

      Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
          diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
                            ....
          diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).

  The matrix Q is returned in terms of its first 2*M rows

                   [  op( Q1 )   op( Q2 ) ]
               Q = [                      ].
                   [ -op( Q2 )   op( Q1 ) ]
Specification 
      SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2,
     $                   CS, TAU, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  TRANQ1  CHARACTER*1
          Specifies the form of op( Q1 ) as follows:
          = 'N':  op( Q1 ) = Q1;
          = 'T':  op( Q1 ) = Q1';
          = 'C':  op( Q1 ) = Q1'.

  TRANQ2  CHARACTER*1
          Specifies the form of op( Q2 ) as follows:
          = 'N':  op( Q2 ) = Q2;
          = 'T':  op( Q2 ) = Q2';
          = 'C':  op( Q2 ) = Q2'.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrices Q1 and Q2. M >= 0.

  N       (input) INTEGER
          The number of columns of the matrices Q1 and Q2.
          M >= N >= 0.

  K       (input) INTEGER
          The number of symplectic Givens rotators whose product
          partly defines the matrix Q. N >= K >= 0.

  Q1      (input/output) DOUBLE PRECISION array, dimension
                  (LDQ1,N) if TRANQ1 = 'N',
                  (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C'
          On entry with TRANQ1 = 'N', the leading M-by-K part of
          this array must contain in its i-th column the vector
          which defines the elementary reflector F(i).
          On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
          K-by-M part of this array must contain in its i-th row
          the vector which defines the elementary reflector F(i).
          On exit with TRANQ1 = 'N', the leading M-by-N part of this
          array contains the matrix Q1.
          On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
          N-by-M part of this array contains the matrix Q1'.

  LDQ1    INTEGER
          The leading dimension of the array Q1.
          LDQ1 >= MAX(1,M),  if TRANQ1 = 'N';
          LDQ1 >= MAX(1,N),  if TRANQ1 = 'T' or TRANQ1 = 'C'.

  Q2      (input/output) DOUBLE PRECISION array, dimension
                  (LDQ2,N) if TRANQ2 = 'N',
                  (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C'
          On entry with TRANQ2 = 'N', the leading M-by-K part of
          this array must contain in its i-th column the vector
          which defines the elementary reflector H(i) and, on the
          diagonal, the scalar factor of H(i).
          On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
          K-by-M part of this array must contain in its i-th row the
          vector which defines the elementary reflector H(i) and, on
          the diagonal, the scalar factor of H(i).
          On exit with TRANQ2 = 'N', the leading M-by-N part of this
          array contains the matrix Q2.
          On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
          N-by-M part of this array contains the matrix Q2'.

  LDQ2    INTEGER
          The leading dimension of the array Q2.
          LDQ2 >= MAX(1,M),  if TRANQ2 = 'N';
          LDQ2 >= MAX(1,N),  if TRANQ2 = 'T' or TRANQ2 = 'C'.

  CS      (input) DOUBLE PRECISION array, dimension (2*K)
          On entry, the first 2*K elements of this array must
          contain the cosines and sines of the symplectic Givens
          rotators G(i).

  TAU     (input) DOUBLE PRECISION array, dimension (K)
          On entry, the first K elements of this array must
          contain the scalar factors of the elementary reflectors
          F(i).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0,  DWORK(1)  returns the optimal
          value of LDWORK.
          On exit, if  INFO = -13,  DWORK(1)  returns the minimum
          value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= MAX(1,M+N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
References 
  [1] Bunse-Gerstner, A.
      Matrix factorizations for symplectic QR-like methods.
      Linear Algebra Appl., 83, pp. 49-77, 1986.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04XD.html000077500000000000000000000534701201767322700161130ustar00rootroot00000000000000 MB04XD - SLICOT Library Routine Documentation

MB04XD

Basis for left/right singular subspace of a matrix corresponding to its smallest singular values

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a basis for the left and/or right singular subspace of
  an M-by-N matrix A corresponding to its smallest singular values.
Specification 
      SUBROUTINE MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU,
     $                   V, LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK,
     $                   IWARN, INFO )
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,*)
Arguments

Mode Parameters 

  JOBU    CHARACTER*1
          Specifies whether to compute the left singular subspace
          as follows:
          = 'N':  Do not compute the left singular subspace;
          = 'A':  Return the (M - RANK) base vectors of the desired
                  left singular subspace in U;
          = 'S':  Return the first (min(M,N) - RANK) base vectors
                  of the desired left singular subspace in U.

  JOBV    CHARACTER*1
          Specifies whether to compute the right singular subspace
          as follows:
          = 'N':  Do not compute the right singular subspace;
          = 'A':  Return the (N - RANK) base vectors of the desired
                  right singular subspace in V;
          = 'S':  Return the first (min(M,N) - RANK) base vectors
                  of the desired right singular subspace in V.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows in matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns in matrix A.  N >= 0.

  RANK    (input/output) INTEGER
          On entry, if RANK < 0, then the rank of matrix A is
          computed by the routine as the number of singular values
          greater than THETA.
          Otherwise, RANK must specify the rank of matrix A.
          RANK <= min(M,N).
          On exit, if RANK < 0 on entry, then RANK contains the
          computed rank of matrix A. That is, the number of singular
          values of A greater than THETA.
          Otherwise, the user-supplied value of RANK may be changed
          by the routine on exit if the RANK-th and the (RANK+1)-th
          singular values of A are considered to be equal.
          See also the description of parameter TOL below.

  THETA   (input/output) DOUBLE PRECISION
          On entry, if RANK < 0, then THETA must specify an upper
          bound on the smallest singular values of A corresponding
          to the singular subspace to be computed.  THETA >= 0.0.
          Otherwise, THETA must specify an initial estimate (t say)
          for computing an upper bound on the (min(M,N) - RANK)
          smallest singular values of A. If THETA < 0.0, then t is
          computed by the routine.
          On exit, if RANK >= 0 on entry, then THETA contains the
          computed upper bound such that precisely RANK singular
          values of A are greater than THETA + TOL.
          Otherwise, THETA is unchanged.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading M-by-N part of this array must contain the
          matrix A from which the basis of a desired singular
          subspace is to be computed.
          NOTE that this array is destroyed.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,M).

  U       (output) DOUBLE PRECISION array, dimension (LDU,*)
          If JOBU = 'A', then the leading M-by-M part of this array
          contains the (M - RANK) M-dimensional base vectors of the
          desired left singular subspace of A corresponding to its
          singular values less than or equal to THETA. These vectors
          are stored in the i-th column(s) of U for which
          INUL(i) = .TRUE., where i = 1,2,...,M.

          If JOBU = 'S', then the leading M-by-min(M,N) part of this
          array contains the first (min(M,N) - RANK) M-dimensional
          base vectors of the desired left singular subspace of A
          corresponding to its singular values less than or equal to
          THETA. These vectors are stored in the i-th column(s) of U
          for which INUL(i) = .TRUE., where i = 1,2,..., min(M,N).

          Otherwise, U is not referenced (since JOBU = 'N') and can
          be supplied as a dummy array (i.e. set parameter LDU = 1
          and declare this array to be U(1,1) in the calling
          program).

  LDU     INTEGER
          The leading dimension of array U.
          LDU >= max(1,M) if JOBU = 'A' or JOBU = 'S',
          LDU >= 1        if JOBU = 'N'.

  V       (output) DOUBLE PRECISION array, dimension (LDV,*)
          If JOBV = 'A', then the leading N-by-N part of this array
          contains the (N - RANK) N-dimensional base vectors of the
          desired right singular subspace of A corresponding to its
          singular values less than or equal to THETA. These vectors
          are stored in the i-th column(s) of V for which
          INUL(i) = .TRUE., where i = 1,2,...,N.

          If JOBV = 'S', then the leading N-by-min(M,N) part of this
          array contains the first (min(M,N) - RANK) N-dimensional
          base vectors of the desired right singular subspace of A
          corresponding to its singular values less than or equal to
          THETA. These vectors are stored in the i-th column(s) of V
          for which INUL(i) = .TRUE., where i = 1,2,...,MIN( M,N).

          Otherwise, V is not referenced (since JOBV = 'N') and can
          be supplied as a dummy array (i.e. set parameter LDV = 1
          and declare this array to be V(1,1) in the calling
          program).

  LDV     INTEGER
          The leading dimension of array V.
          LDV >= max(1,N) if JOBV = 'A' or JOBV = 'S',
          LDV >= 1        if JOBV = 'N'.

  Q       (output) DOUBLE PRECISION array, dimension (2*min(M,N)-1)
          This array contains the partially diagonalized bidiagonal
          matrix J computed from A, at the moment that the desired
          singular subspace has been found. Specifically, the
          leading p = min(M,N) entries of Q contain the diagonal
          elements q(1),q(2),...,q(p) and the entries Q(p+1),
          Q(p+2),...,Q(2*p-1) contain the superdiagonal elements
          e(1),e(2),...,e(p-1) of J.

  INUL    (output) LOGICAL array, dimension (max(M,N))
          If JOBU <> 'N' or JOBV <> 'N', then the indices of the
          elements of this array with value .TRUE. indicate the
          columns in U and/or V containing the base vectors of the
          desired left and/or right singular subspace of A. They
          also equal the indices of the diagonal elements of the
          bidiagonal submatrices in the array Q, which correspond
          to the computed singular subspaces.
Tolerances 
  TOL     DOUBLE PRECISION
          This parameter defines the multiplicity of singular values
          by considering all singular values within an interval of
          length TOL as coinciding. TOL is used in checking how many
          singular values are less than or equal to THETA. Also in
          computing an appropriate upper bound THETA by a bisection
          method, TOL is used as a stopping criterion defining the
          minimum (absolute) subinterval width. TOL is also taken
          as an absolute tolerance for negligible elements in the
          QR/QL iterations. If the user sets TOL to be less than or
          equal to 0, then the tolerance is taken as specified in
          SLICOT Library routine MB04YD document.

  RELTOL  DOUBLE PRECISION
          This parameter specifies the minimum relative width of an
          interval. When an interval is narrower than TOL, or than
          RELTOL times the larger (in magnitude) endpoint, then it
          is considered to be sufficiently small and bisection has
          converged. If the user sets RELTOL to be less than
          BASE * EPS, where BASE is machine radix and EPS is machine
          precision (see LAPACK Library routine DLAMCH), then the
          tolerance is taken as BASE * EPS.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = max(1, LDW + max(2*P + max(M,N), LDY)), where
               P = min(M,N);
             LDW = max(2*N, N*(N+1)/2), if JOBU <> 'N' and M large
                                                     enough than N;
             LDW = 0,                   otherwise;
             LDY = 8*P - 5, if JOBU <> 'N' or  JOBV <> 'N';
             LDY = 6*P - 3, if JOBU =  'N' and JOBV =  'N'.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  if the rank of matrix A (as specified by the user)
                has been lowered because a singular value of
                multiplicity greater than 1 was found.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the maximum number of QR/QL iteration steps
                (30*MIN(M,N)) has been exceeded.
Method 
  The method used is the Partial Singular Value Decomposition (PSVD)
  approach proposed by Van Huffel, Vandewalle and Haegemans, which
  is an efficient technique (see [1]) for computing the singular
  subspace of a matrix corresponding to its smallest singular
  values. It differs from the classical SVD algorithm [3] at three
  points, which results in high efficiency. Firstly, the Householder
  transformations of the bidiagonalization need only to be applied
  on the base vectors of the desired singular subspaces; secondly,
  the bidiagonal matrix need only be partially diagonalized; and
  thirdly, the convergence rate of the iterative diagonalization can
  be improved by an appropriate choice between QL and QR iterations.
  (Note, however, that LAPACK Library routine DGESVD, for computing
  SVD, also uses either QL and QR iterations.) Depending on the gap,
  the desired numerical accuracy and the dimension of the desired
  singular subspace, the PSVD can be up to three times faster than
  the classical SVD algorithm.

  The PSVD algorithm [1-2] for an M-by-N matrix A proceeds as
  follows:

  Step 1: Bidiagonalization phase
          -----------------------
   (a) If M is large enough than N, transform A into upper
       triangular form R.

   (b) Transform A (or R) into bidiagonal form:

             |q(1) e(1)  0   ...  0   |
        (0)  | 0   q(2) e(2)      .   |
       J   = | .                  .   |
             | .                e(N-1)|
             | 0            ...  q(N) |

  if M >= N, or

             |q(1)  0    0   ...  0     0   |
        (0)  |e(1) q(2)  0        .     .   |
       J   = | .                  .     .   |
             | .                 q(M-1) .   |
             | 0             ... e(M-1) q(M)|

  if M < N, using Householder transformations.
  In the second case, transform the matrix to the upper bidiagonal
  form by applying Givens rotations.

   (c) If U is requested, initialize U with the identity matrix.
       If V is requested, initialize V with the identity matrix.

  Step 2: Partial diagonalization phase
          -----------------------------
  If the upper bound THETA is not given, then compute THETA such
  that precisely (min(M,N) - RANK) singular values of the bidiagonal
  matrix are less than or equal to THETA, using a bisection method
  [4]. Diagonalize the given bidiagonal matrix J partially, using
  either QR iterations (if the upper left diagonal element of the
  considered bidiagonal submatrix is larger than the lower right
  diagonal element) or QL iterations, such that J is split into
  unreduced bidiagonal submatrices whose singular values are either
  all larger than THETA or all less than or equal to THETA.
  Accumulate the Givens rotations in U and/or V (if desired).

  Step 3: Back transformation phase
          -------------------------
   (a) Apply the Householder transformations of Step 1(b) onto the
       columns of U and/or V associated with the bidiagonal
       submatrices with all singular values less than or equal to
       THETA (if U and/or V is desired).

   (b) If M is large enough than N, and U is desired, then apply the
       Householder transformations of Step 1(a) onto each computed
       column of U in Step 3(a).
References 
  [1] Van Huffel, S., Vandewalle, J. and Haegemans, A.
      An efficient and reliable algorithm for computing the singular
      subspace of a matrix associated with its smallest singular
      values.
      J. Comput. and Appl. Math., 19, pp. 313-330, 1987.

  [2] Van Huffel, S.
      Analysis of the total least squares problem and its use in
      parameter estimation.
      Doctoral dissertation, Dept. of Electr. Eng., Katholieke
      Universiteit Leuven, Belgium, June 1987.

  [3] Chan, T.F.
      An improved algorithm for computing the singular value
      decomposition.
      ACM TOMS, 8, pp. 72-83, 1982.

  [4] Van Huffel, S. and Vandewalle, J.
      The partial total least squares algorithm.
      J. Comput. and Appl. Math., 21, pp. 333-341, 1988.
Numerical Aspects 
  Using the PSVD a large reduction in computation time can be
  gained in total least squares applications (cf [2 - 4]), in the
  computation of the null space of a matrix and in solving
  (non)homogeneous linear equations.
Further Comments 
  None
Example

Program Text 

*     MB04XD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDU, LDV
      PARAMETER        ( LDA = MMAX, LDU = MMAX, LDV = NMAX )
      INTEGER          MAXMN, MNMIN
      PARAMETER        ( MAXMN = MAX( MMAX, NMAX ),
     $                   MNMIN = MIN( MMAX, NMAX ) )
      INTEGER          LENGQ
      PARAMETER        ( LENGQ = 2*MNMIN-1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 2*NMAX, NMAX*( NMAX+1 )/2 )
     $                          + MAX( 2*MNMIN + MAXMN, 8*MNMIN - 5 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION RELTOL, THETA, THETA1, TOL
      INTEGER          I, INFO, IWARN, J, K, LOOP, M, MINMN, N, NCOLU,
     $                 NCOLV, RANK, RANK1
      CHARACTER*1      JOBU, JOBV
      LOGICAL          LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), Q(LENGQ),
     $                 U(LDU,MMAX), V(LDV,NMAX)
      LOGICAL          INUL(MAXMN)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04XD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, RANK, THETA, TOL, RELTOL, JOBU, JOBV
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99982 ) N
      ELSE IF ( RANK.GT.MNMIN ) THEN
         WRITE ( NOUT, FMT = 99981 ) RANK
      ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         WRITE ( NOUT, FMT = 99980 ) THETA
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
         RANK1 = RANK
         THETA1 = THETA
*        Compute a basis for the left and right singular subspace of A.
         CALL MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, V,
     $                LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) RANK
            ELSE
               IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK
            END IF
            IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA
            LJOBUA = LSAME( JOBU, 'A' )
            LJOBUS = LSAME( JOBU, 'S' )
            LJOBVA = LSAME( JOBV, 'A' )
            LJOBVS = LSAME( JOBV, 'S' )
            WANTU = LJOBUA.OR.LJOBUS
            WANTV = LJOBVA.OR.LJOBVS
            WRITE ( NOUT, FMT = 99994 )
            MINMN = MIN( M, N )
            LOOP = MINMN - 1
            DO 20 I = 1, LOOP
               K = I + MINMN
               WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K)
   20       CONTINUE
            WRITE ( NOUT, FMT = 99992 ) MINMN, MINMN, Q(MINMN)
            IF ( WANTU ) THEN
               NCOLU = M
               IF ( LJOBUS ) NCOLU = MINMN
               WRITE ( NOUT, FMT = 99986 )
               DO 40 I = 1, M
                  WRITE ( NOUT, FMT = 99985 ) ( U(I,J), J = 1,NCOLU )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99991 ) NCOLU
               WRITE ( NOUT, FMT = 99990 )
               DO 60 I = 1, NCOLU
                  WRITE ( NOUT, FMT = 99989 ) I, INUL(I)
   60          CONTINUE
            END IF
            IF ( WANTV ) THEN
               NCOLV = N
               IF ( LJOBVS ) NCOLV = MINMN
               WRITE ( NOUT, FMT = 99984 )
               DO 80 I = 1, N
                  WRITE ( NOUT, FMT = 99985 ) ( V(I,J), J = 1,NCOLV )
   80          CONTINUE
               WRITE ( NOUT, FMT = 99988 ) NCOLV
               WRITE ( NOUT, FMT = 99987 )
               DO 100 J = 1, NCOLV
                  WRITE ( NOUT, FMT = 99989 ) J, INUL(J)
  100          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04XD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04XD = ',I2)
99997 FORMAT (' IWARN on exit from MB04XD = ',I2,/)
99996 FORMAT (' The computed rank of matrix A = ',I3,/)
99995 FORMAT (' The computed value of THETA = ',F7.4,/)
99994 FORMAT (' The elements of the partially diagonalized bidiagonal ',
     $       'matrix are',/)
99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/)
99991 FORMAT (/' Left singular subspace corresponds to the i-th column',
     $       '(s) of U for which ',/' INUL(i) = .TRUE., i = 1,...,',I1,
     $       /)
99990 FORMAT ('  i    INUL(i)',/)
99989 FORMAT (I3,L8)
99988 FORMAT (/' Right singular subspace corresponds to the j-th colum',
     $       'n(s) of V for which ',/' INUL(j) = .TRUE., j = 1,...,',I1,
     $       /)
99987 FORMAT ('  j    INUL(j)',/)
99986 FORMAT (' Matrix U',/)
99985 FORMAT (20(1X,F8.4))
99984 FORMAT (/' Matrix V',/)
99983 FORMAT (/' M is out of range.',/' M = ',I5)
99982 FORMAT (/' N is out of range.',/' N = ',I5)
99981 FORMAT (/' RANK is out of range.',/' RANK = ',I5)
99980 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4)
      END
Program Data 
 MB04XD EXAMPLE PROGRAM DATA
   6     4     -1     0.001     0.0     0.0     A     A
   0.80010  0.39985  0.60005  0.89999
   0.29996  0.69990  0.39997  0.82997
   0.49994  0.60003  0.20012  0.79011
   0.90013  0.20016  0.79995  0.85002
   0.39998  0.80006  0.49985  0.99016
   0.20002  0.90007  0.70009  1.02994
Program Results 
 MB04XD EXAMPLE PROGRAM RESULTS

 The computed rank of matrix A =   3

 The elements of the partially diagonalized bidiagonal matrix are

 (1,1) =  3.2280   (1,2) = -0.0287
 (2,2) =  0.8714   (2,3) =  0.0168
 (3,3) =  0.3698   (3,4) =  0.0000
 (4,4) =  0.0001

 Matrix U

   0.8933   0.4328  -0.1209   0.2499  -0.5812   0.4913
  -0.4493   0.8555  -0.2572   0.1617  -0.4608  -0.7379
  -0.0079   0.2841   0.9588  -0.5352   0.1892   0.0525
   0.0000   0.0000   0.0003  -0.1741   0.3389  -0.3397
   0.0000   0.0000   0.0000   0.6482   0.5428   0.1284
   0.0000   0.0000   0.0000  -0.4176  -0.0674   0.2819

 Left singular subspace corresponds to the i-th column(s) of U for which 
 INUL(i) = .TRUE., i = 1,...,6

  i    INUL(i)

  1       F
  2       F
  3       F
  4       T
  5       T
  6       T

 Matrix V

  -0.3967  -0.7096   0.4612  -0.3555
   0.9150  -0.2557   0.2414  -0.5687
  -0.0728   0.6526   0.5215  -0.2128
   0.0000   0.0720   0.6761   0.7106

 Right singular subspace corresponds to the j-th column(s) of V for which 
 INUL(j) = .TRUE., j = 1,...,4

  j    INUL(j)

  1       F
  2       F
  3       F
  4       T

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04XY.html000077500000000000000000000123771201767322700161410ustar00rootroot00000000000000 MB04XY - SLICOT Library Routine Documentation

MB04XY

Applying the Householder transformations for bidiagonalization (stored in factored form) to specified one or two matrices, from the left

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply the Householder transformations Pj stored in factored
  form into the columns of the array X, to the desired columns of
  the matrix U by premultiplication, and/or the Householder
  transformations Qj stored in factored form into the rows of the
  array X, to the desired columns of the matrix V by
  premultiplication. The Householder transformations Pj and Qj
  are stored as produced by LAPACK Library routine DGEBRD.
Specification 
      SUBROUTINE MB04XY( JOBU, JOBV, M, N, X, LDX, TAUP, TAUQ, U,
     $                   LDU, V, LDV, INUL, INFO )
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,*)
Arguments

Mode Parameters 

  JOBU    CHARACTER*1
          Specifies whether to transform the columns in U as
          follows:
          = 'N':  Do not transform the columns in U;
          = 'A':  Transform the columns in U (U has M columns);
          = 'S':  Transform the columns in U (U has min(M,N)
                  columns).

  JOBV    CHARACTER*1
          Specifies whether to transform the columns in V as
          follows:
          = 'N':  Do not transform the columns in V;
          = 'A':  Transform the columns in V (V has N columns);
          = 'S':  Transform the columns in V (V has min(M,N)
                  columns).
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix X.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix X.  N >= 0.

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          The leading M-by-N part contains in the columns of its
          lower triangle the Householder transformations Pj, and
          in the rows of its upper triangle the Householder
          transformations Qj in factored form.
          X is modified by the routine but restored on exit.

  LDX     INTEGER
          The leading dimension of the array X.   LDX >= MAX(1,M).

  TAUP    (input) DOUBLE PRECISION array, dimension (MIN(M,N))
          The scalar factors of the Householder transformations Pj.

  TAUQ    (input) DOUBLE PRECISION array, dimension (MIN(M,N))
          The scalar factors of the Householder transformations Qj.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,*)
          On entry, U contains the M-by-M (if JOBU = 'A') or
          M-by-min(M,N) (if JOBU = 'S') matrix U.
          On exit, the Householder transformations Pj have been
          applied to each column i of U corresponding to a parameter
          INUL(i) = .TRUE.
          NOTE that U is not referenced if JOBU = 'N'.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= MAX(1,M), if JOBU = 'A' or JOBU = 'S';
          LDU >= 1,        if JOBU = 'N'.

  V       (input/output) DOUBLE PRECISION array, dimension (LDV,*)
          On entry, V contains the N-by-N (if JOBV = 'A') or
          N-by-min(M,N) (if JOBV = 'S') matrix V.
          On exit, the Householder transformations Qj have been
          applied to each column i of V corresponding to a parameter
          INUL(i) = .TRUE.
          NOTE that V is not referenced if JOBV = 'N'.

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= MAX(1,M), if JOBV = 'A' or JOBV = 'S';
          LDV >= 1,        if JOBV = 'N'.

  INUL    (input) LOGICAL array, dimension (MAX(M,N))
          INUL(i) = .TRUE. if the i-th column of U and/or V is to be
          transformed, and INUL(i) = .FALSE., otherwise.
          (1 <= i <= MAX(M,N)).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The Householder transformations Pj or Qj are applied to the
  columns of U or V indexed by I for which INUL(I) = .TRUE..
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04YD.html000077500000000000000000000434361201767322700161150ustar00rootroot00000000000000 MB04YD - SLICOT Library Routine Documentation

MB04YD

Partial diagonalization of a bidiagonal matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To partially diagonalize the bidiagonal matrix

            |q(1) e(1)  0    ...       0      |
            | 0   q(2) e(2)            .      |
        J = | .                        .      |                  (1)
            | .                  e(MIN(M,N)-1)|
            | 0   ...        ...  q(MIN(M,N)) |

  using QR or QL iterations in such a way that J is split into
  unreduced bidiagonal submatrices whose singular values are either
  all larger than a given bound or are all smaller than (or equal
  to) this bound. The left- and right-hand Givens rotations
  performed on J (corresponding to each QR or QL iteration step) may
  be optionally accumulated in the arrays U and V.
Specification 
      SUBROUTINE MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V,
     $                   LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN,
     $                   INFO )
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,*)
Arguments

Mode Parameters 

  JOBU    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix U the left-hand Givens rotations, as follows:
          = 'N':  Do not form U;
          = 'I':  U is initialized to the M-by-MIN(M,N) submatrix of
                  the unit matrix and the left-hand Givens rotations
                  are accumulated in U;
          = 'U':  The given matrix U is updated by the left-hand
                  Givens rotations used in the calculation.

  JOBV    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix V the right-hand Givens rotations, as follows:
          = 'N':  Do not form V;
          = 'I':  V is initialized to the N-by-MIN(M,N) submatrix of
                  the unit matrix and the right-hand Givens
                  rotations are accumulated in V;
          = 'U':  The given matrix V is updated by the right-hand
                  Givens rotations used in the calculation.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows in matrix U.  M >= 0.

  N       (input) INTEGER
          The number of rows in matrix V.  N >= 0.

  RANK    (input/output) INTEGER
          On entry, if RANK < 0, then the rank of matrix J is
          computed by the routine as the number of singular values
          larger than THETA.
          Otherwise, RANK must specify the rank of matrix J.
          RANK <= MIN(M,N).
          On exit, if RANK < 0 on entry, then RANK contains the
          computed rank of J. That is, the number of singular
          values of J larger than THETA.
          Otherwise, the user-supplied value of RANK may be
          changed by the routine on exit if the RANK-th and the
          (RANK+1)-th singular values of J are considered to be
          equal. See also the parameter TOL.

  THETA   (input/output) DOUBLE PRECISION
          On entry, if RANK < 0, then THETA must specify an upper
          bound on the smallest singular values of J. THETA >= 0.0.
          Otherwise, THETA must specify an initial estimate (t say)
          for computing an upper bound such that precisely RANK
          singular values are greater than this bound.
          If THETA < 0.0, then t is computed by the routine.
          On exit, if RANK >= 0 on entry, then THETA contains the
          computed upper bound such that precisely RANK singular
          values of J are greater than THETA + TOL.
          Otherwise, THETA is unchanged.

  Q       (input/output) DOUBLE PRECISION array, dimension
          (MIN(M,N))
          On entry, this array must contain the diagonal elements
          q(1),q(2),...,q(MIN(M,N)) of the bidiagonal matrix J. That
          is, Q(i) = J(i,i) for i = 1,2,...,MIN(M,N).
          On exit, this array contains the leading diagonal of the
          transformed bidiagonal matrix J.

  E       (input/output) DOUBLE PRECISION array, dimension
          (MIN(M,N)-1)
          On entry, this array must contain the superdiagonal
          elements e(1),e(2),...,e(MIN(M,N)-1) of the bidiagonal
          matrix J. That is, E(k) = J(k,k+1) for k = 1,2,...,
          MIN(M,N)-1.
          On exit, this array contains the superdiagonal of the
          transformed bidiagonal matrix J.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,*)
          On entry, if JOBU = 'U', the leading M-by-MIN(M,N) part
          of this array must contain a left transformation matrix
          applied to the original matrix of the problem, and
          on exit, the leading M-by-MIN(M,N) part of this array
          contains the product of the input matrix U and the
          left-hand Givens rotations.
          On exit, if JOBU = 'I', then the leading M-by-MIN(M,N)
          part of this array contains the matrix of accumulated
          left-hand Givens rotations used.
          If JOBU = 'N', the array U is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDU = 1 and
          declare this array to be U(1,1) in the calling program).

  LDU     INTEGER
          The leading dimension of array U. If JOBU = 'U' or
          JOBU = 'I', LDU >= MAX(1,M); if JOBU = 'N', LDU >= 1.

  V       (input/output) DOUBLE PRECISION array, dimension (LDV,*)
          On entry, if JOBV = 'U', the leading N-by-MIN(M,N) part
          of this array must contain a right transformation matrix
          applied to the original matrix of the problem, and
          on exit, the leading N-by-MIN(M,N) part of this array
          contains the product of the input matrix V and the
          right-hand Givens rotations.
          On exit, if JOBV = 'I', then the leading N-by-MIN(M,N)
          part of this array contains the matrix of accumulated
          right-hand Givens rotations used.
          If JOBV = 'N', the array V is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDV = 1 and
          declare this array to be V(1,1) in the calling program).

  LDV     INTEGER
          The leading dimension of array V. If JOBV = 'U' or
          JOBV = 'I', LDV >= MAX(1,N); if JOBV = 'N', LDV >= 1.

  INUL    (input/output) LOGICAL array, dimension (MIN(M,N))
          On entry, the leading MIN(M,N) elements of this array must
          be set to .FALSE. unless the i-th columns of U (if JOBU =
          'U') and V (if JOBV = 'U') already contain a computed base
          vector of the desired singular subspace of the original
          matrix, in which case INUL(i) must be set to .TRUE.
          for 1 <= i <= MIN(M,N).
          On exit, the indices of the elements of this array with
          value .TRUE. indicate the indices of the diagonal entries
          of J which belong to those bidiagonal submatrices whose
          singular values are all less than or equal to THETA.
Tolerances 
  TOL     DOUBLE PRECISION
          This parameter defines the multiplicity of singular values
          by considering all singular values within an interval of
          length TOL as coinciding. TOL is used in checking how many
          singular values are less than or equal to THETA. Also in
          computing an appropriate upper bound THETA by a bisection
          method, TOL is used as a stopping criterion defining the
          minimum (absolute) subinterval width. TOL is also taken
          as an absolute tolerance for negligible elements in the
          QR/QL iterations. If the user sets TOL to be less than or
          equal to 0, then the tolerance is taken as
          EPS * MAX(ABS(Q(i)), ABS(E(k))), where EPS is the
          machine precision (see LAPACK Library routine DLAMCH),
          i = 1,2,...,MIN(M,N) and k = 1,2,...,MIN(M,N)-1.

  RELTOL  DOUBLE PRECISION
          This parameter specifies the minimum relative width of an
          interval. When an interval is narrower than TOL, or than
          RELTOL times the larger (in magnitude) endpoint, then it
          is considered to be sufficiently small and bisection has
          converged. If the user sets RELTOL to be less than
          BASE * EPS, where BASE is machine radix and EPS is machine
          precision (see LAPACK Library routine DLAMCH), then the
          tolerance is taken as BASE * EPS.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,6*MIN(M,N)-5), if JOBU = 'I' or 'U', or
                                            JOBV = 'I' or 'U';
          LDWORK >= MAX(1,4*MIN(M,N)-3), if JOBU = 'N' and
                                            JOBV = 'N'.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  if the rank of the bidiagonal matrix J (as specified
                by the user) has been lowered because a singular
                value of multiplicity larger than 1 was found.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value; this includes values like RANK > MIN(M,N), or
                THETA < 0.0 and RANK < 0;
          = 1:  if the maximum number of QR/QL iteration steps
                (30*MIN(M,N)) has been exceeded.
Method 
  If the upper bound THETA is not specified by the user, then it is
  computed by the routine (using a bisection method) such that
  precisely (MIN(M,N) - RANK) singular values of J are less than or
  equal to THETA + TOL.

  The method used by the routine (see [1]) then proceeds as follows.

  The unreduced bidiagonal submatrices of J(j), where J(j) is the
  transformed bidiagonal matrix after the j-th iteration step, are
  classified into the following three classes:

  - C1 contains the bidiagonal submatrices with all singular values
    > THETA,
  - C2 contains the bidiagonal submatrices with all singular values
    <= THETA and
  - C3 contains the bidiagonal submatrices with singular values
    > THETA and also singular values <= THETA.

  If C3 is empty, then the partial diagonalization is complete, and
  RANK is the sum of the dimensions of the bidiagonal submatrices of
  C1.
  Otherwise, QR or QL iterations are performed on each bidiagonal
  submatrix of C3, until this bidiagonal submatrix has been split
  into two bidiagonal submatrices. These two submatrices are then
  classified and the iterations are restarted.
  If the upper left diagonal element of the bidiagonal submatrix is
  larger than its lower right diagonal element, then QR iterations
  are performed, else QL iterations are used. The shift is taken as
  the smallest diagonal element of the bidiagonal submatrix (in
  magnitude) unless its value exceeds THETA, in which case it is
  taken as zero.
References 
  [1] Van Huffel, S., Vandewalle, J. and Haegemans, A.
      An efficient and reliable algorithm for computing the
      singular subspace of a matrix associated with its smallest
      singular values.
      J. Comput. and Appl. Math., 19, pp. 313-330, 1987.
Numerical Aspects 
  The algorithm is backward stable.

  To avoid overflow, matrix J is scaled so that its largest element
  is no greater than  overflow**(1/2) * underflow**(1/4) in absolute
  value (and not much smaller than that, for maximal accuracy).
Further Comments 
  None
Example

Program Text 

*     MB04YD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          MNMIN
      PARAMETER        ( MNMIN = MIN( MMAX, NMAX ) )
      INTEGER          LDU, LDV
      PARAMETER        ( LDU = MMAX, LDV = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 6*MNMIN - 5 )
*     .. Local Scalars ..
      DOUBLE PRECISION RELTOL, THETA, TOL
      INTEGER          I, INFO, IWARN, J, M, MINMN, N, RANK, RANK1
      CHARACTER*1      JOBU, JOBV
      LOGICAL          LJOBUU, LJOBVU
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), E(MNMIN-1), Q(MNMIN),
     $                 U(LDU,MNMIN), V(LDV,MNMIN)
      LOGICAL          INUL(MNMIN)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04YD
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, THETA, RANK, TOL, RELTOL, JOBU, JOBV
      MINMN = MIN( M, N )
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) N
      ELSE IF ( RANK.GT.MINMN ) THEN
         WRITE ( NOUT, FMT = 99986 ) RANK
      ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         WRITE ( NOUT, FMT = 99985 ) THETA
      ELSE
         READ ( NIN, FMT = * ) ( Q(I), I = 1,MINMN )
         READ ( NIN, FMT = * ) ( E(I), I = 1,MINMN-1 )
         RANK1 = RANK
         LJOBUU = LSAME( JOBU, 'U' )
         LJOBVU = LSAME( JOBV, 'U' )
         IF ( LJOBUU ) READ ( NIN, FMT = * )
     $                      ( ( U(I,J), J = 1,MINMN ), I = 1,M )
         IF ( LJOBVU ) READ ( NIN, FMT = * )
     $                      ( ( V(I,J), J = 1,MINMN ), I = 1,N )
*        Initialise the array INUL.
         DO 20 I = 1, MINMN
            INUL(I) = .FALSE.
   20    CONTINUE
         IF ( LJOBUU.OR.LJOBVU ) READ ( NIN, FMT = * )
     $                                ( INUL(I), I = 1,MINMN )
*        Compute the number of singular values of J > THETA.
         CALL MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V,
     $                LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99993 ) IWARN
               WRITE ( NOUT, FMT = 99984 ) RANK
            END IF
            WRITE ( NOUT, FMT = 99997 )
            DO 160 I = 1, MINMN - 1
               WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I)
  160       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) MINMN, MINMN, Q(MINMN)
            IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99994 ) RANK, THETA
            IF ( .NOT.LSAME( JOBV, 'N' ) ) THEN
               WRITE ( NOUT, FMT = 99992 )
               DO 180 I = 1, N
                  WRITE ( NOUT, FMT = 99991 ) ( V(I,J), J = 1,MINMN )
  180          CONTINUE
            END IF
            IF ( ( .NOT.LSAME( JOBU, 'N' ) ) .AND.
     $           ( .NOT.LSAME( JOBV, 'N' ) ) )
     $           WRITE ( NOUT, FMT = 99990 )
            IF ( .NOT.LSAME( JOBU, 'N' ) ) THEN
               WRITE ( NOUT, FMT = 99989 )
               DO 200 I = 1, M
                  WRITE ( NOUT, FMT = 99991 ) ( U(I,J), J = 1,MINMN )
  200          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04YD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04YD = ',I2)
99997 FORMAT (' The transformed bidiagonal matrix J is',/)
99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99995 FORMAT (' (',I1,',',I1,') = ',F7.4)
99994 FORMAT (/' J has ',I2,' singular values >',F7.4,/)
99993 FORMAT (' IWARN on exit from MB04YD = ',I2,/)
99992 FORMAT (' The product of the right-hand Givens rotation matrices',
     $       ' equals ')
99991 FORMAT (20(1X,F8.4))
99990 FORMAT (' ')
99989 FORMAT (' The product of the left-hand Givens rotation matrices ',
     $       'equals ')
99988 FORMAT (/' M is out of range.',/' M = ',I5)
99987 FORMAT (/' N is out of range.',/' N = ',I5)
99986 FORMAT (/' RANK is out of range.',/' RANK = ',I5)
99985 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4)
99984 FORMAT (/' The computed rank of matrix J = ',I3,/)
      END
Program Data 
 MB04YD EXAMPLE PROGRAM DATA
   5     5     2.0     -1     0.0     0.0     N     N
   1.0  2.0  3.0  4.0  5.0
   2.0  3.0  4.0  5.0
Program Results 
 MB04YD EXAMPLE PROGRAM RESULTS

 The transformed bidiagonal matrix J is

 (1,1) =  0.4045   (1,2) =  0.0000
 (2,2) =  1.9839   (2,3) =  0.0000
 (3,3) =  3.4815   (3,4) =  0.0128
 (4,4) =  5.3723   (4,5) =  0.0273
 (5,5) =  7.9948

 J has  3 singular values > 2.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB04YW.html000077500000000000000000000164041201767322700161330ustar00rootroot00000000000000 MB04YW - SLICOT Library Routine Documentation

MB04YW

Performing either one QR or QL iteration step onto an unreduced bidiagonal submatrix of a bidiagonal matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform either one QR or QL iteration step onto the unreduced
  bidiagonal submatrix Jk:

           |D(l) E(l)    0  ...    0   |
           | 0   D(l+1) E(l+1)     .   |
      Jk = | .                     .   |
           | .                     .   |
           | .                   E(k-1)|
           | 0   ...        ...   D(k) |

  with k <= p and l >= 1, p = MIN(M,N), of the bidiagonal matrix J:

           |D(1) E(1)  0    ...   0   |
           | 0   D(2) E(2)        .   |
       J = | .                    .   |.
           | .                    .   |
           | .                  E(p-1)|
           | 0   ...        ...  D(p) |

  Hereby, Jk is transformed to  S' Jk T with S and T products of
  Givens rotations. These Givens rotations S (respectively, T) are
  postmultiplied into U (respectively, V), if UPDATU (respectively,
  UPDATV) is .TRUE..
Specification 
      SUBROUTINE MB04YW( QRIT, UPDATU, UPDATV, M, N, L, K, SHIFT, D, E,
     $                   U, LDU, V, LDV, DWORK )
C     .. Scalar Arguments ..
      LOGICAL           QRIT, UPDATU, UPDATV
      INTEGER           K, L, LDU, LDV, M, N
      DOUBLE PRECISION  SHIFT
C     .. Array Arguments ..
      DOUBLE PRECISION  D( * ), DWORK( * ), E( * ), U( LDU, * ),
     $                  V( LDV, * )
Arguments

Mode Parameters 

  QRIT    LOGICAL
          Indicates whether a QR or QL iteration step is to be
          taken (from larger end diagonal element towards smaller),
          as follows:
          = .TRUE. :  QR iteration step (chase bulge from top to
                      bottom);
          = .FALSE.:  QL iteration step (chase bulge from bottom to
                      top).

  UPDATU  LOGICAL
          Indicates whether the user wishes to accumulate in a
          matrix U the left-hand Givens rotations S, as follows:
          = .FALSE.:  Do not form U;
          = .TRUE. :  The given matrix U is updated (postmultiplied)
                      by the left-hand Givens rotations S.

  UPDATV  LOGICAL
          Indicates whether the user wishes to accumulate in a
          matrix V the right-hand Givens rotations S, as follows:
          = .FALSE.:  Do not form V;
          = .TRUE. :  The given matrix V is updated (postmultiplied)
                      by the right-hand Givens rotations T.
Input/Output Parameters 
  M       (input) INTEGER
          The number of rows of the matrix U.  M >= 0.

  N       (input) INTEGER
          The number of rows of the matrix V.  N >= 0.

  L       (input) INTEGER
          The index of the first diagonal entry of the considered
          unreduced bidiagonal submatrix Jk of J.

  K       (input) INTEGER
          The index of the last diagonal entry of the considered
          unreduced bidiagonal submatrix Jk of J.

  SHIFT   (input) DOUBLE PRECISION
          Value of the shift used in the QR or QL iteration step.

  D       (input/output) DOUBLE PRECISION array, dimension (p)
          where p = MIN(M,N)
          On entry, D must contain the diagonal entries of the
          bidiagonal matrix J.
          On exit, D contains the diagonal entries of the
          transformed bidiagonal matrix S' J T.

  E       (input/output) DOUBLE PRECISION array, dimension (p-1)
          On entry, E must contain the superdiagonal entries of J.
          On exit, E contains the superdiagonal entries of the
          transformed matrix S' J T.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,p)
          On entry, if UPDATU = .TRUE., U must contain the M-by-p
          left transformation matrix.
          On exit, if UPDATU = .TRUE., the Givens rotations S on the
          left have been postmultiplied into U, i.e., U * S is
          returned.
          U is not referenced if UPDATU = .FALSE..

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= max(1,M) if UPDATU = .TRUE.;
          LDU >= 1        if UPDATU = .FALSE..

  V       (input/output) DOUBLE PRECISION array, dimension (LDV,p)
          On entry, if UPDATV = .TRUE., V must contain the N-by-p
          right transformation matrix.
          On exit, if UPDATV = .TRUE., the Givens rotations T on the
          right have been postmultiplied into V, i.e., V * T is
          returned.
          V is not referenced if UPDATV = .FALSE..

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= max(1,N) if UPDATV = .TRUE.;
          LDV >= 1        if UPDATV = .FALSE..
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (MAX(1,LDWORK))
          LDWORK >= 4*MIN(M,N)-4, if UPDATU = UPDATV = .TRUE.;
          LDWORK >= 2*MIN(M,N)-2, if
                          UPDATU = .TRUE. and UPDATV = .FALSE. or
                          UPDATV = .TRUE. and UPDATU = .FALSE.;
          LDWORK >= 1, if UPDATU = UPDATV = .FALSE..
Method 
  QR iterations diagonalize the bidiagonal matrix by zeroing the
  super-diagonal elements of Jk from bottom to top.
  QL iterations diagonalize the bidiagonal matrix by zeroing the
  super-diagonal elements of Jk from top to bottom.
  The routine overwrites Jk with the bidiagonal matrix S' Jk T,
  where S and T are products of Givens rotations.
  T is essentially the orthogonal matrix that would be obtained by
  applying one implicit symmetric shift QR (QL) step onto the matrix
  Jk'Jk. This step factors the matrix (Jk'Jk - shift*I) into a
  product of an orthogonal matrix T and a upper (lower) triangular
  matrix. See [1,Sec.8.2-8.3] and [2] for more details.
References 
  [1] Golub, G.H. and Van Loan, C.F.
      Matrix Computations.
      The Johns Hopkins University Press, Baltimore, Maryland, 1983.

  [2] Bowdler, H., Martin, R.S. and Wilkinson, J.H.
      The QR and QL algorithms for symmetric matrices.
      Numer. Math., 11, pp. 293-306, 1968.

  [3] Demmel, J. and Kahan, W.
      Computing small singular values of bidiagonal matrices with
      guaranteed high relative accuracy.
      SIAM J. Sci. Statist. Comput., 11, pp. 873-912, 1990.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB04ZD.html000077500000000000000000000327071201767322700161150ustar00rootroot00000000000000 MB04ZD - SLICOT Library Routine Documentation

MB04ZD

Transforming a Hamiltonian matrix into a square-reduced Hamiltonian matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To transform a Hamiltonian matrix

            ( A   G  )
        H = (      T )                                           (1)
            ( Q  -A  )

  into a square-reduced Hamiltonian matrix

             ( A'  G'  )
        H' = (       T )                                         (2)
             ( Q' -A'  )
                                                              T
  by an orthogonal symplectic similarity transformation H' = U H U,
  where
            (  U1   U2 )
        U = (          ).                                        (3)
            ( -U2   U1 )
                                                           T
  The square-reduced Hamiltonian matrix satisfies Q'A' - A' Q' = 0,
  and

        2       T     2     ( A''   G''  )
      H'  :=  (U  H U)   =  (          T ).
                            ( 0     A''  )

  In addition, A'' is upper Hessenberg and G'' is skew symmetric.
  The square roots of the eigenvalues of A'' = A'*A' + G'*Q' are the
  eigenvalues of H.
Specification 
      SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO
     $                 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDQG, LDU, N
      CHARACTER         COMPU
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), QG(LDQG,*), U(LDU,*)
Arguments

Mode Parameters 

  COMPU   CHARACTER*1
          Indicates whether the orthogonal symplectic similarity
          transformation matrix U in (3) is returned or
          accumulated into an orthogonal symplectic matrix, or if
          the transformation matrix is not required, as follows:
          = 'N':         U is not required;
          = 'I' or 'F':  on entry, U need not be set;
                         on exit, U contains the orthogonal
                         symplectic matrix U from (3);
          = 'V' or 'A':  the orthogonal symplectic similarity
                         transformations are accumulated into U;
                         on input, U must contain an orthogonal
                         symplectic matrix S;
                         on exit, U contains S*U with U from (3).
          See the description of U below for details.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, G, and Q.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On input, the leading N-by-N part of this array must
          contain the upper left block A of the Hamiltonian matrix H
          in (1).
          On output, the leading N-by-N part of this array contains
          the upper left block A' of the square-reduced Hamiltonian
          matrix H' in (2).

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  QG      (input/output) DOUBLE PRECISION array, dimension
          (LDQG,N+1)
          On input, the leading N-by-N lower triangular part of this
          array must contain the lower triangle of the lower left
          symmetric block Q of the Hamiltonian matrix H in (1), and
          the N-by-N upper triangular part of the submatrix in the
          columns 2 to N+1 of this array must contain the upper
          triangle of the upper right symmetric block G of H in (1).
          So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j)
          and G(i,j) = G(j,i) is stored in QG(j,i+1).
          On output, the leading N-by-N lower triangular part of
          this array contains the lower triangle of the lower left
          symmetric block Q', and the N-by-N upper triangular part
          of the submatrix in the columns 2 to N+1 of this array
          contains the upper triangle of the upper right symmetric
          block G' of the square-reduced Hamiltonian matrix H'
          in (2).

  LDQG    INTEGER
          The leading dimension of the array QG.  LDQG >= MAX(1,N).

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,2*N)
          If COMPU = 'N', then this array is not referenced.
          If COMPU = 'I' or 'F', then the input contents of this
          array are not specified.  On output, the leading
          N-by-(2*N) part of this array contains the first N rows
          of the orthogonal symplectic matrix U in (3).
          If COMPU = 'V' or 'A', then, on input, the leading
          N-by-(2*N) part of this array must contain the first N
          rows of an orthogonal symplectic matrix S. On output, the
          leading N-by-(2*N) part of this array contains the first N
          rows of the product S*U where U is the orthogonal
          symplectic matrix from (3).
          The storage scheme implied by (3) is used for orthogonal
          symplectic matrices, i.e., only the first N rows are
          stored, as they contain all relevant information.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= MAX(1,N), if COMPU <> 'N';
          LDU >= 1,        if COMPU =  'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, then the i-th argument had an illegal
                value.
Method 
  The Hamiltonian matrix H is transformed into a square-reduced
  Hamiltonian matrix H' using the implicit version of Van Loan's
  method as proposed in [1,2,3].
References 
  [1] Van Loan, C. F.
      A Symplectic Method for Approximating All the Eigenvalues of
      a Hamiltonian Matrix.
      Linear Algebra and its Applications, 61, pp. 233-251, 1984.

  [2] Byers, R.
      Hamiltonian and Symplectic Algorithms for the Algebraic
      Riccati Equation.
      Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983.

  [3] Benner, P., Byers, R., and Barth, E.
      Fortran 77 Subroutines for Computing the Eigenvalues of
      Hamiltonian Matrices. I: The Square-Reduced Method.
      ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000.
Numerical Aspects 
  This algorithm requires approximately 20*N**3 flops for
  transforming H into square-reduced form. If the transformations
  are required, this adds another 8*N**3 flops. The method is
  strongly backward stable in the sense that if H' and U are the
  computed square-reduced Hamiltonian and computed orthogonal
  symplectic similarity transformation, then there is an orthogonal
  symplectic matrix T and a Hamiltonian matrix M such that

               H T  =  T M

     || T - U ||   <=  c1 * eps

     || H' - M ||  <=  c2 * eps * || H ||

  where c1, c2 are modest constants depending on the dimension N and
  eps is the machine precision.

  Eigenvalues computed by explicitly forming the upper Hessenberg
  matrix  A'' = A'A' + G'Q', with A', G', and Q' as in (2), and
  applying the Hessenberg QR iteration to A'' are exactly
  eigenvalues of a perturbed Hamiltonian matrix H + E,  where

     || E ||  <=  c3 * sqrt(eps) * || H ||,

  and c3 is a modest constant depending on the dimension N and eps
  is the machine precision.  Moreover, if the norm of H and an
  eigenvalue lambda are of roughly the same magnitude, the computed
  eigenvalue is essentially as accurate as the computed eigenvalue
  from traditional methods.  See [1] or [2].
Further Comments 
  None
Example

Program Text 

*     MB04ZD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDQG, LDU
      PARAMETER        ( LDA = NMAX, LDQG = NMAX, LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = ( NMAX+NMAX )*( NMAX+NMAX+1 ) )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      INTEGER          I, INFO, IJ, J, JI, N, POS, WPOS
      CHARACTER*1      COMPU
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), QG(LDQG,NMAX+1),
     $                 U(LDU,NMAX)
*     .. External Subroutines ..
      EXTERNAL         DCOPY, DGEMM, DSYMV, MB04ZD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, COMPU
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99998 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J),    J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J),   I = J,N ), J = 1,N )
*        Square-reduce by symplectic orthogonal similarity.
         CALL MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99997 ) INFO
         ELSE
*           Show the square-reduced Hamiltonian.
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99994 )  ( A(I,J),    J = 1,N ),
     $            ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N )
10          CONTINUE
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99994 ) ( QG(I,J), J = 1,I-1 ),
     $               ( QG(J,I), J = I,N ), ( -A(J,I), J = 1,N )
20          CONTINUE
*           Show the square of H.
            WRITE ( NOUT, FMT = 99995 )
            WPOS = ( NMAX+NMAX )*( NMAX+NMAX )
*                                                    T
*           Compute N11 = A*A + G*Q and set N22 = N11 .
            CALL DGEMM( 'N', 'N', N, N, N, ONE, A, LDA, A, LDA, ZERO,
     $                  DWORK, N+N )
            DO 30 I = 1, N
               CALL DCOPY( N-I+1, QG(I,I), 1, DWORK(WPOS+I), 1 )
               CALL DCOPY( I-1, QG(I,1), LDQG, DWORK(WPOS+1), 1 )
               CALL DSYMV( 'U', N, ONE, QG(1,2), LDQG, DWORK(WPOS+1), 1,
     $                     ONE, DWORK((I-1)*(N+N)+1), 1 )
               POS = N*( N+N ) + N + I
               CALL DCOPY( N, DWORK((I-1)*(N+N)+1), 1, DWORK(POS), N+N )
30          CONTINUE
            DO 40 I = 1, N
               CALL DSYMV( 'U', N, -ONE, QG(1,2), LDQG, A(I,1), LDA,
     $                     ZERO, DWORK((N+I-1)*(N+N)+1), 1 )
               CALL DSYMV( 'L', N, ONE, QG, LDQG, A(1,I), 1, ZERO,
     $                     DWORK((I-1)*(N+N)+N+1), 1 )
40          CONTINUE
            DO 60 J = 1, N
               DO 50 I = J, N
                  IJ = ( N+J-1 )*( N+N ) + I
                  JI = ( N+I-1 )*( N+N ) + J
                  DWORK(IJ) =  DWORK(IJ) - DWORK(JI)
                  DWORK(JI) = -DWORK(IJ)
                  IJ = N + I + ( J-1 )*( N+N )
                  JI = N + J + ( I-1 )*( N+N )
                  DWORK(IJ) =  DWORK(IJ) - DWORK(JI)
                  DWORK(JI) = -DWORK(IJ)
50             CONTINUE
60          CONTINUE
            DO 70 I = 1, N+N
               WRITE ( NOUT, FMT = 99994 )
     $               ( DWORK(I+(J-1)*(N+N) ), J = 1,N+N )
70          CONTINUE
         ENDIF
      END IF
      STOP
*
99999 FORMAT (' MB04ZD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' N is out of range.',/' N = ',I5)
99997 FORMAT (' INFO on exit from MB04ZD = ',I2)
99996 FORMAT (/' The square-reduced Hamiltonian is ')
99995 FORMAT (/' The square of the square-reduced Hamiltonian is ')
99994 FORMAT (1X,8(F10.4))
      END
Program Data 
MB04ZD EXAMPLE PROGRAM DATA
3 N
1.0 2.0 3.0 
4.0 5.0 6.0
7.0 8.0 9.0
1.0 1.0 1.0 2.0 2.0 3.0
7.0 6.0 5.0 8.0 4.0 9.0
Program Results 
 MB04ZD EXAMPLE PROGRAM RESULTS


 The square-reduced Hamiltonian is 
     1.0000    3.3485    0.3436    1.0000    1.9126   -0.1072
     6.7566   11.0750   -0.3014    1.9126    8.4479   -1.0790
     2.3478    1.6899   -2.3868   -0.1072   -1.0790   -2.9871
     7.0000    8.6275   -0.6352   -1.0000   -6.7566   -2.3478
     8.6275   16.2238   -0.1403   -3.3485  -11.0750   -1.6899
    -0.6352   -0.1403    1.2371   -0.3436    0.3014    2.3868

 The square of the square-reduced Hamiltonian is 
    48.0000   80.6858   -2.5217    0.0000    1.8590  -10.5824
   167.8362  298.4815   -4.0310   -1.8590    0.0000  -33.1160
     0.0000    4.5325    2.5185   10.5824   33.1160    0.0000
     0.0000    0.0000    0.0000   48.0000  167.8362    0.0000
     0.0000    0.0000    0.0000   80.6858  298.4815    4.5325
     0.0000    0.0000    0.0000   -2.5217   -4.0310    2.5185

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB05MD.html000077500000000000000000000257711201767322700161040ustar00rootroot00000000000000 MB05MD - SLICOT Library Routine Documentation

MB05MD

Matrix exponential for a real non-defective matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute exp(A*delta) where A is a real N-by-N non-defective
  matrix with real or complex eigenvalues and delta is a scalar
  value. The routine also returns the eigenvalues and eigenvectors
  of A as well as (if all eigenvalues are real) the matrix product
  exp(Lambda*delta) times the inverse of the eigenvector matrix
  of A, where Lambda is the diagonal matrix of eigenvalues.
  Optionally, the routine computes a balancing transformation to
  improve the conditioning of the eigenvalues and eigenvectors.
Specification 
      SUBROUTINE MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR,
     $                   VALI, IWORK, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  BALANC  CHARACTER*1
          Indicates how the input matrix should be diagonally scaled
          to improve the conditioning of its eigenvalues as follows:
          = 'N':  Do not diagonally scale;
          = 'S':  Diagonally scale the matrix, i.e. replace A by
                  D*A*D**(-1), where D is a diagonal matrix chosen
                  to make the rows and columns of A more equal in
                  norm. Do not permute.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  DELTA   (input) DOUBLE PRECISION
          The scalar value delta of the problem.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A of the problem.
          On exit, the leading N-by-N part of this array contains
          the solution matrix exp(A*delta).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,N).

  V       (output) DOUBLE PRECISION array, dimension (LDV,N)
          The leading N-by-N part of this array contains the
          eigenvector matrix for A.
          If the k-th eigenvalue is real the k-th column of the
          eigenvector matrix holds the eigenvector corresponding
          to the k-th eigenvalue.
          Otherwise, the k-th and (k+1)-th eigenvalues form a
          complex conjugate pair and the k-th and (k+1)-th columns
          of the eigenvector matrix hold the real and imaginary
          parts of the eigenvectors corresponding to these
          eigenvalues as follows.
          If p and q denote the k-th and (k+1)-th columns of the
          eigenvector matrix, respectively, then the eigenvector
          corresponding to the complex eigenvalue with positive
          (negative) imaginary value is given by
                                    2
          p + q*j (p - q*j), where j  = -1.

  LDV     INTEGER
          The leading dimension of array V.  LDV >= max(1,N).

  Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
          The leading N-by-N part of this array contains an
          intermediate result for computing the matrix exponential.
          Specifically, exp(A*delta) is obtained as the product V*Y,
          where V is the matrix stored in the leading N-by-N part of
          the array V. If all eigenvalues of A are real, then the
          leading N-by-N part of this array contains the matrix
          product exp(Lambda*delta) times the inverse of the (right)
          eigenvector matrix of A, where Lambda is the diagonal
          matrix of eigenvalues.

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= max(1,N).

  VALR    (output) DOUBLE PRECISION array, dimension (N)
  VALI    (output) DOUBLE PRECISION array, dimension (N)
          These arrays contain the real and imaginary parts,
          respectively, of the eigenvalues of the matrix A. The
          eigenvalues are unordered except that complex conjugate
          pairs of values appear consecutively with the eigenvalue
          having positive imaginary part first.
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and if N > 0, DWORK(2) returns the reciprocal
          condition number of the triangular matrix used to obtain
          the inverse of the eigenvector matrix.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= max(1,4*N).
          For good performance, LDWORK must generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = i:  if INFO = i, the QR algorithm failed to compute all
                the eigenvalues; no eigenvectors have been computed;
                elements i+1:N of VALR and VALI contain eigenvalues
                which have converged;
          = N+1:  if the inverse of the eigenvector matrix could not
                be formed due to an attempt to divide by zero, i.e.,
                the eigenvector matrix is singular;
          = N+2:  if the matrix A is defective, possibly due to
                rounding errors.
Method 
  This routine is an implementation of "Method 15" of the set of
  methods described in reference [1], which uses an eigenvalue/
  eigenvector decomposition technique. A modification of LAPACK
  Library routine DGEEV is used for obtaining the right eigenvector
  matrix. A condition estimate is then employed to determine if the
  matrix A is near defective and hence the exponential solution is
  inaccurate. In this case the routine returns with the Error
  Indicator (INFO) set to N+2, and SLICOT Library routines MB05ND or
  MB05OD are the preferred alternative routines to be used.
References 
  [1] Moler, C.B. and Van Loan, C.F.
      Nineteen dubious ways to compute the exponential of a matrix.
      SIAM Review, 20, pp. 801-836, 1978.

  [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     MB05MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDV, LDY
      PARAMETER        ( LDA = NMAX, LDV = NMAX, LDY = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION DELTA
      INTEGER          I, INFO, J, N
      CHARACTER*1      BALANC
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), V(LDV,NMAX),
     $                 VALI(NMAX), VALR(NMAX), Y(LDY,NMAX)
      INTEGER          IWORK(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB05MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      BALANC = 'N'
      READ ( NIN, FMT = * ) N, DELTA
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Find the exponential of the real non-defective matrix A*DELTA.
         CALL MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR,
     $                VALI, IWORK, DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) ( VALR(I), VALI(I), I = 1,N )
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( V(I,J), J = 1,N )
   40       CONTINUE
            WRITE ( NOUT, FMT = 99993 )
            DO 60 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( Y(I,J), J = 1,N )
   60       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB05MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB05MD = ',I2)
99997 FORMAT (' The solution matrix exp(A*DELTA) is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The eigenvalues of A are ',/20(2F5.1,'*j  '))
99994 FORMAT (/' The eigenvector matrix for A is ')
99993 FORMAT (/' The inverse eigenvector matrix for A (premultiplied by'
     $        ,' exp(Lambda*DELTA)) is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB05MD EXAMPLE PROGRAM DATA
   4     1.0
   0.5   0.0   2.3  -2.6
   0.0   0.5  -1.4  -0.7
   2.3  -1.4   0.5   0.0
  -2.6  -0.7   0.0   0.5
Program Results 
 MB05MD EXAMPLE PROGRAM RESULTS

 The solution matrix exp(A*DELTA) is 
  26.8551  -3.2824  18.7409 -19.4430
  -3.2824   4.3474  -5.1848   0.2700
  18.7409  -5.1848  15.6012 -11.7228
 -19.4430   0.2700 -11.7228  15.6012

 The eigenvalues of A are 
 -3.0  0.0*j    4.0  0.0*j   -1.0  0.0*j    2.0  0.0*j  

 The eigenvector matrix for A is 
  -0.7000   0.7000   0.1000  -0.1000
   0.1000  -0.1000   0.7000  -0.7000
   0.5000   0.5000   0.5000   0.5000
  -0.5000  -0.5000   0.5000   0.5000

 The inverse eigenvector matrix for A (premultiplied by exp(Lambda*DELTA)) is 
  -0.0349   0.0050   0.0249  -0.0249
  38.2187  -5.4598  27.2991 -27.2991
   0.0368   0.2575   0.1839   0.1839
  -0.7389  -5.1723   3.6945   3.6945

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB05MY.html000077500000000000000000000133451201767322700161230ustar00rootroot00000000000000 MB05MY - SLICOT Library Routine Documentation

MB05MY

Computation of the orthogonal matrix reducing a given matrix to real Schur form T, of the eigenvalues, and of the upper triangular matrix of right eigenvectors of T

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, for an N-by-N real nonsymmetric matrix A, the
  orthogonal matrix Q reducing it to real Schur form T, the
  eigenvalues, and the right eigenvectors of T.

  The right eigenvector r(j) of T satisfies
                   T * r(j) = lambda(j) * r(j)
  where lambda(j) is its eigenvalue.

  The matrix of right eigenvectors R is upper triangular, by
  construction.
Specification 
      SUBROUTINE MB05MY( BALANC, N, A, LDA, WR, WI, R, LDR, Q, LDQ,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         BALANC
      INTEGER           INFO, LDA, LDQ, LDR, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA, * ), DWORK( * ), Q( LDQ, * ),
     $                  R( LDR, * ), WI( * ), WR( * )
Arguments

Mode Parameters 

  BALANC  CHARACTER*1
          Indicates how the input matrix should be diagonally scaled
          to improve the conditioning of its eigenvalues as follows:
          = 'N':  Do not diagonally scale;
          = 'S':  Diagonally scale the matrix, i.e. replace A by
                  D*A*D**(-1), where D is a diagonal matrix chosen
                  to make the rows and columns of A more equal in
                  norm. Do not permute.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the given matrix A.
          On exit, the leading N-by-N upper quasi-triangular part of
          this array contains the real Schur canonical form of A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,N).

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          WR and WI contain the real and imaginary parts,
          respectively, of the computed eigenvalues. Complex
          conjugate pairs of eigenvalues appear consecutively
          with the eigenvalue having the positive imaginary part
          first.

  R       (output) DOUBLE PRECISION array, dimension (LDR,N)
          The leading N-by-N upper triangular part of this array
          contains the matrix of right eigenvectors R, in the same
          order as their eigenvalues. The real and imaginary parts
          of a complex eigenvector corresponding to an eigenvalue
          with positive imaginary part are stored in consecutive
          columns. (The corresponding conjugate eigenvector is not
          stored.) The eigenvectors are not backward transformed
          for balancing (when BALANC = 'S').

  LDR     INTEGER
          The leading dimension of array R.  LDR >= max(1,N).

  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
          The leading N-by-N part of this array contains the
          orthogonal matrix Q which has reduced A to real Schur
          form.

  LDQ     INTEGER
          The leading dimension of array Q.  LDQ >= MAX(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
          If BALANC = 'S', DWORK(2),...,DWORK(N+1) return the
          scaling factors used for balancing.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= max(1,4*N).
          For good performance, LDWORK must generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, the QR algorithm failed to compute all
                the eigenvalues, and no eigenvectors have been
                computed; elements i+1:N of WR and WI contain
                eigenvalues which have converged.
Method 
  This routine uses the QR algorithm to obtain the real Schur form
  T of matrix A. Then, the right eigenvectors of T are computed,
  but they are not backtransformed into the eigenvectors of A.
  MB05MY is a modification of the LAPACK driver routine DGEEV.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB05ND.html000077500000000000000000000177061201767322700161040ustar00rootroot00000000000000 MB05ND - SLICOT Library Routine Documentation

MB05ND

Matrix exponential and integral for a real matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute

  (a)    F(delta) =  exp(A*delta) and

  (b)    H(delta) =  Int[F(s) ds] from s = 0 to s = delta,

  where A is a real N-by-N matrix and delta is a scalar value.
Specification 
      SUBROUTINE MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  DELTA   (input) DOUBLE PRECISION
          The scalar value delta of the problem.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          matrix A of the problem. (Array A need not be set if
          DELTA = 0.)

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,N).

  EX      (output) DOUBLE PRECISION array, dimension (LDEX,N)
          The leading N-by-N part of this array contains an
          approximation to F(delta).

  LDEX    INTEGER
          The leading dimension of array EX.  LDEX >= MAX(1,N).

  EXINT   (output) DOUBLE PRECISION array, dimension (LDEXIN,N)
          The leading N-by-N part of this array contains an
          approximation to H(delta).

  LDEXIN  INTEGER
          The leading dimension of array EXINT.  LDEXIN >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the order of the
          Pade approximation to H(t), where t is a scale factor
          determined by the routine. A reasonable value for TOL may
          be SQRT(EPS), where EPS is the machine precision (see
          LAPACK Library routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK. LDWORK >= MAX(1,N*(N+1)).
          For optimum performance LDWORK should be larger (2*N*N).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, the (i,i) element of the denominator of
                the Pade approximation is zero, so the denominator
                is exactly singular;
          = N+1:  if DELTA = (delta * frobenius norm of matrix A) is
                probably too large to permit meaningful computation.
                That is, DELTA > SQRT(BIG), where BIG is a
                representable number near the overflow threshold of
                the machine (see LAPACK Library Routine DLAMCH).
Method 
  This routine uses a Pade approximation to H(t) for some small
  value of t (where 0 < t <= delta) and then calculates F(t) from
  H(t). Finally, the results are re-scaled to give F(delta) and
  H(delta). For a detailed description of the implementation of this
  algorithm see [1].
References 
  [1] Benson, C.J.
      The numerical evaluation of the matrix exponential and its
      integral.
      Report 82/03, Control Systems Research Group,
      School of Electronic Engineering and Computer
      Science, Kingston Polytechnic, January 1982.

  [2] Ward, R.C.
      Numerical computation of the matrix exponential with accuracy
      estimate.
      SIAM J. Numer. Anal., 14, pp. 600-610, 1977.

  [3] Moler, C.B. and Van Loan, C.F.
      Nineteen Dubious Ways to Compute the Exponential of a Matrix.
      SIAM Rev., 20, pp. 801-836, 1978.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     MB05ND EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDEX, LDEXIN, LDWORK
      PARAMETER        ( LDA = NMAX, LDEX = NMAX, LDEXIN = NMAX,
     $                   LDWORK = NMAX*( NMAX+1 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION DELTA, TOL
      INTEGER          I, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), EX(LDEX,NMAX),
     $                 EXINT(LDEXIN,NMAX)
      INTEGER          IWORK(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB05ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DELTA, TOL
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Find the matrix exponential of A*DELTA and its integral.
         CALL MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, TOL,
     $                IWORK, DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( EX(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 40 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( EXINT(I,J), J = 1,N )
   40       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB05ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB05ND = ',I2)
99997 FORMAT (' The solution matrix exp(A*DELTA) is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' and its integral is ')
99994 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 MB05ND EXAMPLE PROGRAM DATA
   5     0.1     0.0001
   5.0   4.0   3.0   2.0   1.0
   1.0   6.0   0.0   4.0   3.0
   2.0   0.0   7.0   6.0   5.0
   1.0   3.0   1.0   8.0   7.0
   2.0   5.0   7.0   1.0   9.0
Program Results 
 MB05ND EXAMPLE PROGRAM RESULTS

 The solution matrix exp(A*DELTA) is 
   1.8391   0.9476   0.7920   0.8216   0.7811
   0.3359   2.2262   0.4013   1.0078   1.0957
   0.6335   0.6776   2.6933   1.6155   1.8502
   0.4804   1.1561   0.9110   2.7461   2.0854
   0.7105   1.4244   1.8835   1.0966   3.4134

 and its integral is 
   0.1347   0.0352   0.0284   0.0272   0.0231
   0.0114   0.1477   0.0104   0.0369   0.0368
   0.0218   0.0178   0.1624   0.0580   0.0619
   0.0152   0.0385   0.0267   0.1660   0.0732
   0.0240   0.0503   0.0679   0.0317   0.1863

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB05OD.html000077500000000000000000000202401201767322700160700ustar00rootroot00000000000000 MB05OD - SLICOT Library Routine Documentation

MB05OD

Matrix exponential for a real matrix, with accuracy estimate

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute exp(A*delta) where A is a real N-by-N matrix and delta
  is a scalar value. The routine also returns the minimal number of
  accurate digits in the 1-norm of exp(A*delta) and the number of
  accurate digits in the 1-norm of exp(A*delta) at 95% confidence
  level.
Specification 
      SUBROUTINE MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG,
     $                   IWORK, DWORK, LDWORK, IWARN, INFO )
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(*)
Arguments

Mode Parameters 

  BALANC  CHARACTER*1
          Specifies whether or not a balancing transformation (done
          by SLICOT Library routine MB04MD) is required, as follows:
          = 'N', do not use balancing;
          = 'S', use balancing (scaling).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  NDIAG   (input) INTEGER
          The specified order of the diagonal Pade approximant.
          In the absence of further information NDIAG should
          be set to 9.  NDIAG should not exceed 15.  NDIAG >= 1.

  DELTA   (input) DOUBLE PRECISION
          The scalar value delta of the problem.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On input, the leading N-by-N part of this array must
          contain the matrix A of the problem. (This is not needed
          if DELTA = 0.)
          On exit, if INFO = 0, the leading N-by-N part of this
          array contains the solution matrix exp(A*delta).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  MDIG    (output) INTEGER
          The minimal number of accurate digits in the 1-norm of
          exp(A*delta).

  IDIG    (output) INTEGER
          The number of accurate digits in the 1-norm of
          exp(A*delta) at 95% confidence level.
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= N*(2*N+NDIAG+1)+NDIAG, if N >  1.
          LDWORK >= 1,                     if N <= 1.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  if MDIG = 0 and IDIG > 0, warning for possible
                inaccuracy (the exponential has been computed);
          = 2:  if MDIG = 0 and IDIG = 0, warning for severe
                inaccuracy (the exponential has been computed);
          = 3:  if balancing has been requested, but it failed to
                reduce the matrix norm and was not actually used.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the norm of matrix A*delta (after a possible
                balancing) is too large to obtain an accurate
                result;
          = 2:  if the coefficient matrix (the denominator of the
                Pade approximant) is exactly singular; try a
                different value of NDIAG;
          = 3:  if the solution exponential would overflow, possibly
                due to a too large value DELTA; the calculations
                stopped prematurely. This error is not likely to
                appear.
Method 
  The exponential of the matrix A is evaluated from a diagonal Pade
  approximant. This routine is a modification of the subroutine
  PADE, described in reference [1]. The routine implements an
  algorithm which exploits the identity

      (exp[(2**-m)*A]) ** (2**m) = exp(A),

  where m is an integer determined by the algorithm, to improve the
  accuracy for matrices with large norms.
References 
  [1] Ward, R.C.
      Numerical computation of the matrix exponential with accuracy
      estimate.
      SIAM J. Numer. Anal., 14, pp. 600-610, 1977.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     MB05OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
      INTEGER          NDIAG
      PARAMETER        ( NDIAG = 9 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( 2*NMAX+NDIAG+1 )+NDIAG )
*     .. Local Scalars ..
      DOUBLE PRECISION DELTA
      INTEGER          I, IDIG, INFO, IWARN, J, MDIG, N
      CHARACTER*1      BALANC
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK)
      INTEGER          IWORK(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB05OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DELTA, BALANC
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Find the exponential of the real defective matrix A*DELTA.
         CALL MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG,
     $                IWORK, DWORK, LDWORK, IWARN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 )
     $         WRITE ( NOUT, FMT = 99993 ) IWARN
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) MDIG, IDIG
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB05OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB05OD = ',I2)
99997 FORMAT (' The solution matrix E = exp(A*DELTA) is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' Minimal number of accurate digits in the norm of E =',
     $       I4,/' Number of accurate digits in the norm of E',/'     ',
     $       '            at 95 per cent confidence interval =',I4)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (' IWARN on exit from MB05OD = ',I2)
      END
Program Data 
 MB05OD EXAMPLE PROGRAM DATA
   3     1.0     S
   2.0   1.0   1.0
   0.0   3.0   2.0
   1.0   0.0   4.0
Program Results 
 MB05OD EXAMPLE PROGRAM RESULTS

 The solution matrix E = exp(A*DELTA) is 
  22.5984  17.2073  53.8144
  24.4047  27.6033  83.2241
  29.4097  12.2024  81.4177

 Minimal number of accurate digits in the norm of E =  12
 Number of accurate digits in the norm of E
                 at 95 per cent confidence interval =  15

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MB05OY.html000077500000000000000000000067411201767322700161270ustar00rootroot00000000000000 MB05OY - SLICOT Library Routine Documentation

MB05OY

Restoring a matrix after balancing transformations (permutations and scalings)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To restore a matrix after it has been transformed by applying
  balancing transformations (permutations and scalings), as
  determined by LAPACK Library routine DGEBAL.
Specification 
      SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           IGH, INFO, LDA, LOW, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), SCALE(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the type of backward transformation required,
          as follows:
          = 'N', do nothing, return immediately;
          = 'P', do backward transformation for permutation only;
          = 'S', do backward transformation for scaling only;
          = 'B', do backward transformations for both permutation
                 and scaling.
          JOB must be the same as the argument JOB supplied
          to DGEBAL.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  LOW     (input) INTEGER
  IGH     (input) INTEGER
          The integers LOW and IGH determined by DGEBAL.
          1 <= LOW <= IGH <= N, if N > 0; LOW=1 and IGH=0, if N=0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix to be back-transformed.
          On exit, the leading N-by-N part of this array contains
          the transformed matrix.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  SCALE   (input) DOUBLE PRECISION array, dimension (N)
          Details of the permutation and scaling factors, as
          returned by DGEBAL.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Let P be a permutation matrix, and D a diagonal matrix of scaling
  factors, both of order N. The routine computes
                  -1
     A <-- P D A D  P'.

  where the permutation and scaling factors are encoded in the
  array SCALE.
References 
  None.
Numerical Aspects 
                            2
  The algorithm requires O(N ) operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB3OYZ.html000077500000000000000000000165441201767322700162010ustar00rootroot00000000000000 MB3OYZ - SLICOT Library Routine Documentation

MB3OYZ

Matrix rank determination by incremental condition estimation, during the pivoted QR factorization process (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a rank-revealing QR factorization of a complex general
  M-by-N matrix  A,  which may be rank-deficient, and estimate its
  effective rank using incremental condition estimation.

  The routine uses a truncated QR factorization with column pivoting
                                [ R11 R12 ]
     A * P = Q * R,  where  R = [         ],
                                [  0  R22 ]
  with R11 defined as the largest leading upper triangular submatrix
  whose estimated condition number is less than 1/RCOND.  The order
  of R11, RANK, is the effective rank of A.  Condition estimation is
  performed during the QR factorization process.  Matrix R22 is full
  (but of small norm), or empty.

  MB3OYZ  does not perform any scaling of the matrix A.
Specification 
      SUBROUTINE MB3OYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                   TAU, DWORK, ZWORK, INFO )
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 )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) COMPLEX*16 array, dimension ( LDA, N )
          On entry, the leading M-by-N part of this array must
          contain the given matrix A.
          On exit, the leading RANK-by-RANK upper triangular part
          of A contains the triangular factor R11, and the elements
          below the diagonal in the first  RANK  columns, with the
          array TAU, represent the unitary matrix Q as a product
          of  RANK  elementary reflectors.
          The remaining  N-RANK  columns contain the result of the
          QR factorization process used.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of A, which
          is defined as the order of the largest leading triangular
          submatrix R11 in the QR factorization with pivoting of A,
          whose estimated condition number is less than 1/RCOND.
          0 <= RCOND <= 1.
          NOTE that when SVLMAX > 0, the estimated rank could be
          less than that defined above (see SVLMAX).

  SVLMAX  (input) DOUBLE PRECISION
          If A is a submatrix of another matrix B, and the rank
          decision should be related to that matrix, then SVLMAX
          should be an estimate of the largest singular value of B
          (for instance, the Frobenius norm of B).  If this is not
          the case, the input value SVLMAX = 0 should work.
          SVLMAX >= 0.

  RANK    (output) INTEGER
          The effective (estimated) rank of A, i.e., the order of
          the submatrix R11.

  SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
          The estimates of some of the singular values of the
          triangular factor R:
          SVAL(1): largest singular value of R(1:RANK,1:RANK);
          SVAL(2): smallest singular value of R(1:RANK,1:RANK);
          SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
                   if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
                   otherwise.
          If the triangular factorization is a rank-revealing one
          (which will be the case if the leading columns were well-
          conditioned), then SVAL(1) will also be an estimate for
          the largest singular value of A, and SVAL(2) and SVAL(3)
          will be estimates for the RANK-th and (RANK+1)-st singular
          values of A, respectively.
          By examining these values, one can confirm that the rank
          is well defined with respect to the chosen value of RCOND.
          The ratio SVAL(1)/SVAL(2) is an estimate of the condition
          number of R(1:RANK,1:RANK).

  JPVT    (output) INTEGER array, dimension ( N )
          If JPVT(i) = k, then the i-th column of A*P was the k-th
          column of A.

  TAU     (output) COMPLEX*16 array, dimension ( MIN( M, N ) )
          The leading  RANK  elements of TAU contain the scalar
          factors of the elementary reflectors.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension ( 2*N )

  ZWORK   COMPLEX*16 array, dimension ( 3*N-1 )
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a truncated QR factorization with column
  pivoting of A,  A * P = Q * R,  with  R  defined above, and,
  during this process, finds the largest leading submatrix whose
  estimated condition number is less than 1/RCOND, taking the
  possible positive value of SVLMAX into account.  This is performed
  using the LAPACK incremental condition estimation scheme and a
  slightly modified rank decision test.  The factorization process
  stops when  RANK  has been determined.

  The matrix Q is represented as a product of elementary reflectors

     Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n).

  Each H(i) has the form

     H = I - tau * v * v'

  where tau is a complex scalar, and v is a complex vector with
  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
  A(i+1:m,i), and tau in TAU(i).

  The matrix P is represented in jpvt as follows: If
     jpvt(j) = i
  then the jth column of P is the ith canonical unit vector.
References 
  [1] Bischof, C.H. and P. Tang.
      Generalizing Incremental Condition Estimation.
      LAPACK Working Notes 32, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-132,
      May 1991.

  [2] Bischof, C.H. and P. Tang.
      Robust Incremental Condition Estimation.
      LAPACK Working Notes 33, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-133,
      May 1991.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MB3PYZ.html000077500000000000000000000167551201767322700162060ustar00rootroot00000000000000 MB3PYZ - SLICOT Library Routine Documentation

MB3PYZ

Matrix rank determination by incremental condition estimation, during the pivoted RQ factorization process (row pivoting, complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a rank-revealing RQ factorization of a complex general
  M-by-N matrix  A,  which may be rank-deficient, and estimate its
  effective rank using incremental condition estimation.

  The routine uses a truncated RQ factorization with row pivoting:
                                [ R11 R12 ]
     P * A = R * Q,  where  R = [         ],
                                [  0  R22 ]
  with R22 defined as the largest trailing upper triangular
  submatrix whose estimated condition number is less than 1/RCOND.
  The order of R22, RANK, is the effective rank of A.  Condition
  estimation is performed during the RQ factorization process.
  Matrix R11 is full (but of small norm), or empty.

  MB3PYZ  does not perform any scaling of the matrix A.
Specification 
      SUBROUTINE MB3PYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                   TAU, DWORK, ZWORK, INFO )
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 )
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  A       (input/output) COMPLEX*16 array, dimension ( LDA, N )
          On entry, the leading M-by-N part of this array must
          contain the given matrix A.
          On exit, the upper triangle of the subarray
          A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper
          triangular matrix R22;  the remaining elements in the last
          RANK  rows, with the array TAU, represent the unitary
          matrix Q as a product of  RANK  elementary reflectors
          (see METHOD).  The first  M-RANK  rows contain the result
          of the RQ factorization process used.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,M).

  RCOND   (input) DOUBLE PRECISION
          RCOND is used to determine the effective rank of A, which
          is defined as the order of the largest trailing triangular
          submatrix R22 in the RQ factorization with pivoting of A,
          whose estimated condition number is less than 1/RCOND.
          0 <= RCOND <= 1.
          NOTE that when SVLMAX > 0, the estimated rank could be
          less than that defined above (see SVLMAX).

  SVLMAX  (input) DOUBLE PRECISION
          If A is a submatrix of another matrix B, and the rank
          decision should be related to that matrix, then SVLMAX
          should be an estimate of the largest singular value of B
          (for instance, the Frobenius norm of B).  If this is not
          the case, the input value SVLMAX = 0 should work.
          SVLMAX >= 0.

  RANK    (output) INTEGER
          The effective (estimated) rank of A, i.e., the order of
          the submatrix R22.

  SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
          The estimates of some of the singular values of the
          triangular factor R:
          SVAL(1): largest singular value of
                   R(M-RANK+1:M,N-RANK+1:N);
          SVAL(2): smallest singular value of
                   R(M-RANK+1:M,N-RANK+1:N);
          SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N),
                   if RANK < MIN( M, N ), or of
                   R(M-RANK+1:M,N-RANK+1:N), otherwise.
          If the triangular factorization is a rank-revealing one
          (which will be the case if the trailing rows were well-
          conditioned), then SVAL(1) will also be an estimate for
          the largest singular value of A, and SVAL(2) and SVAL(3)
          will be estimates for the RANK-th and (RANK+1)-st singular
          values of A, respectively.
          By examining these values, one can confirm that the rank
          is well defined with respect to the chosen value of RCOND.
          The ratio SVAL(1)/SVAL(2) is an estimate of the condition
          number of R(M-RANK+1:M,N-RANK+1:N).

  JPVT    (output) INTEGER array, dimension ( M )
          If JPVT(i) = k, then the i-th row of P*A was the k-th row
          of A.

  TAU     (output) COMPLEX*16 array, dimension ( MIN( M, N ) )
          The trailing  RANK  elements of TAU contain the scalar
          factors of the elementary reflectors.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension ( 2*M )

  ZWORK   COMPLEX*16 array, dimension ( 3*M-1 )
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a truncated RQ factorization with row
  pivoting of A,  P * A = R * Q,  with  R  defined above, and,
  during this process, finds the largest trailing submatrix whose
  estimated condition number is less than 1/RCOND, taking the
  possible positive value of SVLMAX into account.  This is performed
  using an adaptation of the LAPACK incremental condition estimation
  scheme and a slightly modified rank decision test.  The
  factorization process stops when  RANK  has been determined.

  The matrix Q is represented as a product of elementary reflectors

     Q = H(k-rank+1)' H(k-rank+2)' . . . H(k)', where k = min(m,n).

  Each H(i) has the form

     H = I - tau * v * v'

  where tau is a complex scalar, and v is a complex vector with
  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored
  on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).

  The matrix P is represented in jpvt as follows: If
     jpvt(j) = i
  then the jth row of P is the ith canonical unit vector.
References 
  [1] Bischof, C.H. and P. Tang.
      Generalizing Incremental Condition Estimation.
      LAPACK Working Notes 32, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-132,
      May 1991.

  [2] Bischof, C.H. and P. Tang.
      Robust Incremental Condition Estimation.
      LAPACK Working Notes 33, Mathematics and Computer Science
      Division, Argonne National Laboratory, UT, CS-91-133,
      May 1991.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MC01MD.html000077500000000000000000000137731201767322700161000ustar00rootroot00000000000000 MC01MD - SLICOT Library Routine Documentation

MC01MD

The leading coefficients of the shifted polynomial for a given real polynomial

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate, for a given real polynomial P(x) and a real scalar
  alpha, the leading K coefficients of the shifted polynomial
                                                            K-1
     P(x) = q(1) + q(2) * (x-alpha) + ... + q(K) * (x-alpha)   + ...

  using Horner's algorithm.
Specification 
      SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, K
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  P(*), Q(*)
Arguments

Input/Output Parameters 

  DP      (input) INTEGER
          The degree of the polynomial P(x).  DP >= 0.

  ALPHA   (input) DOUBLE PRECISION
          The scalar value alpha of the problem.

  K       (input) INTEGER
          The number of coefficients of the shifted polynomial to be
          computed.  1 <= K <= DP+1.

  P       (input) DOUBLE PRECISION array, dimension (DP+1)
          This array must contain the coefficients of P(x) in
          increasing powers of x.

  Q       (output) DOUBLE PRECISION array, dimension (DP+1)
          The leading K elements of this array contain the first
          K coefficients of the shifted polynomial in increasing
          powers of (x - alpha), and the next (DP-K+1) elements
          are used as internal workspace.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given the real polynomial
                                      2                    DP
     P(x) = p(1) + p(2) * x + p(3) * x  + ... + p(DP+1) * x  ,

  the routine computes the leading K coefficients of the shifted
  polynomial
                                                                K-1
     P(x) = q(1) + q(2) * (x - alpha) + ... + q(K) * (x - alpha)

  as follows.

  Applying Horner's algorithm (see [1]) to P(x), i.e. dividing P(x)
  by (x-alpha), yields

     P(x) = q(1) + (x-alpha) * D(x),

  where q(1) is the value of the constant term of the shifted
  polynomial and D(x) is the quotient polynomial of degree (DP-1)
  given by
                                      2                     DP-1
     D(x) = d(2) + d(3) * x + d(4) * x  + ... +  d(DP+1) * x    .

  Applying Horner's algorithm to D(x) and subsequent quotient
  polynomials yields q(2) and q(3), q(4), ..., q(K) respectively.

  It follows immediately that q(1) = P(alpha), and in general
             (i-1)
     q(i) = P     (alpha) / (i - 1)! for i = 1, 2, ..., K.
References 
  [1] STOER, J. and BULIRSCH, R.
      Introduction to Numerical Analysis.
      Springer-Verlag. 1980.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MC01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA
      INTEGER          DP, I, INFO, K
*     .. Local Arrays ..
      DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01MD
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP, ALPHA, K
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Compute the leading K coefficients of the shifted polynomial.
         CALL MC01MD( DP, ALPHA, K, P, Q, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) ALPHA
            DO 20 I = 1, K
               WRITE ( NOUT, FMT = 99996 ) I - 1, Q(I)
   20       CONTINUE
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01MD = ',I2)
99997 FORMAT (' ALPHA = ',F8.4,//' The coefficients of the shifted pol',
     $       'ynomial are ',//' power of (x-ALPHA)     coefficient ')
99996 FORMAT (5X,I5,15X,F9.4)
99995 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END
Program Data 
 MC01MD EXAMPLE PROGRAM DATA
   5     2.0     6
   6.0  5.0  4.0  3.0  2.0  1.0
Program Results 
 MC01MD EXAMPLE PROGRAM RESULTS

 ALPHA =   2.0000

 The coefficients of the shifted polynomial are 

 power of (x-ALPHA)     coefficient 
         0                120.0000
         1                201.0000
         2                150.0000
         3                 59.0000
         4                 12.0000
         5                  1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01ND.html000077500000000000000000000112641201767322700160720ustar00rootroot00000000000000 MC01ND - SLICOT Library Routine Documentation

MC01ND

Value of a real polynomial at a given complex point

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the value of the real polynomial P(x) at a given
  complex point x = x0 using Horner's algorithm.
Specification 
      SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO
      DOUBLE PRECISION  VI, VR, XI, XR
C     .. Array Arguments ..
      DOUBLE PRECISION  P(*)
Arguments

Input/Output Parameters 

  DP      (input) INTEGER
          The degree of the polynomial P(x).  DP >= 0.

  XR      (input) DOUBLE PRECISION
  XI      (input) DOUBLE PRECISION
          The real and imaginary parts, respectively, of x0.

  P       (input) DOUBLE PRECISION array, dimension (DP+1)
          This array must contain the coefficients of the polynomial
          P(x) in increasing powers of x.

  VR      (output) DOUBLE PRECISION
  VI      (output) DOUBLE PRECISION
          The real and imaginary parts, respectively, of P(x0).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given the real polynomial
                                      2                   DP
     P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x  ,

  the routine computes the value of P(x0) using the recursion

     q(DP+1) = p(DP+1),
     q(i) = x0*q(i+1) + p(i) for i = DP, DP-1, ..., 1,

  which is known as Horner's algorithm (see [1]). Then q(1) = P(x0).
References 
  [1] STOER, J and BULIRSCH, R.
      Introduction to Numerical Analysis.
      Springer-Verlag. 1980.
Numerical Aspects 
  The algorithm requires DP operations for real arguments and 4*DP
  for complex arguments.
Further Comments 
  None
Example

Program Text 

*     MC01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION VI, VR, XI, XR
      INTEGER          DP, I, INFO
*     .. Local Arrays ..
      DOUBLE PRECISION P(DPMAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP, XR, XI
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Evaluate the polynomial at the given (complex) point.
         CALL MC01ND( DP, XR, XI, P, VR, VI, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) XR, XI, VR
            WRITE ( NOUT, FMT = 99996 ) XR, XI, VI
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01ND = ',I2)
99997 FORMAT (' Real      part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4)
99996 FORMAT (/' Imaginary part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4)
99995 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END
Program Data 
 MC01ND EXAMPLE PROGRAM DATA
   4     -1.56     0.29
   5.0  3.0  -1.0  2.0  1.0
Program Results 
 MC01ND EXAMPLE PROGRAM RESULTS

 Real      part of P( -1.56 +0.29*j ) =  -4.1337

 Imaginary part of P( -1.56 +0.29*j ) =   1.7088

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01OD.html000077500000000000000000000116411201767322700160720ustar00rootroot00000000000000 MC01OD - SLICOT Library Routine Documentation

MC01OD

Coefficients of a complex polynomial, given its zeros

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the coefficients of a complex polynomial P(x) from its
  zeros.
Specification 
      SUBROUTINE MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, K
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), IMP(*), IMZ(*), REP(*), REZ(*)
Arguments

Input/Output Parameters 

  K       (input) INTEGER
          The number of zeros (and hence the degree) of P(x).
          K >= 0.

  REZ     (input) DOUBLE PRECISION array, dimension (K)
  IMZ     (input) DOUBLE PRECISION array, dimension (K)
          The real and imaginary parts of the i-th zero of P(x)
          must be stored in REZ(i) and IMZ(i), respectively, where
          i = 1, 2, ..., K. The zeros may be supplied in any order.

  REP     (output) DOUBLE PRECISION array, dimension (K+1)
  IMP     (output) DOUBLE PRECISION array, dimension (K+1)
          These arrays contain the real and imaginary parts,
          respectively, of the coefficients of P(x) in increasing
          powers of x. If K = 0, then REP(1) is set to one and
          IMP(1) is set to zero.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (2*K+2)
          If K = 0, this array is not referenced.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes the coefficients of the complex K-th degree
  polynomial P(x) as

     P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K))

  where r(i) = (REZ(i),IMZ(i)), using real arithmetic.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MC01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX
      PARAMETER        ( KMAX = 10 )
*     .. Local Scalars ..
      INTEGER          I, INFO, K
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(2*KMAX+2), IMP(KMAX+1), IMZ(KMAX),
     $                 REP(KMAX+1), REZ(KMAX)
*     .. External Subroutines ..
      EXTERNAL         MC01OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K
      IF ( K.LT.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) K
      ELSE
         READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K )
*        Compute the coefficients of P(x) from the given zeros.
         CALL MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99996 )
     $            ( I, REP(I+1), IMP(I+1), I = 0,K )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MC01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01OD = ',I2)
99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe',
     $       'r of x     real part     imag part ')
99996 FORMAT (2X,I5,8X,F9.4,5X,F9.4)
99995 FORMAT (/' K is out of range.',/' K = ',I5)
      END
Program Data 
 MC01OD EXAMPLE PROGRAM DATA
   5
   1.1   0.9
   0.6  -0.7
  -2.0   0.3
  -0.8   2.5
  -0.3  -0.4
Program Results 
 MC01OD EXAMPLE PROGRAM RESULTS

 The coefficients of the polynomial P(x) are 

 power of x     real part     imag part 
      0           2.7494       -2.1300
      1          -1.7590       -5.4205
      2           0.0290        2.8290
      3          -1.6500       -1.7300
      4           1.4000       -2.6000
      5           1.0000        0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01PD.html000077500000000000000000000116121201767322700160710ustar00rootroot00000000000000 MC01PD - SLICOT Library Routine Documentation

MC01PD

Coefficients of a real polynomial, given its zeros

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the coefficients of a real polynomial P(x) from its
  zeros.
Specification 
      SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, K
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), IMZ(*), P(*), REZ(*)
Arguments

Input/Output Parameters 

  K       (input) INTEGER
          The number of zeros (and hence the degree) of P(x).
          K >= 0.

  REZ     (input) DOUBLE PRECISION array, dimension (K)
  IMZ     (input) DOUBLE PRECISION array, dimension (K)
          The real and imaginary parts of the i-th zero of P(x)
          must be stored in REZ(i) and IMZ(i), respectively, where
          i = 1, 2, ..., K. The zeros may be supplied in any order,
          except that complex conjugate zeros must appear
          consecutively.

  P       (output) DOUBLE PRECISION array, dimension (K+1)
          This array contains the coefficients of P(x) in increasing
          powers of x. If K = 0, then P(1) is set to one.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (K+1)
          If K = 0, this array is not referenced.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, (REZ(i),IMZ(i)) is a complex zero but
                (REZ(i-1),IMZ(i-1)) is not its conjugate.
Method 
  The routine computes the coefficients of the real K-th degree
  polynomial P(x) as

     P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K))

  where r(i) = (REZ(i),IMZ(i)).

  Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j)
  form a complex conjugate pair (where i <> j), and that IMZ(i) = 0
  if r(i) is real.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MC01PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX
      PARAMETER        ( KMAX = 10 )
*     .. Local Scalars ..
      INTEGER          I, INFO, K
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(KMAX+1), IMZ(KMAX), P(KMAX+1), REZ(KMAX)
*     .. External Subroutines ..
      EXTERNAL         MC01PD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K
      IF ( K.LT.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) K
      ELSE
         READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K )
*        Compute the coefficients of P(x) from the given zeros.
         CALL MC01PD( K, REZ, IMZ, P, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99996 ) ( I, P(I+1), I = 0,K )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MC01PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01PD = ',I2)
99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe',
     $       'r of x     coefficient ')
99996 FORMAT (2X,I5,9X,F9.4)
99995 FORMAT (' K is out of range.',/' K = ',I5)
      END
Program Data 
 MC01PD EXAMPLE PROGRAM DATA
   5
   0.0   1.0
   0.0  -1.0
   2.0   0.0
   1.0   3.0
   1.0  -3.0
Program Results 
 MC01PD EXAMPLE PROGRAM RESULTS

 The coefficients of the polynomial P(x) are 

 power of x     coefficient 
      0          -20.0000
      1           14.0000
      2          -24.0000
      3           15.0000
      4           -4.0000
      5            1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01PY.html000077500000000000000000000057621201767322700161270ustar00rootroot00000000000000 MC01PY - SLICOT Library Routine Documentation

MC01PY

Coefficients of a real polynomial, stored in decreasing order, given its zeros

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the coefficients of a real polynomial P(x) from its
  zeros. The coefficients are stored in decreasing order of the
  powers of x.
Specification 
      SUBROUTINE MC01PY( K, REZ, IMZ, P, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, K
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), IMZ(*), P(*), REZ(*)
Arguments

Input/Output Parameters 

  K       (input) INTEGER
          The number of zeros (and hence the degree) of P(x).
          K >= 0.

  REZ     (input) DOUBLE PRECISION array, dimension (K)
  IMZ     (input) DOUBLE PRECISION array, dimension (K)
          The real and imaginary parts of the i-th zero of P(x)
          must be stored in REZ(i) and IMZ(i), respectively, where
          i = 1, 2, ..., K. The zeros may be supplied in any order,
          except that complex conjugate zeros must appear
          consecutively.

  P       (output) DOUBLE PRECISION array, dimension (K+1)
          This array contains the coefficients of P(x) in decreasing
          powers of x.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (K)
          If K = 0, this array is not referenced.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, (REZ(i),IMZ(i)) is a complex zero but
                (REZ(i-1),IMZ(i-1)) is not its conjugate.
Method 
  The routine computes the coefficients of the real K-th degree
  polynomial P(x) as

     P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K))

  where r(i) = (REZ(i),IMZ(i)).

  Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j)
  form a complex conjugate pair (where i <> j), and that IMZ(i) = 0
  if r(i) is real.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MC01QD.html000077500000000000000000000177461201767322700161100ustar00rootroot00000000000000 MC01QD - SLICOT Library Routine Documentation

MC01QD

Quotient and remainder polynomials for polynomial division

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, for two given real polynomials A(x) and B(x), the
  quotient polynomial Q(x) and the remainder polynomial R(x) of
  A(x) divided by B(x).

  The polynomials Q(x) and R(x) satisfy the relationship

     A(x) = B(x) * Q(x) + R(x),

  where the degree of R(x) is less than the degree of B(x).
Specification 
      SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO )
C     .. Scalar Arguments ..
      INTEGER           DA, DB, INFO, IWARN
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*), RQ(*)
Arguments

Input/Output Parameters 

  DA      (input) INTEGER
          The degree of the numerator polynomial A(x).  DA >= -1.

  DB      (input/output) INTEGER
          On entry, the degree of the denominator polynomial B(x).
          DB >= 0.
          On exit, if B(DB+1) = 0.0 on entry, then DB contains the
          index of the highest power of x for which B(DB+1) <> 0.0.

  A       (input) DOUBLE PRECISION array, dimension (DA+1)
          This array must contain the coefficients of the
          numerator polynomial A(x) in increasing powers of x
          unless DA = -1 on entry, in which case A(x) is taken
          to be the zero polynomial.

  B       (input) DOUBLE PRECISION array, dimension (DB+1)
          This array must contain the coefficients of the
          denominator polynomial B(x) in increasing powers of x.

  RQ      (output) DOUBLE PRECISION array, dimension (DA+1)
          If DA < DB on exit, then this array contains the
          coefficients of the remainder polynomial R(x) in
          increasing powers of x; Q(x) is the zero polynomial.
          Otherwise, the leading DB elements of this array contain
          the coefficients of R(x) in increasing powers of x, and
          the next (DA-DB+1) elements contain the coefficients of
          Q(x) in increasing powers of x.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = k:  if the degree of the denominator polynomial B(x) has
                been reduced to (DB - k) because B(DB+1-j) = 0.0 on
                entry for j = 0, 1, ..., k-1 and B(DB+1-k) <> 0.0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if on entry, DB >= 0 and B(i) = 0.0, where
                i = 1, 2, ..., DB+1.
Method 
  Given real polynomials
                                               DA
     A(x) = a(1) + a(2) * x + ... + a(DA+1) * x

  and
                                               DB
     B(x) = b(1) + b(2) * x + ... + b(DB+1) * x

  where b(DB+1) is non-zero, the routine computes the coeffcients of
  the quotient polynomial
                                                  DA-DB
     Q(x) = q(1) + q(2) * x + ... + q(DA-DB+1) * x

  and the remainder polynomial
                                             DB-1
     R(x) = r(1) + r(2) * x + ... + r(DB) * x

  such that A(x) = B(x) * Q(x) + R(x).

  The algorithm used is synthetic division of polynomials (see [1]),
  which involves the following steps:

     (a) compute q(k+1) = a(DB+k+1) / b(DB+1)

  and

     (b) set a(j) = a(j) - q(k+1) * b(j-k) for j = k+1, ..., DB+k.

  Steps (a) and (b) are performed for k = DA-DB, DA-DB-1, ..., 0 and
  the algorithm terminates with r(i) = a(i) for i = 1, 2, ..., DB.
References 
  [1] Knuth, D.E.
      The Art of Computer Programming, (Vol. 2, Seminumerical
      Algorithms).
      Addison-Wesley, Reading, Massachusetts (2nd Edition), 1981.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MC01QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DAMAX, DBMAX
      PARAMETER        ( DAMAX = 10, DBMAX = 10 )
*     .. Local Scalars ..
      INTEGER          DA, DB, DBB, DQ, DR, I, IMAX, INFO, IWARN
*     .. Local Arrays ..
      DOUBLE PRECISION A(DAMAX+1), B(DBMAX+1), RQ(DAMAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01QD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DA
      IF ( DA.LE.-2 .OR. DA.GT.DAMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) DA
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 )
         READ ( NIN, FMT = * ) DB
         DBB = DB
         IF ( DB.LE.-1 .OR. DB.GT.DBMAX ) THEN
            WRITE ( NOUT, FMT = 99990 ) DB
         ELSE
            READ ( NIN, FMT = * ) ( B(I), I = 1,DB+1 )
*           Compute Q(x) and R(x) from the given A(x) and B(x).
            CALL MC01QD( DA, DB, A, B, RQ, IWARN, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF ( IWARN.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) IWARN
                  WRITE ( NOUT, FMT = 99996 ) DBB, DB
               END IF
               WRITE ( NOUT, FMT = 99995 )
               DQ = DA - DB
               DR = DB - 1
               IMAX = DQ
               IF ( DR.GT.IMAX ) IMAX = DR
               DO 20 I = 0, IMAX
                  IF ( I.LE.DQ .AND. I.LE.DR ) THEN
                     WRITE ( NOUT, FMT = 99994 ) I, RQ(DB+I+1), RQ(I+1)
                  ELSE IF ( I.LE.DQ ) THEN
                     WRITE ( NOUT, FMT = 99993 ) I, RQ(DB+I+1)
                  ELSE
                     WRITE ( NOUT, FMT = 99992 ) I, RQ(I+1)
                  END IF
   20          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01QD = ',I2)
99997 FORMAT (' IWARN on exit from MC01QD = ',I2,/)
99996 FORMAT (' The degree of the denominator polynomial B(x) has been',
     $       ' reduced from ',I2,' to ',I2,/)
99995 FORMAT (' The coefficients of the polynomials Q(x) and R(x) are ',
     $       //'                    Q(x)            R(x) ',/' power of',
     $       ' x     coefficient     coefficient ')
99994 FORMAT (2X,I5,9X,F9.4,7X,F9.4)
99993 FORMAT (2X,I5,9X,F9.4)
99992 FORMAT (2X,I5,25X,F9.4)
99991 FORMAT (/' DA is out of range.',/' DA = ',I5)
99990 FORMAT (/' DB is out of range.',/' DB = ',I5)
      END
Program Data 
 MC01QD EXAMPLE PROGRAM DATA
   4
   2.0  2.0  -1.0  2.0  1.0
   2
   1.0  -1.0  1.0
Program Results 
 MC01QD EXAMPLE PROGRAM RESULTS

 The coefficients of the polynomials Q(x) and R(x) are 

                    Q(x)            R(x) 
 power of x     coefficient     coefficient 
      0            1.0000          1.0000
      1            3.0000          0.0000
      2            1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01RD.html000077500000000000000000000173431201767322700161020ustar00rootroot00000000000000 MC01RD - SLICOT Library Routine Documentation

MC01RD

Polynomial operation P(x) = P1(x) P2(x) + alpha P3(x)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the coefficients of the polynomial

     P(x) = P1(x) * P2(x) + alpha * P3(x),

  where P1(x), P2(x) and P3(x) are given real polynomials and alpha
  is a real scalar.

  Each of the polynomials P1(x), P2(x) and P3(x) may be the zero
  polynomial.
Specification 
      SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO )
C     .. Scalar Arguments ..
      INTEGER           DP1, DP2, DP3, INFO
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  P1(*), P2(*), P3(*)
Arguments

Input/Output Parameters 

  DP1     (input) INTEGER
          The degree of the polynomial P1(x).  DP1 >= -1.

  DP2     (input) INTEGER
          The degree of the polynomial P2(x).  DP2 >= -1.

  DP3     (input/output) INTEGER
          On entry, the degree of the polynomial P3(x).  DP3 >= -1.
          On exit, the degree of the polynomial P(x).

  ALPHA   (input) DOUBLE PRECISION
          The scalar value alpha of the problem.

  P1      (input) DOUBLE PRECISION array, dimension (lenp1)
          where lenp1 = DP1 + 1 if DP1 >= 0 and 1 otherwise.
          If DP1 >= 0, then this array must contain the
          coefficients of P1(x) in increasing powers of x.
          If DP1 = -1, then P1(x) is taken to be the zero
          polynomial, P1 is not referenced and can be supplied
          as a dummy array.

  P2      (input) DOUBLE PRECISION array, dimension (lenp2)
          where lenp2 = DP2 + 1 if DP2 >= 0 and 1 otherwise.
          If DP2 >= 0, then this array must contain the
          coefficients of P2(x) in increasing powers of x.
          If DP2 = -1, then P2(x) is taken to be the zero
          polynomial, P2 is not referenced and can be supplied
          as a dummy array.

  P3      (input/output) DOUBLE PRECISION array, dimension (lenp3)
          where lenp3 = MAX(DP1+DP2,DP3,0) + 1.
          On entry, if DP3 >= 0, then this array must contain the
          coefficients of P3(x) in increasing powers of x.
          On entry, if DP3 = -1, then P3(x) is taken to be the zero
          polynomial.
          On exit, the leading (DP3+1) elements of this array
          contain the coefficients of P(x) in increasing powers of x
          unless DP3 = -1 on exit, in which case the coefficients of
          P(x) (the zero polynomial) are not stored in the array.
          This is the case, for instance, when ALPHA = 0.0 and
          P1(x) or P2(x) is the zero polynomial.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given real polynomials

             DP1           i           DP2           i
     P1(x) = SUM a(i+1) * x ,  P2(x) = SUM b(i+1) * x  and
             i=0                       i=0

             DP3           i
     P3(x) = SUM c(i+1) * x ,
             i=0

  the routine computes the coefficents of P(x) = P1(x) * P2(x) +
                  DP3            i
  alpha * P3(x) = SUM  d(i+1) * x  as follows.
                  i=0

  Let e(i) = c(i) for 1 <= i <= DP3+1 and e(i) = 0 for i > DP3+1.
  Then if DP1 >= DP2,

             i
     d(i) = SUM a(k) * b(i-k+1) + f(i), for i = 1, ..., DP2+1,
            k=1

              i
     d(i)  = SUM a(k) * b(i-k+1) + f(i), for i = DP2+2, ..., DP1+1
            k=i-DP2

  and
             DP1+1
     d(i)  = SUM a(k) * b(i-k+1) + f(i) for i = DP1+2,...,DP1+DP2+1,
            k=i-DP2

  where f(i) = alpha * e(i).

  Similar formulas hold for the case DP1 < DP2.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MC01RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DP1MAX, DP2MAX, DP3MAX
      PARAMETER        ( DP1MAX = 10, DP2MAX = 10, DP3MAX = 10 )
      INTEGER          LENP3
      PARAMETER        ( LENP3 = MAX(DP1MAX+DP2MAX,DP3MAX)+1 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA
      INTEGER          DP1, DP2, DP3, I, INFO
*     .. Local Arrays ..
      DOUBLE PRECISION P1(DP1MAX+1), P2(DP2MAX+1), P3(LENP3)
*    $                 P3(DP1MAX+DP2MAX+DP3MAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP1
      IF ( DP1.LE.-2 .OR. DP1.GT.DP1MAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) DP1
      ELSE
         READ ( NIN, FMT = * ) ( P1(I), I = 1,DP1+1 )
         READ ( NIN, FMT = * ) DP2
         IF ( DP2.LE.-2 .OR. DP2.GT.DP2MAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) DP2
         ELSE
            READ ( NIN, FMT = * ) ( P2(I), I = 1,DP2+1 )
            READ ( NIN, FMT = * ) DP3
            IF ( DP3.LE.-2 .OR. DP3.GT.DP3MAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) DP3
            ELSE
               READ ( NIN, FMT = * ) ( P3(I), I = 1,DP3+1 )
            END IF
            READ ( NIN, FMT = * ) ALPHA
*           Compute the coefficients of the polynomial P(x).
            CALL MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) DP3
               IF ( DP3.GE.0 ) THEN
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 0, DP3
                     WRITE ( NOUT, FMT = 99995 ) I, P3(I+1)
   20             CONTINUE
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01RD = ',I2)
99997 FORMAT (' Degree of the resulting polynomial P(x) = ',I2)
99996 FORMAT (/' The coefficients of P(x) are ',//' power of x     coe',
     $       'fficient ')
99995 FORMAT (2X,I5,9X,F9.4)
99994 FORMAT (/' DP1 is out of range.',/' DP1 = ',I5)
99993 FORMAT (/' DP2 is out of range.',/' DP2 = ',I5)
99992 FORMAT (/' DP3 is out of range.',/' DP3 = ',I5)
      END
Program Data 
 MC01RD EXAMPLE PROGRAM DATA
   1
   1.00  2.50
   2
   1.00  0.10  -0.40
   1
   1.15  1.50
  -2.20
Program Results 
 MC01RD EXAMPLE PROGRAM RESULTS

 Degree of the resulting polynomial P(x) =  3

 The coefficients of P(x) are 

 power of x     coefficient 
      0           -1.5300
      1           -0.7000
      2           -0.1500
      3           -1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01SD.html000077500000000000000000000163241201767322700161010ustar00rootroot00000000000000 MC01SD - SLICOT Library Routine Documentation

MC01SD

Scaling coefficients of a real polynomial for having minimal variation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To scale the coefficients of the real polynomial P(x) such that
  the coefficients of the scaled polynomial Q(x) = sP(tx) have
  minimal variation, where s and t are real scalars.
Specification 
      SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, S, T
C     .. Array Arguments ..
      INTEGER           E(*), IWORK(*)
      DOUBLE PRECISION  MANT(*), P(*)
Arguments

Input/Output Parameters 

  DP      (input) INTEGER
          The degree of the polynomial P(x).  DP >= 0.

  P       (input/output) DOUBLE PRECISION array, dimension (DP+1)
          On entry, this array must contain the coefficients of P(x)
          in increasing powers of x.
          On exit, this array contains the coefficients of the
          scaled polynomial Q(x) in increasing powers of x.

  S       (output) INTEGER
          The exponent of the floating-point representation of the
          scaling factor s = BASE**S, where BASE is the base of the
          machine representation of floating-point numbers (see
          LAPACK Library Routine DLAMCH).

  T       (output) INTEGER
          The exponent of the floating-point representation of the
          scaling factor t = BASE**T.

  MANT    (output) DOUBLE PRECISION array, dimension (DP+1)
          This array contains the mantissas of the standard
          floating-point representation of the coefficients of the
          scaled polynomial Q(x) in increasing powers of x.

  E       (output) INTEGER array, dimension (DP+1)
          This array contains the exponents of the standard
          floating-point representation of the coefficients of the
          scaled polynomial Q(x) in increasing powers of x.
Workspace 
  IWORK   INTEGER array, dimension (DP+1)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if on entry, P(x) is the zero polynomial.
Method 
  Define the variation of the coefficients of the real polynomial

                                      2                DP
     P(x) = p(0) + p(1) * x + p(2) * x  + ... + p(DP) x

  whose non-zero coefficients can be represented as
                       e(i)
     p(i) = m(i) * BASE     (where 1 <= ABS(m(i)) < BASE)

  by

     V = max(e(i)) - min(e(i)),

  where max and min are taken over the indices i for which p(i) is
  non-zero.
                                     DP         i    i
  For the scaled polynomial P(cx) = SUM p(i) * c  * x  with
                                    i=0
             j
  c  = (BASE) , the variation V(j) is given by

    V(j) = max(e(i) + j * i) - min(e(i) + j * i).

  Using the fact that V(j) is a convex function of j, the routine
  determines scaling factors s = (BASE)**S and t = (BASE)**T such
  that the coefficients of the scaled polynomial Q(x) = sP(tx)
  satisfy the following conditions:

    (a) 1 <= q(0) < BASE and

    (b) the variation of the coefficients of Q(x) is minimal.

  Further details can be found in [1].
References 
  [1] Dunaway, D.K.
      Calculation of Zeros of a Real Polynomial through
      Factorization using Euclid's Algorithm.
      SIAM J. Numer. Anal., 11, pp. 1087-1104, 1974.
Numerical Aspects 
  Since the scaling is performed on the exponents of the floating-
  point representation of the coefficients of P(x), no rounding
  errors occur during the computation of the coefficients of Q(x).
Further Comments 
  The scaling factors s and t are BASE dependent.
Example

Program Text 

*     MC01SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 10 )
*     .. Local Scalars ..
      INTEGER          BETA, DP, I, INFO, S, T
*     .. Local Arrays ..
      DOUBLE PRECISION MANT(DPMAX+1), P(DPMAX+1)
      INTEGER          E(DPMAX+1), IWORK(DPMAX+1)
C     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH
*     .. External Subroutines ..
      EXTERNAL         MC01SD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Compute the coefficients of the scaled polynomial Q(x).
         CALL MC01SD( DP, P, S, T, MANT, E, IWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            BETA = DLAMCH( 'Base' )
            WRITE ( NOUT, FMT = 99995 ) BETA, S, T
            WRITE ( NOUT,FMT = 99997 )
            DO 20 I = 0, DP
               WRITE ( NOUT, FMT = 99996 ) I, P(I+1)
   20       CONTINUE
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01SD = ',I2)
99997 FORMAT (/' The coefficients of the scaled polynomial Q(x) = s*P(',
     $       'tx) are ',//' power of x     coefficient ')
99996 FORMAT (2X,I5,9X,F9.4)
99995 FORMAT (' The base of the machine (BETA) = ',I2,//' The scaling ',
     $       'factors are s = BETA**(',I3,') and t = BETA**(',I3,')')
99994 FORMAT (/' DP is out of range.',/' DP =',I5)
      END
Program Data 
 MC01SD EXAMPLE PROGRAM DATA
   5
  10.0  -40.5  159.5  0.0  2560.0  -10236.5
Program Results 
 MC01SD EXAMPLE PROGRAM RESULTS

 The base of the machine (BETA) =  2

 The scaling factors are s = BETA**( -3) and t = BETA**( -2)

 The coefficients of the scaled polynomial Q(x) = s*P(tx) are 

 power of x     coefficient 
      0            1.2500
      1           -1.2656
      2            1.2461
      3            0.0000
      4            1.2500
      5           -1.2496

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01TD.html000077500000000000000000000205241201767322700160770ustar00rootroot00000000000000 MC01TD - SLICOT Library Routine Documentation

MC01TD

Checking stability of a given real polynomial

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine whether or not a given polynomial P(x) with real
  coefficients is stable, either in the continuous-time or discrete-
  time case.

  A polynomial is said to be stable in the continuous-time case
  if all its zeros lie in the left half-plane, and stable in the
  discrete-time case if all its zeros lie inside the unit circle.
Specification 
      SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      LOGICAL           STABLE
      INTEGER           DP, INFO, IWARN, NZ
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), P(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Indicates whether the stability test to be applied to
          P(x) is in the continuous-time or discrete-time case as
          follows:
          = 'C':  Continuous-time case;
          = 'D':  Discrete-time case.
Input/Output Parameters 
  DP      (input/output) INTEGER
          On entry, the degree of the polynomial P(x).  DP >= 0.
          On exit, if P(DP+1) = 0.0 on entry, then DP contains the
          index of the highest power of x for which P(DP+1) <> 0.0.

  P       (input) DOUBLE PRECISION array, dimension (DP+1)
          This array must contain the coefficients of P(x) in
          increasing powers of x.

  STABLE  (output) LOGICAL
          Contains the value .TRUE. if P(x) is stable and the value
          .FALSE. otherwise (see also NUMERICAL ASPECTS).

  NZ      (output) INTEGER
          If INFO = 0, contains the number of unstable zeros - that
          is, the number of zeros of P(x) in the right half-plane if
          DICO = 'C' or the number of zeros of P(x) outside the unit
          circle if DICO = 'D' (see also NUMERICAL ASPECTS).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (2*DP+2)
          The leading (DP+1) elements of DWORK contain the Routh
          coefficients, if DICO = 'C', or the constant terms of
          the Schur-Cohn transforms, if DICO = 'D'.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = k:  if the degree of the polynomial P(x) has been
                reduced to (DB - k) because P(DB+1-j) = 0.0 on entry
                for j = 0, 1,..., k-1 and P(DB+1-k) <> 0.0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if on entry, P(x) is the zero polynomial;
          = 2:  if the polynomial P(x) is most probably unstable,
                although it may be stable with one or more zeros
                very close to either the imaginary axis if
                DICO = 'C' or the unit circle if DICO = 'D'.
                The number of unstable zeros (NZ) is not determined.
Method 
  The stability of the real polynomial
                                      2                DP
     P(x) = p(0) + p(1) * x + p(2) * x  + ... + p(DP) x

  is determined as follows.

  In the continuous-time case (DICO = 'C') the Routh algorithm
  (see [1]) is used. The routine computes the Routh coefficients and
  if they are non-zero then the number of sign changes in the
  sequence of the coefficients is equal to the number of zeros with
  positive imaginary part.

  In the discrete-time case (DICO = 'D') the Schur-Cohn
  algorithm (see [2] and [3]) is applied to the reciprocal
  polynomial
                                             2               DP
     Q(x) = p(DP) + p(DP-1) * x + p(DP-2) * x  + ... + p(0) x  .

  The routine computes the constant terms of the Schur transforms
  and if all of them are non-zero then the number of zeros of P(x)
  with modulus greater than unity is obtained from the sequence of
  constant terms.
References 
  [1] Gantmacher, F.R.
      Applications of the Theory of Matrices.
      Interscience Publishers, New York, 1959.

  [2] Kucera, V.
      Discrete Linear Control. The Algorithmic Approach.
      John Wiley & Sons, Chichester, 1979.

  [3] Henrici, P.
      Applied and Computational Complex Analysis (Vol. 1).
      John Wiley & Sons, New York, 1974.
Numerical Aspects 
  The algorithm used by the routine is numerically stable.

  Note that if some of the Routh coefficients (DICO = 'C') or
  some of the constant terms of the Schur-Cohn transforms (DICO =
  'D') are small relative to EPS (the machine precision), then
  the number of unstable zeros (and hence the value of STABLE) may
  be incorrect.
Further Comments 
  None
Example

Program Text 

*     MC01TD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 10 )
*     .. Local Scalars ..
      INTEGER          DP, DPP, I, INFO, IWARN, NZ
      LOGICAL          STABLE
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(2*DPMAX+2), P(DPMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MC01TD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = * )
      READ ( NIN, FMT = * ) DP, DICO
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DP
      ELSE
         DPP = DP
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Determine whether or not the given polynomial P(x) is stable.
         CALL MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) DPP, DP
            END IF
            IF ( STABLE ) THEN
               WRITE ( NOUT, FMT = 99995 )
            ELSE
               WRITE ( NOUT, FMT = 99994 )
               IF ( LSAME( DICO, 'D' ) ) THEN
                  WRITE ( NOUT, FMT = 99992 ) NZ
               ELSE
                  WRITE ( NOUT, FMT = 99991 ) NZ
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MC01TD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01TD = ',I2)
99997 FORMAT (' IWARN on exit from MC01TD = ',I2,/)
99996 FORMAT (' The degree of the polynomial P(x) has been reduced fro',
     $       'm ',I2,' to ',I2,/)
99995 FORMAT (' The polynomial P(x) is stable ')
99994 FORMAT (' The polynomial P(x) is unstable ')
99993 FORMAT (/' DP is out of range. ',/' DP = ',I5)
99992 FORMAT (/' The number of zeros of P(x) outside the unit ',
     $       'circle = ',I2)
99991 FORMAT (/' The number of zeros of P(x) in the right ',
     $       'half-plane = ',I2)
      END
Program Data 
 MC01TD EXAMPLE PROGRAM DATA
   4     C
   2.0  0.0  1.0  -1.0  1.0
Program Results 
 MC01TD EXAMPLE PROGRAM RESULTS

 The polynomial P(x) is unstable 

 The number of zeros of P(x) in the right half-plane =  2

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01VD.html000077500000000000000000000117501201767322700161020ustar00rootroot00000000000000 MC01VD - SLICOT Library Routine Documentation

MC01VD

Roots of a quadratic equation with real coefficients

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the roots of a quadratic equation with real
  coefficients.
Specification 
      SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO
      DOUBLE PRECISION  A, B, C, Z1IM, Z1RE, Z2IM, Z2RE
Arguments

Input/Output Parameters 

  A       (input) DOUBLE PRECISION
          The value of the coefficient of the quadratic term.

  B       (input) DOUBLE PRECISION
          The value of the coefficient of the linear term.

  C       (input) DOUBLE PRECISION
          The value of the coefficient of the constant term.

  Z1RE    (output) DOUBLE PRECISION
  Z1IM    (output) DOUBLE PRECISION
          The real and imaginary parts, respectively, of the largest
          root in magnitude.

  Z2RE    (output) DOUBLE PRECISION
  Z2IM    (output) DOUBLE PRECISION
          The real and imaginary parts, respectively, of the
          smallest root in magnitude.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if on entry, either A = B = 0.0 or A = 0.0 and the
                root -C/B overflows; in this case Z1RE, Z1IM, Z2RE
                and Z2IM are unassigned;
          = 2:  if on entry, A = 0.0; in this case Z1RE contains
                BIG and Z1IM contains zero, where BIG is a
                representable number near the overflow threshold
                of the machine (see LAPACK Library Routine DLAMCH);
          = 3:  if on entry, either C = 0.0 and the root -B/A
                overflows or A, B and C are non-zero and the largest
                real root in magnitude cannot be computed without
                overflow; in this case Z1RE contains BIG and Z1IM
                contains zero;
          = 4:  if the roots cannot be computed without overflow; in
                this case Z1RE, Z1IM, Z2RE and Z2IM are unassigned.
Method 
  The routine computes the roots (r1 and r2) of the real quadratic
  equation
          2
     a * x  + b * x + c = 0

  as
          - b - SIGN(b) * SQRT(b * b - 4 * a * c)             c
     r1 = ---------------------------------------  and r2 = ------
                           2 * a                            a * r1

  unless a = 0, in which case

          -c
     r1 = --.
           b

  Precautions are taken to avoid overflow and underflow wherever
  possible.
Numerical Aspects 
  The algorithm is numerically stable.
Further Comments 
  None
Example

Program Text 

*     MC01VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
*     .. Local Scalars ..
      DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE
      INTEGER          INFO
*     .. External Subroutines ..
      EXTERNAL         MC01VD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) A, B, C
*     Solve the quadratic equation A*x**2 + B*x + C = 0.
      CALL MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO )
*
      IF ( INFO.NE.0 ) THEN
         WRITE ( NOUT, FMT = 99998 ) INFO
      ELSE
         WRITE ( NOUT, FMT = 99997 )
         WRITE ( NOUT, FMT = 99996 ) Z1RE, Z1IM, Z2RE, Z2IM
      END IF
*
      STOP
*
99999 FORMAT (' MC01VD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01VD = ',I2)
99997 FORMAT (' The roots of the quadratic equation are ')
99996 FORMAT (/' x = ',F8.4,2X,SP,F8.4,'*j',SS,/' x = ',F8.4,2X,SP,F8.4,
     $       '*j')
      END
Program Data 
 MC01VD EXAMPLE PROGRAM DATA
   0.5  -1.0  2.0
Program Results 
 MC01VD EXAMPLE PROGRAM RESULTS

 The roots of the quadratic equation are 

 x =   1.0000   +1.7321*j
 x =   1.0000   -1.7321*j

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC01WD.html000077500000000000000000000136371201767322700161110ustar00rootroot00000000000000 MC01WD - SLICOT Library Routine Documentation

MC01WD

Quotient and remainder polynomials for a quadratic denominator polynomial

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, for a given real polynomial P(x) and a quadratic
  polynomial B(x), the quotient polynomial Q(x) and the linear
  remainder polynomial R(x) such that

     P(x) = B(x) * Q(x) + R(x),

                              2
  where B(x) = u1 + u2 * x + x , R(x) = q(1) + q(2) * (u2 + x)
  and u1, u2, q(1) and q(2) are real scalars.
Specification 
      SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO
      DOUBLE PRECISION  U1, U2
C     .. Array Arguments ..
      DOUBLE PRECISION  P(*), Q(*)
Arguments

Input/Output Parameters 

  DP      (input) INTEGER
          The degree of the polynomial P(x).  DP >= 0.

  P       (input) DOUBLE PRECISION array, dimension (DP+1)
          This array must contain the coefficients of P(x) in
          increasing powers of x.

  U1      (input) DOUBLE PRECISION
          The value of the constant term of the quadratic
          polynomial B(x).

  U2      (input) DOUBLE PRECISION
          The value of the coefficient of x of the quadratic
          polynomial B(x).

  Q       (output) DOUBLE PRECISION array, dimension (DP+1)
          If DP >= 1 on entry, then elements Q(1) and Q(2) contain
          the coefficients q(1) and q(2), respectively, of the
          remainder polynomial R(x), and the next (DP-1) elements
          of this array contain the coefficients of the quotient
          polynomial Q(x) in increasing powers of x.
          If DP = 0 on entry, then element Q(1) contains the
          coefficient q(1) of the remainder polynomial R(x) = q(1);
          Q(x) is the zero polynomial.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given the real polynomials

             DP           i                           2
     P(x) = SUM p(i+1) * x  and B(x) = u1 + u2 * x + x
            i=0

  the routine uses the recurrence relationships

     q(DP+1) = p(DP+1),

     q(DP) = p(DP) - u2 * q(DP+1) and

     q(i)  = p(i) - u2 * q(i+1) - u1 * q(i+2) for i = DP-1, ..., 1

  to determine the coefficients of the quotient polynomial

            DP-2          i
     Q(x) = SUM q(i+3) * x
            i=0

  and the remainder polynomial

     R(x) = q(1) + q(2) * (u2 + x).
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     MC01WD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 10 )
*     .. Local Scalars ..
      DOUBLE PRECISION U1, U2
      INTEGER          DP, I, INFO
*     .. Local Arrays ..
      DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01WD
*     .. Executable Statements ..
*
      WRITE ( NOUT,FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
         READ ( NIN, FMT = * ) U1, U2
*        Compute Q(x) and R(x) from P(x) = (x**2+U2*x+U1) * Q(x) + R(x).
         CALL MC01WD( DP, P, U1, U2, Q, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 0, DP - 2
               WRITE ( NOUT, FMT = 99996 ) I, Q(I+3)
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) Q(1) + Q(2)*U2, Q(2)
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01WD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01WD = ',I2)
99997 FORMAT (' The coefficients of the quotient polynomial Q(x) are ',
     $       //' power of x     coefficient ')
99996 FORMAT (2X,I5,9X,F9.4)
99995 FORMAT (/' The coefficients of the remainder polynomial R(x) are '
     $       ,//' power of x     coefficient ',/'      0         ',F9.4,
     $       /'      1         ',F9.4)
99994 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END
Program Data 
 MC01WD EXAMPLE PROGRAM DATA
   6
   0.62  1.10  1.64  1.88  2.12  1.70  1.00
   0.60  0.80
Program Results 
 MC01WD EXAMPLE PROGRAM RESULTS

 The coefficients of the quotient polynomial Q(x) are 

 power of x     coefficient 
      0            0.6000
      1            0.7000
      2            0.8000
      3            0.9000
      4            1.0000

 The coefficients of the remainder polynomial R(x) are 

 power of x     coefficient 
      0            0.2600
      1            0.2000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC03MD.html000077500000000000000000000301651201767322700160740ustar00rootroot00000000000000 MC03MD - SLICOT Library Routine Documentation

MC03MD

Real polynomial matrix operation P(x) = P1(x) P2(x) + alpha P3(x)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the coefficients of the real polynomial matrix

     P(x) = P1(x) * P2(x) + alpha * P3(x),

  where P1(x), P2(x) and P3(x) are given real polynomial matrices
  and alpha is a real scalar.

  Each of the polynomial matrices P1(x), P2(x) and P3(x) may be the
  zero matrix.
Specification 
      SUBROUTINE MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1,
     $                   LDP11, LDP12, P2, LDP21, LDP22, P3, LDP31,
     $                   LDP32, DWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  RP1     (input) INTEGER
          The number of rows of the matrices P1(x) and P3(x).
          RP1 >= 0.

  CP1     (input) INTEGER
          The number of columns of matrix P1(x) and the number of
          rows of matrix P2(x).  CP1 >= 0.

  CP2     (input) INTEGER
          The number of columns of the matrices P2(x) and P3(x).
          CP2 >= 0.

  DP1     (input) INTEGER
          The degree of the polynomial matrix P1(x).  DP1 >= -1.

  DP2     (input) INTEGER
          The degree of the polynomial matrix P2(x).  DP2 >= -1.

  DP3     (input/output) INTEGER
          On entry, the degree of the polynomial matrix P3(x).
          DP3 >= -1.
          On exit, the degree of the polynomial matrix P(x).

  ALPHA   (input) DOUBLE PRECISION
          The scalar value alpha of the problem.

  P1      (input) DOUBLE PRECISION array, dimension (LDP11,LDP12,*)
          If DP1 >= 0, then the leading RP1-by-CP1-by-(DP1+1) part
          of this array must contain the coefficients of the
          polynomial matrix P1(x). Specifically, P1(i,j,k) must
          contain the coefficient of x**(k-1) of the polynomial
          which is the (i,j)-th element of P1(x), where i = 1,2,...,
          RP1, j = 1,2,...,CP1 and k = 1,2,...,DP1+1.
          If DP1 = -1, then P1(x) is taken to be the zero polynomial
          matrix, P1 is not referenced and can be supplied as a
          dummy array (i.e. set the parameters LDP11 = LDP12 = 1 and
          declare this array to be P1(1,1,1) in the calling
          program).

  LDP11   INTEGER
          The leading dimension of array P1.
          LDP11 >= MAX(1,RP1) if DP1 >= 0,
          LDP11 >= 1          if DP1 = -1.

  LDP12   INTEGER
          The second dimension of array P1.
          LDP12 >= MAX(1,CP1) if DP1 >= 0,
          LDP12 >= 1          if DP1 = -1.

  P2      (input) DOUBLE PRECISION array, dimension (LDP21,LDP22,*)
          If DP2 >= 0, then the leading CP1-by-CP2-by-(DP2+1) part
          of this array must contain the coefficients of the
          polynomial matrix P2(x). Specifically, P2(i,j,k) must
          contain the coefficient of x**(k-1) of the polynomial
          which is the (i,j)-th element of P2(x), where i = 1,2,...,
          CP1, j = 1,2,...,CP2 and k = 1,2,...,DP2+1.
          If DP2 = -1, then P2(x) is taken to be the zero polynomial
          matrix, P2 is not referenced and can be supplied as a
          dummy array (i.e. set the parameters LDP21 = LDP22 = 1 and
          declare this array to be P2(1,1,1) in the calling
          program).

  LDP21   INTEGER
          The leading dimension of array P2.
          LDP21 >= MAX(1,CP1) if DP2 >= 0,
          LDP21 >= 1          if DP2 = -1.

  LDP22   INTEGER
          The second dimension of array P2.
          LDP22 >= MAX(1,CP2) if DP2 >= 0,
          LDP22 >= 1          if DP2 = -1.

  P3      (input/output) DOUBLE PRECISION array, dimension
          (LDP31,LDP32,n), where n = MAX(DP1+DP2,DP3,0)+1.
          On entry, if DP3 >= 0, then the leading
          RP1-by-CP2-by-(DP3+1) part of this array must contain the
          coefficients of the polynomial matrix P3(x). Specifically,
          P3(i,j,k) must contain the coefficient of x**(k-1) of the
          polynomial which is the (i,j)-th element of P3(x), where
          i = 1,2,...,RP1, j = 1,2,...,CP2 and k = 1,2,...,DP3+1.
          If DP3 = -1, then P3(x) is taken to be the zero polynomial
          matrix.
          On exit, if DP3 >= 0 on exit (ALPHA <> 0.0 and DP3 <> -1,
          on entry, or DP1 <> -1 and DP2 <> -1), then the leading
          RP1-by-CP2-by-(DP3+1) part of this array contains the
          coefficients of P(x). Specifically, P3(i,j,k) contains the
          coefficient of x**(k-1) of the polynomial which is the
          (i,j)-th element of P(x), where i = 1,2,...,RP1, j = 1,2,
          ...,CP2 and k = 1,2,...,DP3+1.
          If DP3 = -1 on exit, then the coefficients of P(x) (the
          zero polynomial matrix) are not stored in the array.

  LDP31   INTEGER
          The leading dimension of array P3.  LDP31 >= MAX(1,RP1).

  LDP32   INTEGER
          The second dimension of array P3.   LDP32 >= MAX(1,CP2).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (CP1)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given real polynomial matrices

             DP1            i
     P1(x) = SUM (A(i+1) * x ),
             i=0

             DP2            i
     P2(x) = SUM (B(i+1) * x ),
             i=0

             DP3            i
     P3(x) = SUM (C(i+1) * x )
             i=0

  and a real scalar alpha, the routine computes the coefficients
  d ,d ,..., of the polynomial matrix
   1  2

     P(x) = P1(x) * P2(x) + alpha * P3(x)

  from the formula

              s
     d    =  SUM (A(k+1) * B(i-k+1)) + alpha * C(i+1),
      i+1    k=r

  where i = 0,1,...,DP1+DP2 and r and s depend on the value of i
  (e.g. if i <= DP1 and i <= DP2, then r = 0 and s = i).
Numerical Aspects 
  None.
Further Comments 
  Other elementary operations involving polynomial matrices can
  easily be obtained by calling the appropriate BLAS routine(s).
Example

Program Text 

*     MC03MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          CP1MAX, CP2MAX, DP1MAX, DP2MAX, DP3MAX, RP1MAX
      PARAMETER        ( CP1MAX = 10, CP2MAX = 10, DP1MAX = 10,
     $                   DP2MAX = 10, DP3MAX = 20, RP1MAX = 10 )
      INTEGER          LDP11, LDP12, LDP21, LDP22, LDP31, LDP32
      PARAMETER        ( LDP11 = RP1MAX, LDP12 = CP1MAX,
     $                   LDP21 = CP1MAX, LDP22 = CP2MAX,
     $                   LDP31 = RP1MAX, LDP32 = CP2MAX )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA
      INTEGER          CP1, CP2, DP1, DP2, DP3, I, INFO, J, K, RP1
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(CP1MAX),
     $                 P1(LDP11,LDP12,DP1MAX+1),
     $                 P2(LDP21,LDP22,DP2MAX+1),
     $                 P3(LDP31,LDP32,DP3MAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC03MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) RP1, CP1, CP2
      IF ( RP1.LT.0 .OR. RP1.GT.RP1MAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) RP1
      ELSE IF ( CP1.LT.0 .OR. CP1.GT.CP1MAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) CP1
      ELSE IF ( CP2.LT.0 .OR. CP2.GT.CP2MAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) CP2
      ELSE
         READ ( NIN, FMT = * ) DP1
         IF ( DP1.LE.-2 .OR. DP1.GT.DP1MAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) DP1
         ELSE
            DO 40 K = 1, DP1 + 1
               DO 20 J = 1, CP1
                  READ ( NIN, FMT = * ) ( P1(I,J,K), I = 1,RP1 )
   20          CONTINUE
   40       CONTINUE
            READ ( NIN, FMT = * ) DP2
            IF ( DP2.LE.-2 .OR. DP2.GT.DP2MAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) DP2
            ELSE
               DO 80 K = 1, DP2 + 1
                  DO 60 J = 1, CP2
                     READ ( NIN, FMT = * ) ( P2(I,J,K), I = 1,CP1 )
   60             CONTINUE
   80          CONTINUE
               READ ( NIN, FMT = * ) DP3
               IF ( DP3.LE.-2 .OR. DP3.GT.DP3MAX ) THEN
                  WRITE ( NOUT, FMT = 99990 ) DP3
               ELSE
                  DO 120 K = 1, DP3 + 1
                     DO 100 J = 1, CP2
                        READ ( NIN, FMT = * ) ( P3(I,J,K), I = 1,RP1 )
  100                CONTINUE
  120             CONTINUE
                  READ ( NIN, FMT = * ) ALPHA
*                 Compute the coefficients of the polynomial matrix P(x)
                  CALL MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1,
     $                         LDP11, LDP12, P2, LDP21, LDP22, P3,
     $                         LDP31, LDP32, DWORK, INFO )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99997 ) DP3,
     $                     ( I-1, I = 1,DP3+1 )
                     DO 160 I = 1, RP1
                        DO 140 J = 1, CP2
                           WRITE ( NOUT, FMT = 99996 ) I, J,
     $                       ( P3(I,J,K), K = 1,DP3+1 )
  140                   CONTINUE
  160                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC03MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC03MD = ',I2)
99997 FORMAT (' The polynomial matrix P(x) (of degree ',I2,') is ',
     $       //' power of x         ',20I8)
99996 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F7.2))
99995 FORMAT (/' RP1 is out of range.',/' RP1 = ',I5)
99994 FORMAT (/' CP1 is out of range.',/' CP1 = ',I5)
99993 FORMAT (/' CP2 is out of range.',/' CP2 = ',I5)
99992 FORMAT (/' DP1 is out of range.',/' DP1 = ',I5)
99991 FORMAT (/' DP2 is out of range.',/' DP2 = ',I5)
99990 FORMAT (/' DP3 is out of range.',/' DP3 = ',I5)
      END
Program Data 
 MC03MD EXAMPLE PROGRAM DATA
   3     2     2
   2
   1.0   0.0   3.0
   2.0  -1.0   2.0
  -2.0   4.0   9.0
   3.0   7.0  -2.0
   6.0   2.0  -3.0
   1.0   2.0   4.0
   1
   6.0   1.0
   1.0   7.0
  -9.0  -6.0
   7.0   8.0
   1
   1.0   1.0   0.0
   0.0   1.0   1.0
  -1.0   1.0   1.0
  -1.0  -1.0   1.0
   1.0
Program Results 
 MC03MD EXAMPLE PROGRAM RESULTS

 The polynomial matrix P(x) (of degree  3) is 

 power of x                0       1       2       3

 element ( 1, 1) is     9.00  -31.00   37.00  -60.00

 element ( 1, 2) is    15.00   41.00   23.00   50.00

 element ( 2, 1) is     0.00   38.00  -64.00  -30.00

 element ( 2, 2) is    -6.00   44.00  100.00   30.00

 element ( 3, 1) is    20.00   14.00  -83.00    3.00

 element ( 3, 2) is    18.00   33.00   72.00   11.00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC03ND.html000077500000000000000000000360641201767322700161010ustar00rootroot00000000000000 MC03ND - SLICOT Library Routine Documentation

MC03ND

Minimal polynomial basis for the right nullspace of a polynomial matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the coefficients of a minimal polynomial basis
                                              DK
      K(s) = K(0) + K(1) * s + ... + K(DK) * s

  for the right nullspace of the MP-by-NP polynomial matrix of
  degree DP, given by
                                              DP
      P(s) = P(0) + P(1) * s + ... + P(DP) * s  ,

  which corresponds to solving the polynomial matrix equation
  P(s) * K(s) = 0.
Specification 
      SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP,
     $                   LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  MP      (input) INTEGER
          The number of rows of the polynomial matrix P(s).
          MP >= 0.

  NP      (input) INTEGER
          The number of columns of the polynomial matrix P(s).
          NP >= 0.

  DP      (input) INTEGER
          The degree of the polynomial matrix P(s).  DP >= 1.

  P       (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1)
          The leading MP-by-NP-by-(DP+1) part of this array must
          contain the coefficients of the polynomial matrix P(s).
          Specifically, P(i,j,k) must contain the (i,j)-th element
          of P(k-1), which is the cofficient of s**(k-1) of P(s),
          where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1.

  LDP1    INTEGER
          The leading dimension of array P.  LDP1 >= MAX(1,MP).

  LDP2    INTEGER
          The second dimension of array P.   LDP2 >= MAX(1,NP).

  DK      (output) INTEGER
          The degree of the minimal polynomial basis K(s) for the
          right nullspace of P(s) unless DK = -1, in which case
          there is no right nullspace.

  GAM     (output) INTEGER array, dimension (DP*MP+1)
          The leading (DK+1) elements of this array contain
          information about the ordering of the right nullspace
          vectors stored in array NULLSP.

  NULLSP  (output) DOUBLE PRECISION array, dimension
          (LDNULL,(DP*MP+1)*NP)
          The leading NP-by-SUM(i*GAM(i)) part of this array
          contains the right nullspace vectors of P(s) in condensed
          form (as defined in METHOD), where i = 1,2,...,DK+1.

  LDNULL  INTEGER
          The leading dimension of array NULLSP.
          LDNULL >= MAX(1,NP).

  KER     (output) DOUBLE PRECISION array, dimension
          (LDKER1,LDKER2,DP*MP+1)
          The leading NP-by-nk-by-(DK+1) part of this array contains
          the coefficients of the minimal polynomial basis K(s),
          where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically,
          KER(i,j,m) contains the (i,j)-th element of K(m-1), which
          is the coefficient of s**(m-1) of K(s), where i = 1,2,...,
          NP, j = 1,2,...,nk and m = 1,2,...,DK+1.

  LDKER1  INTEGER
          The leading dimension of array KER.  LDKER1 >= MAX(1,NP).

  LDKER2  INTEGER
          The second dimension of array KER.   LDKER2 >= MAX(1,NP).
Tolerances 
  TOL     DOUBLE PRECISION
          A tolerance below which matrix elements are considered
          to be zero. If the user sets TOL to be less than
          10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is
                               F       F
          taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the
                                        F       F
          machine precision (see LAPACK Library Routine DLAMCH) and
          A and E are matrices (as defined in METHOD).
Workspace 
  IWORK   INTEGER array, dimension (m+2*MAX(n,m+1)+n),
          where m = DP*MP and n = (DP-1)*MP + NP.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  The length of the array DWORK.
          LDWORK >= m*n*n + 2*m*n + 2*n*n.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
          > 0:  if incorrect rank decisions were taken during the
                computations. This failure is not likely to occur.
                The possible values are:
                  k, 1 <= k <= DK+1, the k-th diagonal submatrix had
                        not a full row rank;
                  DK+2, if incorrect dimensions of a full column
                        rank submatrix;
                  DK+3, if incorrect dimensions of a full row rank
                        submatrix.
Method 
  The computation of the right nullspace of the MP-by-NP polynomial
  matrix P(s) of degree DP given by
                                               DP-1            DP
     P(s) = P(0) + P(1) * s + ... + P(DP-1) * s     + P(DP) * s

  is performed via the pencil s*E - A, associated with P(s), where

         | I              |           | 0         -P(DP) |
         |   .            |           | I .          .   |
     A = |     .          |  and  E = |   . .        .   |.      (1)
         |       .        |           |     . 0      .   |
         |         I      |           |       I 0 -P(2)  |
         |           P(0) |           |         I -P(1)  |

  The pencil s*E - A is transformed by unitary matrices Q and Z such
  that

                  | sE(eps)-A(eps) |        X       |      X     |
                  |----------------|----------------|------------|
                  |        0       | sE(inf)-A(inf) |      X     |
     Q'(s*E-A)Z = |=================================|============|.
                  |                                 |            |
                  |                0                | sE(r)-A(r) |

  Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the
  minimal polynomial basis for the right nullspace of Q'(s*E-A)Z
  (and consequently the basis for the right nullspace of s*E - A) is
  completely determined by s*E(eps)-A(eps).

  Let Veps(s) be a minimal polynomial basis for the right nullspace
  of s*E(eps)-A(eps). Then

                | Veps(s) |
     V(s) = Z * |---------|
                |    0    |

  is a minimal polynomial basis for the right nullspace of s*E - A.
  From the structure of s*E - A it can be shown that if V(s) is
  partitioned as

            | Vo(s) | (DP-1)*MP
     V(s) = |------ |
            | Ve(s) | NP

  then the columns of Ve(s) form a minimal polynomial basis for the
  right nullspace of P(s).

  The vectors of Ve(s) are computed and stored in array NULLSP in
  the following condensed form:

     ||      ||      |      ||      |      |      ||      |     |
     || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |,
     ||      ||      |      ||      |      |      ||      |     |

  where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block
  of columns of K(j), the j-th coefficient of the polynomial matrix
  representation for the right nullspace
                                               DK
     K(s) = K(0) + K(1) * s + . . . + K(DK) * s  .

  The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices
  given by

     K(0)  = | U1,0 | U2,0 | U3,0 | . . .          | U(DK+1,0) |

     K(1)  = |  0   | U2,1 | U3,1 | . . .          | U(DK+1,1) |

     K(2)  = |  0   |  0   | U3,2 | . . .          | U(DK+1,2) |

       .     .     .     .     .     .     .     .     .     .

     K(DK) = |  0   |  0   |  0   | . . .    |  0  | U(DK+1,DK)|.

  Note that the degree of K(s) satisfies the inequality DK <=
  DP * MIN(MP,NP) and that the dimension of K(s) satisfies the
  inequality (NP-MP) <= nk <= NP.
References 
  [1] Beelen, Th.G.J.
      New Algorithms for Computing the Kronecker structure of a
      Pencil with Applications to Systems and Control Theory.
      Ph.D.Thesis, Eindhoven University of Technology, 1987.

  [2] Van Den Hurk, G.J.H.H.
      New Algorithms for Solving Polynomial Matrix Problems.
      Master's Thesis, Eindhoven University of Technology, 1987.
Numerical Aspects 
  The algorithm used by the routine involves the construction of a
  special block echelon form with pivots considered to be non-zero
  when they are larger than TOL. These pivots are then inverted in
  order to construct the columns of the kernel of the polynomial
  matrix. If TOL is chosen to be too small then these inversions may
  be sensitive whereas increasing TOL will make the inversions more
  robust but will affect the block echelon form (and hence the
  column degrees of the polynomial kernel). Furthermore, if the
  elements of the computed polynomial kernel are large relative to
  the polynomial matrix, then the user should consider trying
  several values of TOL.
Further Comments 
  It also possible to compute a minimal polynomial basis for the
  right nullspace of a pencil, since a pencil is a polynomial matrix
  of degree 1. Thus for the pencil (s*E - A), the required input is
  P(1)  = E and P(0) = -A.

  The routine can also be used to compute a minimal polynomial
  basis for the left nullspace of a polynomial matrix by simply
  transposing P(s).
Example

Program Text 

*     MC03ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX, MPMAX, NPMAX
*     PARAMETER        ( DPMAX = 5, MPMAX = 5, NPMAX = 5 )
      PARAMETER        ( DPMAX = 2, MPMAX = 5, NPMAX = 4 )
      INTEGER          LDP1, LDP2, LDNULL, LDKER1, LDKER2
      PARAMETER        ( LDP1 = MPMAX, LDP2 = NPMAX, LDNULL = NPMAX,
     $                   LDKER1 = NPMAX, LDKER2 = NPMAX )
      INTEGER          M, N
      PARAMETER        ( M = DPMAX*MPMAX, N = ( DPMAX-1 )*MPMAX+NPMAX )
      INTEGER          LIWORK, LDWORK
*     PARAMETER        ( LIWORK = 3*( N+M )+2,
      PARAMETER        ( LIWORK = M+2*MAX( N,M+1 )+N,
     $                   LDWORK = M*N**2+2*M*N+2*N**2 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          DK, DP, I, INFO, J, K, M1, MP, NK, NP
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), KER(LDKER1,LDKER2,M+1),
     $                 NULLSP(LDNULL,(M+1)*NPMAX), P(LDP1,LDP2,DPMAX+1)
      INTEGER          GAM(M+1), IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         MC03ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) MP, NP, DP, TOL
      IF ( MP.LT.0 .OR. MP.GT.MPMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) MP
      ELSE IF ( NP.LT.0 .OR. NP.GT.NPMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) NP
      ELSE IF ( DP.LE.0 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) DP
      ELSE
         DO 40 K = 1, DP + 1
            DO 20 I = 1, MP
               READ ( NIN, FMT = * ) ( P(I,J,K), J = 1,NP )
   20       CONTINUE
   40    CONTINUE
*        Compute a minimal polynomial basis K(s) of the given P(s).
         CALL MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP,
     $                LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK,
     $                LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE IF ( DK.LT.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
         ELSE
            NK = 0
            M1 = 0
            DO 60 I = 1, DK + 1
               NK = NK + GAM(I)
               M1 = M1 + GAM(I)*I
   60       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 80 I = 1, NP
               WRITE ( NOUT, FMT = 99995 ) ( NULLSP(I,J), J = 1,M1 )
   80       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) DK, ( I-1, I = 1,DK+1 )
            DO 120 I = 1, NP
               DO 100 J = 1, NK
                  WRITE ( NOUT, FMT = 99993 )
     $                  I, J, ( KER(I,J,K), K = 1,DK+1 )
  100          CONTINUE
  120       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MC03ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC03ND = ',I2)
99997 FORMAT (' The polynomial matrix P(s) has no right nullspace')
99996 FORMAT (' The right nullspace vectors of P(s) are ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' The minimal polynomial basis K(s) (of degree ',I2,') ',
     $       'for the right nullspace is ',//' power of s         ',
     $       20I8)
99993 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F7.2))
99992 FORMAT (/' DP is out of range.',/' DP = ',I5)
99991 FORMAT (/' NP is out of range.',/' NP = ',I5)
99990 FORMAT (/' MP is out of range.',/' MP = ',I5)
      END
Program Data 
 MC03ND EXAMPLE PROGRAM DATA
   5     4     2     0.0
   2.0   2.0   0.0   3.0
   0.0   4.0   0.0   6.0
   8.0   8.0   0.0  12.0
   0.0   0.0   0.0   0.0
   2.0   2.0   0.0   3.0
   1.0   0.0   1.0   0.0
   0.0   0.0   2.0   0.0
   4.0   0.0   4.0   0.0
   2.0   2.0   0.0   3.0
   3.0   2.0   1.0   3.0
   0.0   0.0   0.0   0.0
   1.0   0.0   0.0   0.0
   0.0   0.0   0.0   0.0
   1.0   0.0   1.0   0.0
   1.0   0.0   1.0   0.0
Program Results 
 MC03ND EXAMPLE PROGRAM RESULTS

 The right nullspace vectors of P(s) are 
   0.0000   0.0000   0.0000
  -0.8321   0.0000   0.1538
   0.0000  -1.0000   0.0000
   0.5547   0.0000   0.2308

 The minimal polynomial basis K(s) (of degree  1) for the right nullspace is 

 power of s                0       1

 element ( 1, 1) is     0.00    0.00

 element ( 1, 2) is     0.00    0.00

 element ( 2, 1) is    -0.83    0.00

 element ( 2, 2) is     0.00    0.15

 element ( 3, 1) is     0.00    0.00

 element ( 3, 2) is    -1.00    0.00

 element ( 4, 1) is     0.55    0.00

 element ( 4, 2) is     0.00    0.23

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MC03NX.html000077500000000000000000000067531201767322700161270ustar00rootroot00000000000000 MC03NX - SLICOT Library Routine Documentation

MC03NX

Construction of a pencil sE-A related to a given polynomial matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  Given an MP-by-NP polynomial matrix of degree dp
                                 dp-1            dp
  P(s) = P(0) + ... + P(dp-1) * s     + P(dp) * s            (1)

  the routine composes the related pencil s*E-A where

      | I              |           | O          -P(dp) |
      |   .            |           | I .           .   |
  A = |     .          |  and  E = |   . .         .   |.    (2)
      |       .        |           |     . O       .   |
      |         I      |           |       I  O -P(2)  |
      |           P(0) |           |          I -P(1)  |

  ==================================================================
  REMARK: This routine is intended to be called only from the SLICOT
          routine MC03ND.
  ==================================================================
Specification 
      SUBROUTINE MC03NX( MP, NP, DP, P, LDP1, LDP2, A, LDA, E, LDE )
C     .. Scalar Arguments ..
      INTEGER           DP, LDA, LDE, LDP1, LDP2, MP, NP
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), P(LDP1,LDP2,*)
Arguments

Input/Output Parameters 

  MP      (input) INTEGER
          The number of rows of the polynomial matrix P(s).
          MP >= 0.

  NP      (input) INTEGER
          The number of columns of the polynomial matrix P(s).
          NP >= 0.

  DP      (input) INTEGER
          The degree of the polynomial matrix P(s).  DP >= 1.

  P       (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1)
          The leading MP-by-NP-by-(DP+1) part of this array must
          contain the coefficients of the polynomial matrix P(s)
          in (1) in increasing powers of s.

  LDP1    INTEGER
          The leading dimension of array P.  LDP1 >= MAX(1,MP).

  LDP2    INTEGER
          The second dimension of array P.   LDP2 >= MAX(1,NP).

  A       (output) DOUBLE PRECISION array, dimension
          (LDA,(DP-1)*MP+NP)
          The leading DP*MP-by-((DP-1)*MP+NP) part of this array
          contains the matrix A as described in (2).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,DP*MP).

  E       (output) DOUBLE PRECISION array, dimension
          (LDE,(DP-1)*MP+NP)
          The leading DP*MP-by-((DP-1)*MP+NP) part of this array
          contains the matrix E as described in (2).

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,DP*MP).
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MD03AD.html000077500000000000000000000765641201767322700160760ustar00rootroot00000000000000 MD03AD - SLICOT Library Routine Documentation

MD03AD

Solution of a standard nonlinear least squares problem (Cholesky-based or conjugate gradients solver)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To minimize the sum of the squares of m nonlinear functions, e, in
  n variables, x, by a modification of the Levenberg-Marquardt
  algorithm, using either a Cholesky-based or a conjugate gradients
  solver. The user must provide a subroutine FCN which calculates
  the functions and the Jacobian J (possibly by finite differences),
  and another subroutine JPJ, which computes either J'*J + par*I
  (if ALG = 'D'), or (J'*J + par*I)*x (if ALG = 'I'), where par is
  the Levenberg factor, exploiting the possible structure of the
  Jacobian matrix. Template implementations of these routines are
  included in the SLICOT Library.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  XINIT   CHARACTER*1
          Specifies how the variables x are initialized, as follows:
          = 'R' :  the array X is initialized to random values; the
                   entries DWORK(1:4) are used to initialize the
                   random number generator: the first three values
                   are converted to integers between 0 and 4095, and
                   the last one is converted to an odd integer
                   between 1 and 4095;
          = 'G' :  the given entries of X are used as initial values
                   of variables.

  ALG     CHARACTER*1
          Specifies the algorithm used for solving the linear
          systems involving a Jacobian matrix J, as follows:
          = 'D' :  a direct algorithm, which computes the Cholesky
                   factor of the matrix J'*J + par*I is used;
          = 'I' :  an iterative Conjugate Gradients algorithm, which
                   only needs the matrix J, is used.
          In both cases, matrix J is stored in a compressed form.

  STOR    CHARACTER*1
          If ALG = 'D', specifies the storage scheme for the
          symmetric matrix J'*J, as follows:
          = 'F' :  full storage is used;
          = 'P' :  packed storage is used.
          The option STOR = 'F' usually ensures a faster execution.
          This parameter is not relevant if ALG = 'I'.

  UPLO    CHARACTER*1
          If ALG = 'D', specifies which part of the matrix J'*J
          is stored, as follows:
          = 'U' :  the upper triagular part is stored;
          = 'L' :  the lower triagular part is stored.
          The option UPLO = 'U' usually ensures a faster execution.
          This parameter is not relevant if ALG = 'I'.
Function Parameters 
  FCN     EXTERNAL
          Subroutine which evaluates the functions and the Jacobian.
          FCN must be declared in an external statement in the user
          calling program, and must have the following interface:

          SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1,
         $                DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, JTE,
         $                DWORK, LDWORK, INFO )

          where

          IFLAG   (input/output) INTEGER
                  On entry, this parameter must contain a value
                  defining the computations to be performed:
                  = 0 :  Optionally, print the current iterate X,
                         function values E, and Jacobian matrix J,
                         or other results defined in terms of these
                         values. See the argument NPRINT of MD03AD.
                         Do not alter E and J.
                  = 1 :  Calculate the functions at X and return
                         this vector in E. Do not alter J.
                  = 2 :  Calculate the Jacobian at X and return
                         this matrix in J. Also return J'*e in JTE
                         and NFEVL (see below). Do not alter E.
                  = 3 :  Do not compute neither the functions nor
                         the Jacobian, but return in LDJ and
                         IPAR/DPAR1,DPAR2 (some of) the integer/real
                         parameters needed.
                  On exit, the value of this parameter should not be
                  changed by FCN unless the user wants to terminate
                  execution of MD03AD, in which case IFLAG must be
                  set to a negative integer.

          M       (input) INTEGER
                  The number of functions.  M >= 0.

          N       (input) INTEGER
                  The number of variables.  M >= N >= 0.

          IPAR    (input/output) INTEGER array, dimension (LIPAR)
                  The integer parameters describing the structure of
                  the Jacobian matrix or needed for problem solving.
                  IPAR is an input parameter, except for IFLAG = 3
                  on entry, when it is also an output parameter.
                  On exit, if IFLAG = 3, IPAR(1) contains the length
                  of the array J, for storing the Jacobian matrix,
                  and the entries IPAR(2:5) contain the workspace
                  required by FCN for IFLAG = 1, FCN for IFLAG = 2,
                  JPJ for ALG = 'D', and JPJ for ALG = 'I',
                  respectively.

          LIPAR   (input) INTEGER
                  The length of the array IPAR.  LIPAR >= 5.

          DPAR1   (input/output) DOUBLE PRECISION array, dimension
                  (LDPAR1,*) or (LDPAR1)
                  A first set of real parameters needed for
                  describing or solving the problem.
                  DPAR1 can also be used as an additional array for
                  intermediate results when computing the functions
                  or the Jacobian. For control problems, DPAR1 could
                  store the input trajectory of a system.

          LDPAR1  (input) INTEGER
                  The leading dimension or the length of the array
                  DPAR1, as convenient.  LDPAR1 >= 0.  (LDPAR1 >= 1,
                  if leading dimension.)

          DPAR2   (input/output) DOUBLE PRECISION array, dimension
                  (LDPAR2,*) or (LDPAR2)
                  A second set of real parameters needed for
                  describing or solving the problem.
                  DPAR2 can also be used as an additional array for
                  intermediate results when computing the functions
                  or the Jacobian. For control problems, DPAR2 could
                  store the output trajectory of a system.

          LDPAR2  (input) INTEGER
                  The leading dimension or the length of the array
                  DPAR2, as convenient.  LDPAR2 >= 0.  (LDPAR2 >= 1,
                  if leading dimension.)

          X       (input) DOUBLE PRECISION array, dimension (N)
                  This array must contain the value of the
                  variables x where the functions or the Jacobian
                  must be evaluated.

          NFEVL   (input/output) INTEGER
                  The number of function evaluations needed to
                  compute the Jacobian by a finite difference
                  approximation.
                  NFEVL is an input parameter if IFLAG = 0, or an
                  output parameter if IFLAG = 2. If the Jacobian is
                  computed analytically, NFEVL should be set to a
                  non-positive value.

          E       (input/output) DOUBLE PRECISION array,
                  dimension (M)
                  This array contains the value of the (error)
                  functions e evaluated at X.
                  E is an input parameter if IFLAG = 0 or 2, or an
                  output parameter if IFLAG = 1.

          J       (input/output) DOUBLE PRECISION array, dimension
                  (LDJ,NC), where NC is the number of columns
                  needed.
                  This array contains a possibly compressed
                  representation of the Jacobian matrix evaluated
                  at X. If full Jacobian is stored, then NC = N.
                  J is an input parameter if IFLAG = 0, or an output
                  parameter if IFLAG = 2.

          LDJ     (input/output) INTEGER
                  The leading dimension of array J.  LDJ >= 1.
                  LDJ is essentially used inside the routines FCN
                  and JPJ.
                  LDJ is an input parameter, except for IFLAG = 3
                  on entry, when it is an output parameter.
                  It is assumed in MD03AD that LDJ is not larger
                  than needed.

          JTE     (output) DOUBLE PRECISION array, dimension (N)
                  If IFLAG = 2, the matrix-vector product J'*e.

          DWORK   DOUBLE PRECISION array, dimension (LDWORK)
                  The workspace array for subroutine FCN.
                  On exit, if INFO = 0, DWORK(1) returns the optimal
                  value of LDWORK.

          LDWORK  (input) INTEGER
                  The size of the array DWORK (as large as needed
                  in the subroutine FCN).  LDWORK >= 1.

          INFO    INTEGER
                  Error indicator, set to a negative value if an
                  input (scalar) argument is erroneous, and to
                  positive values for other possible errors in the
                  subroutine FCN. The LAPACK Library routine XERBLA
                  should be used in conjunction with negative INFO.
                  INFO must be zero if the subroutine finished
                  successfully.

          Parameters marked with "(input)" must not be changed.

  JPJ     EXTERNAL
          Subroutine which computes J'*J + par*I, if ALG = 'D', and
          J'*J*x + par*x, if ALG = 'I', where J is the Jacobian as
          described above.

          JPJ must have the following interface:

          SUBROUTINE JPJ( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR,
         $                J, LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO )

          if ALG = 'D', and

          SUBROUTINE JPJ( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X,
         $                INCX, DWORK, LDWORK, INFO )

          if ALG = 'I', where

          STOR    (input) CHARACTER*1
                  Specifies the storage scheme for the symmetric
                  matrix J'*J, as follows:
                  = 'F' :  full storage is used;
                  = 'P' :  packed storage is used.

          UPLO    (input) CHARACTER*1
                  Specifies which part of the matrix J'*J is stored,
                  as follows:
                  = 'U' :  the upper triagular part is stored;
                  = 'L' :  the lower triagular part is stored.

          N       (input) INTEGER
                  The number of columns of the matrix J.  N >= 0.

          IPAR    (input) INTEGER array, dimension (LIPAR)
                  The integer parameters describing the structure of
                  the Jacobian matrix.

          LIPAR   (input) INTEGER
                  The length of the array IPAR.  LIPAR >= 0.

          DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
                  DPAR(1) must contain an initial estimate of the
                  Levenberg-Marquardt parameter, par.  DPAR(1) >= 0.

          LDPAR   (input) INTEGER
                  The length of the array DPAR.  LDPAR >= 1.

          J       (input) DOUBLE PRECISION array, dimension
                  (LDJ, NC), where NC is the number of columns.
                  The leading NR-by-NC part of this array must
                  contain the (compressed) representation of the
                  Jacobian matrix J, where NR is the number of rows
                  of J (function of IPAR entries).

          LDJ     (input) INTEGER
                  The leading dimension of array J.
                  LDJ >= MAX(1,NR).

          JTJ     (output) DOUBLE PRECISION array,
                           dimension (LDJTJ,N),    if STOR = 'F',
                           dimension (N*(N+1)/2),  if STOR = 'P'.
                  The leading N-by-N (if STOR = 'F'), or N*(N+1)/2
                  (if STOR = 'P') part of this array contains the
                  upper or lower triangle of the matrix J'*J+par*I,
                  depending on UPLO = 'U', or UPLO = 'L',
                  respectively, stored either as a two-dimensional,
                  or one-dimensional array, depending on STOR.

          LDJTJ   (input) INTEGER
                  The leading dimension of the array JTJ.
                  LDJTJ >= MAX(1,N), if STOR = 'F'.
                  LDJTJ >= 1,        if STOR = 'P'.

          DWORK   DOUBLE PRECISION array, dimension (LDWORK)
                  The workspace array for subroutine JPJ.

          LDWORK  (input) INTEGER
                  The size of the array DWORK (as large as needed
                  in the subroutine JPJ).

          INFO    INTEGER
                  Error indicator, set to a negative value if an
                  input (scalar) argument is erroneous, and to
                  positive values for other possible errors in the
                  subroutine JPJ. The LAPACK Library routine XERBLA
                  should be used in conjunction with negative INFO
                  values. INFO must be zero if the subroutine
                  finished successfully.

          If ALG = 'I', the parameters in common with those for
          ALG = 'D', have the same meaning, and the additional
          parameters are:

          X       (input/output) DOUBLE PRECISION array, dimension
                  (1+(N-1)*INCX)
                  On entry, this incremented array must contain the
                  vector x.
                  On exit, this incremented array contains the value
                  of the matrix-vector product (J'*J + par)*x.

          INCX    (input) INTEGER
                  The increment for the elements of X.  INCX > 0.

          Parameters marked with "(input)" must not be changed.
Input/Output Parameters 
  M       (input) INTEGER
          The number of functions.  M >= 0.

  N       (input) INTEGER
          The number of variables.  M >= N >= 0.

  ITMAX   (input) INTEGER
          The maximum number of iterations.  ITMAX >= 0.

  NPRINT  (input) INTEGER
          This parameter enables controlled printing of iterates if
          it is positive. In this case, FCN is called with IFLAG = 0
          at the beginning of the first iteration and every NPRINT
          iterations thereafter and immediately prior to return,
          with X, E, and J available for printing. If NPRINT is not
          positive, no special calls of FCN with IFLAG = 0 are made.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters needed, for instance, for
          describing the structure of the Jacobian matrix, which
          are handed over to the routines FCN and JPJ.
          The first five entries of this array are modified
          internally by a call to FCN (with IFLAG = 3), but are
          restored on exit.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 5.

  DPAR1   (input/output) DOUBLE PRECISION array, dimension
          (LDPAR1,*) or (LDPAR1)
          A first set of real parameters needed for describing or
          solving the problem. This argument is not used by MD03AD
          routine, but it is passed to the routine FCN.

  LDPAR1  (input) INTEGER
          The leading dimension or the length of the array DPAR1, as
          convenient.  LDPAR1 >= 0.  (LDPAR1 >= 1, if leading
          dimension.)

  DPAR2   (input/output) DOUBLE PRECISION array, dimension
          (LDPAR2,*) or (LDPAR2)
          A second set of real parameters needed for describing or
          solving the problem. This argument is not used by MD03AD
          routine, but it is passed to the routine FCN.

  LDPAR2  (input) INTEGER
          The leading dimension or the length of the array DPAR2, as
          convenient.  LDPAR2 >= 0.  (LDPAR2 >= 1, if leading
          dimension.)

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, if XINIT = 'G', this array must contain the
          vector of initial variables x to be optimized.
          If XINIT = 'R', this array need not be set before entry,
          and random values will be used to initialize x.
          On exit, if INFO = 0, this array contains the vector of
          values that (approximately) minimize the sum of squares of
          error functions. The values returned in IWARN and
          DWORK(1:5) give details on the iterative process.

  NFEV    (output) INTEGER
          The number of calls to FCN with IFLAG = 1. If FCN is
          properly implemented, this includes the function
          evaluations needed for finite difference approximation
          of the Jacobian.

  NJEV    (output) INTEGER
          The number of calls to FCN with IFLAG = 2.
Tolerances 
  TOL     DOUBLE PRECISION
          If TOL >= 0, the tolerance which measures the relative
          error desired in the sum of squares. Termination occurs
          when the actual relative reduction in the sum of squares
          is at most TOL. If the user sets  TOL < 0, then  SQRT(EPS)
          is used instead TOL, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH).

  CGTOL   DOUBLE PRECISION
          If ALG = 'I' and CGTOL > 0, the tolerance which measures
          the relative residual of the solutions computed by the
          conjugate gradients (CG) algorithm. Termination of a
          CG process occurs when the relative residual is at
          most CGTOL. If the user sets  CGTOL <= 0, then  SQRT(EPS)
          is used instead CGTOL.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, DWORK(2) returns the residual error norm (the
          sum of squares), DWORK(3) returns the number of iterations
          performed, DWORK(4) returns the total number of conjugate
          gradients iterations performed (zero, if ALG = 'D'), and
          DWORK(5) returns the final Levenberg factor.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( 5, M + 2*N + size(J) +
                         max( DW( FCN|IFLAG = 1 ) + N,
                              DW( FCN|IFLAG = 2 ),
                              DW( sol ) ) ),
          where size(J) is the size of the Jacobian (provided by FCN
          in IPAR(1), for IFLAG = 3), DW( f ) is the workspace
          needed by the routine f, where f is FCN or JPJ (provided
          by FCN in IPAR(2:5), for IFLAG = 3), and DW( sol ) is the
          workspace needed for solving linear systems,
          DW( sol ) = N*N + DW( JPJ ),  if ALG = 'D', STOR = 'F';
          DW( sol ) = N*(N+1)/2 + DW( JPJ ),
                                        if ALG = 'D', STOR = 'P';
          DW( sol ) = 3*N + DW( JPJ ),  if ALG = 'I'.
Warning Indicator 
  IWARN   INTEGER
          < 0:  the user set IFLAG = IWARN in the subroutine FCN;
          = 0:  no warning;
          = 1:  if the iterative process did not converge in ITMAX
                iterations with tolerance TOL;
          = 2:  if ALG = 'I', and in one or more iterations of the
                Levenberg-Marquardt algorithm, the conjugate
                gradient algorithm did not finish after 3*N
                iterations, with the accuracy required in the
                call;
          = 3:  the cosine of the angle between e and any column of
                the Jacobian is at most FACTOR*EPS in absolute
                value, where FACTOR = 100 is defined in a PARAMETER
                statement;
          = 4:  TOL is too small: no further reduction in the sum
                of squares is possible.
                In all these cases, DWORK(1:5) are set as described
                above.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  user-defined routine FCN returned with INFO <> 0
                for IFLAG = 1;
          = 2:  user-defined routine FCN returned with INFO <> 0
                for IFLAG = 2;
          = 3:  SLICOT Library routine MB02XD, if ALG = 'D', or
                SLICOT Library routine MB02WD, if ALG = 'I' (or
                user-defined routine JPJ), returned with INFO <> 0.
Method 
  If XINIT = 'R', the initial value for X is set to a vector of
  pseudo-random values uniformly distributed in [-1,1].

  The Levenberg-Marquardt algorithm (described in [1]) is used for
  optimizing the parameters. This algorithm needs the Jacobian
  matrix J, which is provided by the subroutine FCN. The algorithm
  tries to update x by the formula

      x = x - p,

  using the solution of the system of linear equations

      (J'*J + PAR*I)*p = J'*e,

  where I is the identity matrix, and e the error function vector.
  The Levenberg factor PAR is decreased after each successfull step
  and increased in the other case.

  If ALG = 'D', a direct method, which evaluates the matrix product
  J'*J + par*I and then factors it using Cholesky algorithm,
  implemented in the SLICOT Libray routine MB02XD, is used for
  solving the linear system above.

  If ALG = 'I', the Conjugate Gradients method, described in [2],
  and implemented in the SLICOT Libray routine MB02WD, is used for
  solving the linear system above. The main advantage of this method
  is that in most cases the solution of the system can be computed
  in less time than the time needed to compute the matrix J'*J
  This is, however, problem dependent.
References 
  [1] Kelley, C.T.
      Iterative Methods for Optimization.
      Society for Industrial and Applied Mathematics (SIAM),
      Philadelphia (Pa.), 1999.

  [2] Golub, G.H. and van Loan, C.F.
      Matrix Computations. Third Edition.
      M. D. Johns Hopkins University Press, Baltimore, pp. 520-528,
      1996.

  [3] More, J.J.
      The Levenberg-Marquardt algorithm: implementation and theory.
      In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in
      Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg
      and New York, pp. 105-116, 1978.
Numerical Aspects 
  The Levenberg-Marquardt algorithm described in [3] is scaling
  invariant and globally convergent to (maybe local) minima.
  According to [1], the convergence rate near a local minimum is
  quadratic, if the Jacobian is computed analytically, and linear,
  if the Jacobian is computed numerically.

  Whether or not the direct algorithm is faster than the iterative
  Conjugate Gradients algorithm for solving the linear systems
  involved depends on several factors, including the conditioning
  of the Jacobian matrix, and the ratio between its dimensions.
Further Comments 
  None
Example

Program Text 

*     MD03AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           MMAX, NMAX
      PARAMETER         ( MMAX = 20, NMAX = 20 )
      INTEGER           LDWORK
      PARAMETER         ( LDWORK = MMAX + 2*NMAX + MMAX*NMAX +
     $                             MAX( NMAX*NMAX, 3*NMAX + MMAX ) )
*     .. The lengths of DPAR1, DPAR2, IPAR are set to 1, 1, and 5 ..
      INTEGER           LDPAR1, LDPAR2, LIPAR
      PARAMETER         ( LDPAR1 = 1, LDPAR2 = 1, LIPAR = 5 )
*     .. Local Scalars ..
      CHARACTER*1       ALG, STOR, UPLO, XINIT
      INTEGER           I, INFO, ITMAX, IWARN, M, N, NFEV, NJEV, NPRINT
      DOUBLE PRECISION  CGTOL, TOL
*     .. Array Arguments ..
      INTEGER           IPAR(LIPAR)
      DOUBLE PRECISION  DPAR1(LDPAR1), DPAR2(LDPAR2), DWORK(LDWORK),
     $                  X(NMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          MD03AD, MD03AF, NF01BV, NF01BX
*     .. Intrinsic Functions ..
      INTRINSIC         MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, ITMAX, NPRINT, TOL, CGTOL, XINIT,
     $                      ALG, STOR, UPLO
      IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE
         IF( N.LE.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) N
         ELSE
            IF ( LSAME( XINIT, 'G' ) )
     $         READ ( NIN, FMT = * ) ( X(I), I = 1,N )
*           Solve a standard nonlinear least squares problem.
            IPAR(1) = M
            IF ( LSAME( ALG, 'D' ) ) THEN
               CALL MD03AD( XINIT, ALG, STOR, UPLO, MD03AF, NF01BV, M,
     $                      N, ITMAX, NPRINT, IPAR, LIPAR, DPAR1,
     $                      LDPAR1, DPAR2, LDPAR2, X, NFEV, NJEV, TOL,
     $                      CGTOL, DWORK, LDWORK, IWARN, INFO )
            ELSE
               CALL MD03AD( XINIT, ALG, STOR, UPLO, MD03AF, NF01BX, M,
     $                      N, ITMAX, NPRINT, IPAR, LIPAR, DPAR1,
     $                      LDPAR1, DPAR2, LDPAR2, X, NFEV, NJEV, TOL,
     $                      CGTOL, DWORK, LDWORK, IWARN, INFO )
            END IF
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99991 ) IWARN
               WRITE ( NOUT, FMT = 99997 ) DWORK(2)
               WRITE ( NOUT, FMT = 99996 ) NFEV, NJEV
               WRITE ( NOUT, FMT = 99994 )
               WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, N )
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MD03AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MD03AD = ',I2)
99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7)
99996 FORMAT (/' The number of function and Jacobian evaluations = ',
     $           2I7)
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' Final approximate solution is ' )
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (' IWARN on exit from MD03AD = ',I2)
      END
C
      SUBROUTINE MD03AF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $                   LDPAR2, X, NFEVL, E, J, LDJ, JTE, DWORK,
     $                   LDWORK, INFO )
C
C     This is the FCN routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03AD. See the
C     argument FCN in the routine MD03AD 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  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, 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,*),
     $                  JTE(*), X(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  ERR, TMP1, TMP2, TMP3, TMP4
C     .. External Functions ..
      DOUBLE PRECISION  DNRM2
      EXTERNAL          DNRM2
C     .. External Subroutines ..
      EXTERNAL          DGEMV
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, e.
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
C        Compute the product J'*e (the error e was computed in array E).
C
         CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, E, 1, ZERO, JTE,
     $               1 )
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 MD03AF (IFLAG = 1 or 2), NF01BV and
C        NF01BX.
C
         LDJ = M
         IPAR(1) = M*N
         IPAR(2) = 0
         IPAR(3) = 0
         IPAR(4) = M
      ELSE IF ( IFLAG.EQ.0 ) THEN
C
C        Special call for printing intermediate results.
C
         ERR = DNRM2( M, E, 1 )
         WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR
C
      END IF
C
      DWORK(1) = ZERO
      RETURN
C
C *** Last line of MD03AF ***
      END
Program Data 
 MD03AD EXAMPLE PROGRAM DATA
 15     3   100     0   -1.   -1.    G     D     F    U
   1.0   1.0   1.0
Program Results 
 MD03AD EXAMPLE PROGRAM RESULTS


 Final 2-norm of the residuals =   0.9063596D-01

 The number of function and Jacobian evaluations =      13     12

 Final approximate solution is 
   0.0824   1.1330   2.3437

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MD03BD.html000077500000000000000000001240201201767322700160540ustar00rootroot00000000000000 MD03BD - SLICOT Library Routine Documentation

MD03BD

Solution of a standard nonlinear least squares problem

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To minimize the sum of the squares of m nonlinear functions, e, in
  n variables, x, by a modification of the Levenberg-Marquardt
  algorithm. The user must provide a subroutine FCN which calculates
  the functions and the Jacobian (possibly by finite differences).
  In addition, specialized subroutines QRFACT, for QR factorization
  with pivoting of the Jacobian, and LMPARM, for the computation of
  Levenberg-Marquardt parameter, exploiting the possible structure
  of the Jacobian matrix, should be provided. Template
  implementations of these routines are included in SLICOT Library.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  XINIT   CHARACTER*1
          Specifies how the variables x are initialized, as follows:
          = 'R' :  the array X is initialized to random values; the
                   entries DWORK(1:4) are used to initialize the
                   random number generator: the first three values
                   are converted to integers between 0 and 4095, and
                   the last one is converted to an odd integer
                   between 1 and 4095;
          = 'G' :  the given entries of X are used as initial values
                   of variables.

  SCALE   CHARACTER*1
          Specifies how the variables will be scaled, as follows:
          = 'I' :  use internal scaling;
          = 'S' :  use specified scaling factors, given in DIAG.

  COND    CHARACTER*1
          Specifies whether the condition of the linear systems
          involved should be estimated, as follows:
          = 'E' :  use incremental condition estimation to find the
                   numerical rank;
          = 'N' :  do not use condition estimation, but check the
                   diagonal entries of matrices for zero values.
Function Parameters 
  FCN     EXTERNAL
          Subroutine which evaluates the functions and the Jacobian.
          FCN must be declared in an external statement in the user
          calling program, and must have the following interface:

          SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1,
         $                DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, DWORK,
         $                LDWORK, INFO )

          where

          IFLAG   (input/output) INTEGER
                  On entry, this parameter must contain a value
                  defining the computations to be performed:
                  = 0 :  Optionally, print the current iterate X,
                         function values E, and Jacobian matrix J,
                         or other results defined in terms of these
                         values. See the argument NPRINT of MD03BD.
                         Do not alter E and J.
                  = 1 :  Calculate the functions at X and return
                         this vector in E. Do not alter J.
                  = 2 :  Calculate the Jacobian at X and return
                         this matrix in J. Also return NFEVL
                         (see below). Do not alter E.
                  = 3 :  Do not compute neither the functions nor
                         the Jacobian, but return in LDJ and
                         IPAR/DPAR1,DPAR2 (some of) the integer/real
                         parameters needed.
                  On exit, the value of this parameter should not be
                  changed by FCN unless the user wants to terminate
                  execution of MD03BD, in which case IFLAG must be
                  set to a negative integer.

          M       (input) INTEGER
                  The number of functions.  M >= 0.

          N       (input) INTEGER
                  The number of variables.  M >= N >= 0.

          IPAR    (input/output) INTEGER array, dimension (LIPAR)
                  The integer parameters describing the structure of
                  the Jacobian matrix or needed for problem solving.
                  IPAR is an input parameter, except for IFLAG = 3
                  on entry, when it is also an output parameter.
                  On exit, if IFLAG = 3, IPAR(1) contains the length
                  of the array J, for storing the Jacobian matrix,
                  and the entries IPAR(2:5) contain the workspace
                  required by FCN for IFLAG = 1, FCN for IFLAG = 2,
                  QRFACT, and LMPARM, respectively.

          LIPAR   (input) INTEGER
                  The length of the array IPAR.  LIPAR >= 5.

          DPAR1   (input/output) DOUBLE PRECISION array, dimension
                  (LDPAR1,*) or (LDPAR1)
                  A first set of real parameters needed for
                  describing or solving the problem.
                  DPAR1 can also be used as an additional array for
                  intermediate results when computing the functions
                  or the Jacobian. For control problems, DPAR1 could
                  store the input trajectory of a system.

          LDPAR1  (input) INTEGER
                  The leading dimension or the length of the array
                  DPAR1, as convenient.  LDPAR1 >= 0.  (LDPAR1 >= 1,
                  if leading dimension.)

          DPAR2   (input/output) DOUBLE PRECISION array, dimension
                  (LDPAR2,*) or (LDPAR2)
                  A second set of real parameters needed for
                  describing or solving the problem.
                  DPAR2 can also be used as an additional array for
                  intermediate results when computing the functions
                  or the Jacobian. For control problems, DPAR2 could
                  store the output trajectory of a system.

          LDPAR2  (input) INTEGER
                  The leading dimension or the length of the array
                  DPAR2, as convenient.  LDPAR2 >= 0.  (LDPAR2 >= 1,
                  if leading dimension.)

          X       (input) DOUBLE PRECISION array, dimension (N)
                  This array must contain the value of the
                  variables x where the functions or the Jacobian
                  must be evaluated.

          NFEVL   (input/output) INTEGER
                  The number of function evaluations needed to
                  compute the Jacobian by a finite difference
                  approximation.
                  NFEVL is an input parameter if IFLAG = 0, or an
                  output parameter if IFLAG = 2. If the Jacobian is
                  computed analytically, NFEVL should be set to a
                  non-positive value.

          E       (input/output) DOUBLE PRECISION array,
                  dimension (M)
                  This array contains the value of the (error)
                  functions e evaluated at X.
                  E is an input parameter if IFLAG = 0 or 2, or an
                  output parameter if IFLAG = 1.

          J       (input/output) DOUBLE PRECISION array, dimension
                  (LDJ,NC), where NC is the number of columns
                  needed.
                  This array contains a possibly compressed
                  representation of the Jacobian matrix evaluated
                  at X. If full Jacobian is stored, then NC = N.
                  J is an input parameter if IFLAG = 0, or an output
                  parameter if IFLAG = 2.

          LDJ     (input/output) INTEGER
                  The leading dimension of array J.  LDJ >= 1.
                  LDJ is essentially used inside the routines FCN,
                  QRFACT and LMPARM.
                  LDJ is an input parameter, except for IFLAG = 3
                  on entry, when it is an output parameter.
                  It is assumed in MD03BD that LDJ is not larger
                  than needed.

          DWORK   DOUBLE PRECISION array, dimension (LDWORK)
                  The workspace array for subroutine FCN.
                  On exit, if INFO = 0, DWORK(1) returns the optimal
                  value of LDWORK.

          LDWORK  (input) INTEGER
                  The size of the array DWORK (as large as needed
                  in the subroutine FCN).  LDWORK >= 1.

          INFO    INTEGER
                  Error indicator, set to a negative value if an
                  input (scalar) argument is erroneous, and to
                  positive values for other possible errors in the
                  subroutine FCN. The LAPACK Library routine XERBLA
                  should be used in conjunction with negative INFO.
                  INFO must be zero if the subroutine finished
                  successfully.

          Parameters marked with "(input)" must not be changed.

  QRFACT  EXTERNAL
          Subroutine which computes the QR factorization with
          (block) column pivoting of the Jacobian matrix, J*P = Q*R.
          QRFACT must be declared in an external statement in the
          calling program, and must have the following interface:

          SUBROUTINE QRFACT( N, IPAR, LIPAR, FNORM, J, LDJ, E,
         $                   JNORMS, GNORM, IPVT, DWORK, LDWORK,
         $                   INFO )

          where

          N       (input) INTEGER
                  The number of columns of the Jacobian matrix J.
                  N >= 0.

          IPAR    (input) INTEGER array, dimension (LIPAR)
                  The integer parameters describing the structure of
                  the Jacobian matrix.

          LIPAR   (input) INTEGER
                  The length of the array IPAR.  LIPAR >= 0.

          FNORM   (input) DOUBLE PRECISION
                  The Euclidean norm of the vector e.  FNORM >= 0.

          J       (input/output) DOUBLE PRECISION array, dimension
                  (LDJ, NC), where NC is the number of columns.
                  On entry, the leading NR-by-NC part of this array
                  must contain the (compressed) representation
                  of the Jacobian matrix J, where NR is the number
                  of rows of J (function of IPAR entries).
                  On exit, the leading N-by-NC part of this array
                  contains a (compressed) representation of the
                  upper triangular factor R of the Jacobian matrix.
                  For efficiency of the later calculations, the
                  matrix R is delivered with the leading dimension
                  MAX(1,N), possibly much smaller than the value
                  of LDJ on entry.

          LDJ     (input/output) INTEGER
                  The leading dimension of array J.
                  On entry, LDJ >= MAX(1,NR).
                  On exit,  LDJ >= MAX(1,N).

          E       (input/output) DOUBLE PRECISION array, dimension
                  (NR)
                  On entry, this array contains the error vector e.
                  On exit, this array contains the updated vector
                  Z*Q'*e, where Z is a block row permutation matrix
                  (possibly identity) used in the QR factorization
                  of J. (See, for example, the SLICOT Library
                  routine NF01BS, Section METHOD.)

          JNORMS  (output) DOUBLE PRECISION array, dimension (N)
                  This array contains the Euclidean norms of the
                  columns of the Jacobian matrix (in the original
                  order).

          GNORM   (output) DOUBLE PRECISION
                  If FNORM > 0, the 1-norm of the scaled vector
                  J'*e/FNORM, with each element i further divided
                  by JNORMS(i) (if JNORMS(i) is nonzero).
                  If FNORM = 0, the returned value of GNORM is 0.

          IPVT    (output) INTEGER array, dimension (N)
                  This array defines the permutation matrix P such
                  that J*P = Q*R. Column j of P is column IPVT(j) of
                  the identity matrix.

          DWORK   DOUBLE PRECISION array, dimension (LDWORK)
                  The workspace array for subroutine QRFACT.
                  On exit, if INFO = 0, DWORK(1) returns the optimal
                  value of LDWORK.

          LDWORK  (input) INTEGER
                  The size of the array DWORK (as large as needed
                  in the subroutine QRFACT).  LDWORK >= 1.

          INFO    INTEGER
                  Error indicator, set to a negative value if an
                  input (scalar) argument is erroneous, and to
                  positive values for other possible errors in the
                  subroutine QRFACT. The LAPACK Library routine
                  XERBLA should be used in conjunction with negative
                  INFO. INFO must be zero if the subroutine finished
                  successfully.

          Parameters marked with "(input)" must not be changed.

  LMPARM  EXTERNAL
          Subroutine which determines a value for the Levenberg-
          Marquardt parameter PAR such that if x solves the system

                J*x = b ,     sqrt(PAR)*D*x = 0 ,

          in the least squares sense, where J is an m-by-n matrix,
          D is an n-by-n nonsingular diagonal matrix, and b is an
          m-vector, and if DELTA is a positive number, DXNORM is
          the Euclidean norm of D*x, then either PAR is zero and

                ( DXNORM - DELTA ) .LE. 0.1*DELTA ,

          or PAR is positive and

                ABS( DXNORM - DELTA ) .LE. 0.1*DELTA .

          It is assumed that a block QR factorization, with column
          pivoting, of J is available, that is, J*P = Q*R, where P
          is a permutation matrix, Q has orthogonal columns, and
          R is an upper triangular matrix (possibly stored in a
          compressed form), with diagonal elements of nonincreasing
          magnitude for each block. On output, LMPARM also provides
          a (compressed) representation of an upper triangular
          matrix S, such that

                P'*(J'*J + PAR*D*D)*P = S'*S .

          LMPARM must be declared in an external statement in the
          calling program, and must have the following interface:

          SUBROUTINE LMPARM( COND, N, IPAR, LIPAR, R, LDR, IPVT,
         $                   DIAG, QTB, DELTA, PAR, RANKS, X, RX,
         $                   TOL, DWORK, LDWORK, INFO )

          where

          COND    CHARACTER*1
                  Specifies whether the condition of the linear
                  systems involved should be estimated, as follows:
                  = 'E' :  use incremental condition estimation
                           to find the numerical rank;
                  = 'N' :  do not use condition estimation, but
                           check the diagonal entries for zero
                           values;
                  = 'U' :  use the ranks already stored in RANKS
                           (for R).

          N       (input) INTEGER
                  The order of the matrix R.  N >= 0.

          IPAR    (input) INTEGER array, dimension (LIPAR)
                  The integer parameters describing the structure of
                  the Jacobian matrix.

          LIPAR   (input) INTEGER
                  The length of the array IPAR.  LIPAR >= 0.

          R       (input/output) DOUBLE PRECISION array, dimension
                  (LDR, NC), where NC is the number of columns.
                  On entry, the leading N-by-NC part of this array
                  must contain the (compressed) representation (Rc)
                  of the upper triangular matrix R.
                  On exit, the full upper triangular part of R
                  (in representation Rc), is unaltered, and the
                  remaining part contains (part of) the (compressed)
                  representation of the transpose of the upper
                  triangular matrix S.

          LDR     (input) INTEGER
                  The leading dimension of array R.
                  LDR >= MAX(1,N).

          IPVT    (input) INTEGER array, dimension (N)
                  This array must define the permutation matrix P
                  such that J*P = Q*R. Column j of P is column
                  IPVT(j) of the identity matrix.

          DIAG    (input) DOUBLE PRECISION array, dimension (N)
                  This array must contain the diagonal elements of
                  the matrix D.  DIAG(I) <> 0, I = 1,...,N.

          QTB     (input) DOUBLE PRECISION array, dimension (N)
                  This array must contain the first n elements of
                  the vector Q'*b.

          DELTA   (input) DOUBLE PRECISION
                  An upper bound on the Euclidean norm of D*x.
                  DELTA > 0.

          PAR     (input/output) DOUBLE PRECISION
                  On entry, PAR must contain an initial estimate of
                  the Levenberg-Marquardt parameter.  PAR >= 0.
                  On exit, it contains the final estimate of this
                  parameter.

          RANKS   (input or output) INTEGER array, dimension (r),
                  where r is the number of diagonal blocks R_k in R,
                  corresponding to the block column structure of J.
                  On entry, if COND = 'U' and N > 0, this array must
                  contain the numerical ranks of the submatrices
                  R_k, k = 1:r. The number r is defined in terms of
                  the entries of IPAR.
                  On exit, if N > 0, this array contains the
                  numerical ranks of the submatrices S_k, k = 1:r.

          X       (output) DOUBLE PRECISION array, dimension (N)
                  This array contains the least squares solution of
                  the system J*x = b, sqrt(PAR)*D*x = 0.

          RX      (output) DOUBLE PRECISION array, dimension (N)
                  This array contains the matrix-vector product
                  -R*P'*x.

          TOL     (input) DOUBLE PRECISION
                  If COND = 'E', the tolerance to be used for
                  finding the ranks of the submatrices R_k and S_k.
                  If the user sets TOL > 0, then the given value of
                  TOL is used as a lower bound for the reciprocal
                  condition number;  a (sub)matrix whose estimated
                  condition number is less than 1/TOL is considered
                  to be of full rank.  If the user sets TOL <= 0,
                  then an implicitly computed, default tolerance,
                  defined by TOLDEF = N*EPS,  is used instead,
                  where EPS is the machine precision (see LAPACK
                  Library routine DLAMCH).
                  This parameter is not relevant if COND = 'U'
                  or 'N'.

          DWORK   DOUBLE PRECISION array, dimension (LDWORK)
                  The workspace array for subroutine LMPARM.
                  On exit, if INFO = 0, DWORK(1) returns the optimal
                  value of LDWORK.

          LDWORK  (input) INTEGER
                  The size of the array DWORK (as large as needed
                  in the subroutine LMPARM).  LDWORK >= 1.

          INFO    INTEGER
                  Error indicator, set to a negative value if an
                  input (scalar) argument is erroneous, and to
                  positive values for other possible errors in the
                  subroutine LMPARM. The LAPACK Library routine
                  XERBLA should be used in conjunction with negative
                  INFO. INFO must be zero if the subroutine finished
                  successfully.

          Parameters marked with "(input)" must not be changed.
Input/Output Parameters 
  M       (input) INTEGER
          The number of functions.  M >= 0.

  N       (input) INTEGER
          The number of variables.  M >= N >= 0.

  ITMAX   (input) INTEGER
          The maximum number of iterations.  ITMAX >= 0.

  FACTOR  (input) DOUBLE PRECISION
          The value used in determining the initial step bound. This
          bound is set to the product of FACTOR and the Euclidean
          norm of DIAG*X if nonzero, or else to FACTOR itself.
          In most cases FACTOR should lie in the interval (.1,100).
          A generally recommended value is 100.  FACTOR > 0.

  NPRINT  (input) INTEGER
          This parameter enables controlled printing of iterates if
          it is positive. In this case, FCN is called with IFLAG = 0
          at the beginning of the first iteration and every NPRINT
          iterations thereafter and immediately prior to return,
          with X, E, and J available for printing. Note that when
          called immediately prior to return, J normally contains
          the result returned by QRFACT and LMPARM (the compressed
          R and S factors). If NPRINT is not positive, no special
          calls of FCN with IFLAG = 0 are made.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters needed, for instance, for
          describing the structure of the Jacobian matrix, which
          are handed over to the routines FCN, QRFACT and LMPARM.
          The first five entries of this array are modified
          internally by a call to FCN (with IFLAG = 3), but are
          restored on exit.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 5.

  DPAR1   (input/output) DOUBLE PRECISION array, dimension
          (LDPAR1,*) or (LDPAR1)
          A first set of real parameters needed for describing or
          solving the problem. This argument is not used by MD03BD
          routine, but it is passed to the routine FCN.

  LDPAR1  (input) INTEGER
          The leading dimension or the length of the array DPAR1, as
          convenient.  LDPAR1 >= 0.  (LDPAR1 >= 1, if leading
          dimension.)

  DPAR2   (input/output) DOUBLE PRECISION array, dimension
          (LDPAR2,*) or (LDPAR2)
          A second set of real parameters needed for describing or
          solving the problem. This argument is not used by MD03BD
          routine, but it is passed to the routine FCN.

  LDPAR2  (input) INTEGER
          The leading dimension or the length of the array DPAR2, as
          convenient.  LDPAR2 >= 0.  (LDPAR2 >= 1, if leading
          dimension.)

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, if XINIT = 'G', this array must contain the
          vector of initial variables x to be optimized.
          If XINIT = 'R', this array need not be set before entry,
          and random values will be used to initialize x.
          On exit, if INFO = 0, this array contains the vector of
          values that (approximately) minimize the sum of squares of
          error functions. The values returned in IWARN and
          DWORK(1:4) give details on the iterative process.

  DIAG    (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, if SCALE = 'S', this array must contain some
          positive entries that serve as multiplicative scale
          factors for the variables x.  DIAG(I) > 0, I = 1,...,N.
          If SCALE = 'I', DIAG is internally set.
          On exit, this array contains the scale factors used
          (or finally used, if SCALE = 'I').

  NFEV    (output) INTEGER
          The number of calls to FCN with IFLAG = 1. If FCN is
          properly implemented, this includes the function
          evaluations needed for finite difference approximation
          of the Jacobian.

  NJEV    (output) INTEGER
          The number of calls to FCN with IFLAG = 2.
Tolerances 
  FTOL    DOUBLE PRECISION
          If FTOL >= 0, the tolerance which measures the relative
          error desired in the sum of squares. Termination occurs
          when both the actual and predicted relative reductions in
          the sum of squares are at most FTOL. If the user sets
          FTOL < 0,  then  SQRT(EPS)  is used instead FTOL, where
          EPS is the machine precision (see LAPACK Library routine
          DLAMCH).

  XTOL    DOUBLE PRECISION
          If XTOL >= 0, the tolerance which measures the relative
          error desired in the approximate solution. Termination
          occurs when the relative error between two consecutive
          iterates is at most XTOL. If the user sets  XTOL < 0,
          then  SQRT(EPS)  is used instead XTOL.

  GTOL    DOUBLE PRECISION
          If GTOL >= 0, the tolerance which measures the
          orthogonality desired between the function vector e and
          the columns of the Jacobian J. Termination occurs when
          the cosine of the angle between e and any column of the
          Jacobian J is at most GTOL in absolute value. If the user
          sets  GTOL < 0,  then  EPS  is used instead GTOL.

  TOL     DOUBLE PRECISION
          If COND = 'E', the tolerance to be used for finding the
          ranks of the matrices of linear systems to be solved. If
          the user sets TOL > 0, then the given value of TOL is used
          as a lower bound for the reciprocal condition number;  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*EPS,  is used instead.
          This parameter is not relevant if COND = 'N'.
Workspace 
  IWORK   INTEGER array, dimension (N+r), where r is the number
          of diagonal blocks R_k in R (see description of LMPARM).
          On output, if INFO = 0, the first N entries of this array
          define a permutation matrix P such that J*P = Q*R, where
          J is the final calculated Jacobian, Q is an orthogonal
          matrix (not stored), and R is upper triangular with
          diagonal elements of nonincreasing magnitude (possibly
          for each block column of J). Column j of P is column
          IWORK(j) of the identity matrix. If INFO = 0, the entries
          N+1:N+r of this array contain the ranks of the final
          submatrices S_k (see description of LMPARM).

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, DWORK(2) returns the residual error norm (the
          sum of squares), DWORK(3) returns the number of iterations
          performed, and DWORK(4) returns the final Levenberg
          factor. If INFO = 0, N > 0, and IWARN >= 0, the elements
          DWORK(5) to DWORK(4+M) contain the final matrix-vector
          product Z*Q'*e, and the elements DWORK(5+M) to
          DWORK(4+M+N*NC) contain the (compressed) representation of
          final upper triangular matrices R and S (if IWARN <> 4).

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max( 4, M + max( size(J) +
                                     max( DW( FCN|IFLAG = 1 ),
                                          DW( FCN|IFLAG = 2 ),
                                          DW( QRFACT ) + N ),
                                     N*NC + N +
                                     max( M + DW( FCN|IFLAG = 1 ),
                                          N + DW( LMPARM ) ) ) ),
          where size(J) is the size of the Jacobian (provided by FCN
          in IPAR(1), for IFLAG = 3), and DW( f ) is the workspace
          needed by the routine f, where f is FCN, QRFACT, or LMPARM
          (provided by FCN in IPAR(2:5), for IFLAG = 3).
Warning Indicator 
  IWARN   INTEGER
          < 0:  the user set IFLAG = IWARN in the subroutine FCN;
          = 1:  both actual and predicted relative reductions in
                the sum of squares are at most FTOL;
          = 2:  relative error between two consecutive iterates is
                at most XTOL;
          = 3:  conditions for IWARN = 1 and IWARN = 2 both hold;
          = 4:  the cosine of the angle between e and any column of
                the Jacobian is at most GTOL in absolute value;
          = 5:  the number of iterations has reached ITMAX without
                satisfying any convergence condition;
          = 6:  FTOL is too small: no further reduction in the sum
                of squares is possible;
          = 7:  XTOL is too small: no further improvement in the
                approximate solution x is possible;
          = 8:  GTOL is too small: e is orthogonal to the columns of
                the Jacobian to machine precision.
          In all these cases, DWORK(1:4) are set as described above.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  user-defined routine FCN returned with INFO <> 0
                for IFLAG = 1;
          = 2:  user-defined routine FCN returned with INFO <> 0
                for IFLAG = 2;
          = 3:  user-defined routine QRFACT returned with INFO <> 0;
          = 4:  user-defined routine LMPARM returned with INFO <> 0.
Method 
  If XINIT = 'R', the initial value for x is set to a vector of
  pseudo-random values uniformly distributed in (-1,1).

  The Levenberg-Marquardt algorithm (described in [1,3]) is used for
  optimizing the variables x. This algorithm needs the Jacobian
  matrix J, which is provided by the subroutine FCN. A trust region
  method is used. The algorithm tries to update x by the formula

      x = x - p,

  using an approximate solution of the system of linear equations

      (J'*J + PAR*D*D)*p = J'*e,

  with e the error function vector, and D a diagonal nonsingular
  matrix, where either PAR = 0 and

      ( norm( D*x ) - DELTA ) <= 0.1*DELTA ,

  or PAR > 0 and

      ABS( norm( D*x ) - DELTA ) <= 0.1*DELTA .

  DELTA is the radius of the trust region. If the Gauss-Newton
  direction is not acceptable, then an iterative algorithm obtains
  improved lower and upper bounds for the Levenberg-Marquardt
  parameter PAR. Only a few iterations are generally needed for
  convergence of the algorithm. The trust region radius DELTA
  and the Levenberg factor PAR are updated based on the ratio
  between the actual and predicted reduction in the sum of squares.
References 
  [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
      User's Guide for MINPACK-1.
      Applied Math. Division, Argonne National Laboratory, Argonne,
      Illinois, Report ANL-80-74, 1980.

  [2] Golub, G.H. and van Loan, C.F.
      Matrix Computations. Third Edition.
      M. D. Johns Hopkins University Press, Baltimore, pp. 520-528,
      1996.

  [3] More, J.J.
      The Levenberg-Marquardt algorithm: implementation and theory.
      In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in
      Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg
      and New York, pp. 105-116, 1978.
Numerical Aspects 
  The Levenberg-Marquardt algorithm described in [3] is scaling
  invariant and globally convergent to (maybe local) minima.
  The convergence rate near a local minimum is quadratic, if the
  Jacobian is computed analytically, and linear, if the Jacobian
  is computed numerically.
Further Comments 
  This routine is a more general version of the subroutines LMDER
  and LMDER1 from the MINPACK package [1], which enables to exploit
  the structure of the problem, and optionally use condition
  estimation. Unstructured problems could be solved as well.

  Template SLICOT Library implementations for FCN, QRFACT and
  LMPARM routines are:
  MD03BF, MD03BA, and MD03BB, respectively, for standard problems;
  NF01BF, NF01BS, and NF01BP, respectively, for optimizing the
  parameters of Wiener systems (structured problems).
Example

Program Text 

*     MD03BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           MMAX, NMAX
      PARAMETER         ( MMAX = 20, NMAX = 20 )
      INTEGER           LDWORK
      PARAMETER         ( LDWORK = MMAX +
     $                             MAX( MMAX*NMAX + 5*NMAX + 1,
     $                                  NMAX*NMAX + NMAX +
     $                                  MAX( MMAX, 5*NMAX ) ) )
*     .. Local Scalars ..
      CHARACTER*1       COND, SCALE, XINIT
      INTEGER           I, INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LIPAR, M,
     $                  N, NFEV, NJEV, NPRINT
      DOUBLE PRECISION  FACTOR, FTOL, GTOL, TOL, XTOL
*     .. Array Arguments ..
      INTEGER           IPAR(5), IWORK(NMAX+1)
      DOUBLE PRECISION  DIAG(NMAX), DPAR1(1), DPAR2(1), DWORK(LDWORK),
     $                  X(NMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          MD03BA, MD03BB, MD03BD, MD03BF
*     .. Intrinsic Functions ..
      INTRINSIC         MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, ITMAX, LIPAR, LDPAR1, LDPAR2, FACTOR,
     $                      NPRINT, FTOL, XTOL, GTOL, TOL, XINIT, SCALE,
     $                      COND
      IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE
         IF( N.LE.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) N
         ELSE
            IF ( LSAME( SCALE, 'S' ) )
     $         READ ( NIN, FMT = * ) ( DIAG(I), I = 1,N )
            IF ( LSAME( XINIT, 'G' ) )
     $         READ ( NIN, FMT = * ) ( X(I), I = 1,N )
*           Solve a standard nonlinear least squares problem.
            IPAR(1) = M
            CALL MD03BD( XINIT, SCALE, COND, MD03BF, MD03BA, MD03BB,
     $                   M, N, ITMAX, FACTOR, NPRINT, IPAR, LIPAR,
     $                   DPAR1, LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV,
     $                   NJEV, FTOL, XTOL, GTOL, TOL, IWORK, DWORK,
     $                   LDWORK, IWARN, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99991 ) IWARN
               WRITE ( NOUT, FMT = 99997 ) DWORK(2)
               WRITE ( NOUT, FMT = 99996 ) NFEV, NJEV
               WRITE ( NOUT, FMT = 99994 )
               WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, N )
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MD03BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MD03BD = ',I2)
99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7)
99996 FORMAT (/' The number of function and Jacobian evaluations = ',
     $           2I7)
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' Final approximate solution is ' )
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (' IWARN on exit from MD03BD = ',I2)
      END
C
      SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $                   LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK,
     $                   INFO )
C
C     This is the FCN routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03BD. See the
C     argument 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     .. External Subroutines ..
      EXTERNAL          MD03BA, MD03BB
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 MD03BF (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
      ELSE IF ( IFLAG.EQ.0 ) THEN
C
C        Special call for printing intermediate results.
C
         ERR = DNRM2( M, E, 1 )
         WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR
C
      END IF
C
      RETURN
C
C *** Last line of MD03BF ***
      END
C
      SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS,
     $                   GNORM, IPVT, DWORK, LDWORK, INFO )
C
C     This is the QRFACT routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03BD. See the
C     argument QRFACT in the routine MD03BD for the description of
C     parameters.
C
C     For efficiency, the arguments are not checked. This is done in
C     the routine MD03BX (except for LIPAR).
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(LDJ,*), 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
C
      SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB,
     $                   DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK,
     $                   INFO )
C
C     This is the LMPARM routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03BD. See the
C     argument LMPARM in the routine MD03BD for the description of
C     parameters.
C
C     For efficiency, the arguments are not checked. This is done in
C     the routine MD03BY (except for LIPAR).
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
Program Data 
 MD03BD EXAMPLE PROGRAM DATA
 15     3   100     5     0     0   1.D2     0   -1.   -1.   -1.   -1.     G     I     E
   1.0   1.0   1.0
Program Results 
 MD03BD EXAMPLE PROGRAM RESULTS

 IWARN on exit from MD03BD =  1

 Final 2-norm of the residuals =   0.9063596D-01

 The number of function and Jacobian evaluations =       6      5

 Final approximate solution is 
   0.0824   1.1330   2.3437

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/MD03BX.html000077500000000000000000000107171201767322700161070ustar00rootroot00000000000000 MD03BX - SLICOT Library Routine Documentation

MD03BX

QR factorization with column pivoting for a standard nonlinear least squares problem

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the QR factorization with column pivoting of an
  m-by-n matrix J (m >= n), that is, J*P = Q*R, where Q is a matrix
  with orthogonal columns, P a permutation matrix, and R an upper
  trapezoidal matrix with diagonal elements of nonincreasing
  magnitude, and to apply the transformation Q' on the error
  vector e (in-situ). The 1-norm of the scaled gradient is also
  returned. The matrix J could be the Jacobian of a nonlinear least
  squares problem.
Specification 
      SUBROUTINE MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDJ, LDWORK, M, N
      DOUBLE PRECISION  FNORM, GNORM
C     .. Array Arguments ..
      INTEGER           IPVT(*)
      DOUBLE PRECISION  DWORK(*), E(*), J(*), JNORMS(*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the Jacobian matrix J.  M >= 0.

  N       (input) INTEGER
          The number of columns of the Jacobian matrix J.
          M >= N >= 0.

  FNORM   (input) DOUBLE PRECISION
          The Euclidean norm of the vector e.  FNORM >= 0.

  J       (input/output) DOUBLE PRECISION array, dimension (LDJ, N)
          On entry, the leading M-by-N part of this array must
          contain the Jacobian matrix J.
          On exit, the leading N-by-N upper triangular part of this
          array contains the upper triangular factor R of the
          Jacobian matrix. Note that for efficiency of the later
          calculations, the matrix R is delivered with the leading
          dimension MAX(1,N), possibly much smaller than the value
          of LDJ on entry.

  LDJ     (input/output) INTEGER
          The leading dimension of array J.
          On entry, LDJ >= MAX(1,M).
          On exit,  LDJ >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (M)
          On entry, this array must contain the error vector e.
          On exit, this array contains the updated vector Q'*e.

  JNORMS  (output) DOUBLE PRECISION array, dimension (N)
          This array contains the Euclidean norms of the columns of
          the Jacobian matrix, considered in the initial order.

  GNORM   (output) DOUBLE PRECISION
          If FNORM > 0, the 1-norm of the scaled vector
          J'*Q'*e/FNORM, with each element i further divided by
          JNORMS(i) (if JNORMS(i) is nonzero).
          If FNORM = 0, the returned value of GNORM is 0.

  IPVT    (output) INTEGER array, dimension (N)
          This array defines the permutation matrix P such that
          J*P = Q*R. Column j of P is column IPVT(j) of the identity
          matrix.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 1,      if N = 0 or M = 1;
          LDWORK >= 4*N+1,  if N > 1.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The algorithm uses QR factorization with column pivoting of the
  matrix J, J*P = Q*R, and applies the orthogonal matrix Q' to the
  vector e.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/MD03BY.html000077500000000000000000000170261201767322700161100ustar00rootroot00000000000000 MD03BY - SLICOT Library Routine Documentation

MD03BY

Levenberg-Marquardt parameter for a standard nonlinear least squares problem

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine a value for the parameter PAR such that if x solves
  the system

        A*x = b ,     sqrt(PAR)*D*x = 0 ,

  in the least squares sense, where A is an m-by-n matrix, D is an
  n-by-n nonsingular diagonal matrix, and b is an m-vector, and if
  DELTA is a positive number, DXNORM is the Euclidean norm of D*x,
  then either PAR is zero and

        ( DXNORM - DELTA ) .LE. 0.1*DELTA ,

  or PAR is positive and

        ABS( DXNORM - DELTA ) .LE. 0.1*DELTA .

  It is assumed that a QR factorization, with column pivoting, of A
  is available, that is, A*P = Q*R, where P is a permutation matrix,
  Q has orthogonal columns, and R is an upper triangular matrix
  with diagonal elements of nonincreasing magnitude.
  The routine needs the full upper triangle of R, the permutation
  matrix P, and the first n components of Q'*b (' denotes the
  transpose). On output, MD03BY also provides an upper triangular
  matrix S such that

        P'*(A'*A + PAR*D*D)*P = S'*S .

  Matrix S is used in the solution process.
Specification 
      SUBROUTINE MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR,
     $                   RANK, X, RX, TOL, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  COND    CHARACTER*1
          Specifies whether the condition of the matrices R and S
          should be estimated, as follows:
          = 'E' :  use incremental condition estimation for R and S;
          = 'N' :  do not use condition estimation, but check the
                   diagonal entries of R and S for zero values;
          = 'U' :  use the rank already stored in RANK (for R).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix R.  N >= 0.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR, N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the upper triangular matrix R.
          On exit, the full upper triangle is unaltered, and the
          strict lower triangle contains the strict upper triangle
          (transposed) of the upper triangular matrix S.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  IPVT    (input) INTEGER array, dimension (N)
          This array must define the permutation matrix P such that
          A*P = Q*R. Column j of P is column IPVT(j) of the identity
          matrix.

  DIAG    (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the diagonal elements of the
          matrix D.  DIAG(I) <> 0, I = 1,...,N.

  QTB     (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the first n elements of the
          vector Q'*b.

  DELTA   (input) DOUBLE PRECISION
          An upper bound on the Euclidean norm of D*x.  DELTA > 0.

  PAR     (input/output) DOUBLE PRECISION
          On entry, PAR must contain an initial estimate of the
          Levenberg-Marquardt parameter.  PAR >= 0.
          On exit, it contains the final estimate of this parameter.

  RANK    (input or output) INTEGER
          On entry, if COND = 'U', this parameter must contain the
          (numerical) rank of the matrix R.
          On exit, this parameter contains the numerical rank of
          the matrix S.

  X       (output) DOUBLE PRECISION array, dimension (N)
          This array contains the least squares solution of the
          system A*x = b, sqrt(PAR)*D*x = 0.

  RX      (output) DOUBLE PRECISION array, dimension (N)
          This array contains the matrix-vector product -R*P'*x.
Tolerances 
  TOL     DOUBLE PRECISION
          If COND = 'E', the tolerance to be used for finding the
          rank of the matrices R and S. If the user sets TOL > 0,
          then the given value of TOL is used as a lower bound for
          the reciprocal condition number;  a (sub)matrix whose
          estimated condition number is less than 1/TOL is
          considered to be of full rank.  If the user sets TOL <= 0,
          then an implicitly computed, default tolerance, defined by
          TOLDEF = N*EPS,  is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not relevant if COND = 'U' or 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, the first N elements of this array contain the
          diagonal elements of the upper triangular matrix S.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 4*N, if COND =  'E';
          LDWORK >= 2*N, if COND <> 'E'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The algorithm computes the Gauss-Newton direction. A least squares
  solution is found if the Jacobian is rank deficient. If the Gauss-
  Newton direction is not acceptable, then an iterative algorithm
  obtains improved lower and upper bounds for the parameter PAR.
  Only a few iterations are generally needed for convergence of the
  algorithm. If, however, the limit of ITMAX = 10 iterations is
  reached, then the output PAR will contain the best value obtained
  so far. If the Gauss-Newton step is acceptable, it is stored in x,
  and PAR is set to zero, hence S = R.
References 
  [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
      User's Guide for MINPACK-1.
      Applied Math. Division, Argonne National Laboratory, Argonne,
      Illinois, Report ANL-80-74, 1980.
Numerical Aspects 
                            2
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  This routine is a LAPACK-based modification of LMPAR from the
  MINPACK package [1], and with optional condition estimation.
  The option COND = 'U' is useful when dealing with several
  right-hand side vectors, but RANK should be reset.
  If COND = 'E', but the matrix S is guaranteed to be nonsingular
  and well conditioned relative to TOL, i.e., rank(R) = N, and
  min(DIAG) > 0, then its condition is not estimated.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01AD.html000077500000000000000000000113331201767322700160560ustar00rootroot00000000000000 NF01AD - SLICOT Library Routine Documentation

NF01AD

Computing the output of a Wiener system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate the output y of the Wiener system

     x(t+1) = A*x(t) + B*u(t)
     z(t)   = C*x(t) + D*u(t),

     y(t)   = f(z(t),wb(1:L)),

  where t = 1, 2, ..., NSMP, and f is a nonlinear function,
  evaluated by the SLICOT Library routine NF01AY. The parameter
  vector X is partitioned as X = ( wb(1), ..., wb(L), theta ),
  where wb(i), i = 1:L, correspond to the nonlinear part, theta
  corresponds to the linear part, and the notation is fully
  described below.
Specification 
      SUBROUTINE NF01AD( NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, Y, LDY,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  NSMP    (input) INTEGER
          The number of training samples.  NSMP >= 0.

  M       (input) INTEGER
          The length of each input sample.  M >= 0.

  L       (input) INTEGER
          The length of each output sample.  L >= 0.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters needed.
          IPAR(1)  must contain the order of the linear part,
                   referred to as N below.  N >= 0.
          IPAR(2)  must contain the number of neurons for the
                   nonlinear part, referred to as NN below.
                   NN >= 0.

  LIPAR   (input) INTEGER
          The length of IPAR.  LIPAR >= 2.

  X       (input) DOUBLE PRECISION array, dimension (LX)
          The parameter vector, partitioned as
          X = (wb(1), ..., wb(L), theta), where the vectors
          wb(i), of length NN*(L+2)+1, are parameters for the
          static nonlinearity, which is simulated by the
          SLICOT Library routine NF01AY. See the documentation of
          NF01AY for further details. The vector theta, of length
          N*(M + L + 1) + L*M, represents the matrices A, B, C,
          D and x(1), and it can be retrieved from these matrices
          by SLICOT Library routine TB01VD and retranslated by
          TB01VY.

  LX      (input) INTEGER
          The length of the array X.
          LX >= ( NN*(L+2)+1 )*L + N*(M + L + 1) + L*M.

  U       (input) DOUBLE PRECISION array, dimension (LDU, M)
          The leading NSMP-by-M part of this array must contain the
          set of input samples,
          U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ).

  LDU     INTEGER
          The leading dimension of the array U.  LDU >= MAX(1,NSMP).

  Y       (output) DOUBLE PRECISION array, dimension (LDY, L)
          The leading NSMP-by-L part of this array contains the
          simulated output.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= MAX(1,NSMP).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N +
                                  MAX( N*(N + L), N + M + L ) )
                                                           if M > 0;
          LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*N + 2*N +
                                  MAX( N*(N + L), L ) ),   if M = 0.
          A larger value of LDWORK could improve the efficiency.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  BLAS routines are used for the matrix-vector multiplications and
  the routine NF01AY is called for the calculation of the nonlinear
  function.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01AY.html000077500000000000000000000106631201767322700161100ustar00rootroot00000000000000 NF01AY - SLICOT Library Routine Documentation

NF01AY

Computing the output of a set of neural networks

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate the output of a set of neural networks with the
  structure

          - tanh(w1'*z+b1) -
        /      :             \
      z ---    :           --- sum(ws(i)*...)+ b(n+1)  --- y,
        \      :             /
          - tanh(wn'*z+bn) -

  given the input z and the parameter vectors wi, ws, and b,
  where z, w1, ..., wn are vectors of length NZ, ws is a vector
  of length n, b(1), ..., b(n+1) are scalars, and n is called the
  number of neurons in the hidden layer, or just number of neurons.
  Such a network is used for each L output variables.
Specification 
      SUBROUTINE NF01AY( NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, LDZ,
     $                   Y, LDY, DWORK, LDWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  NSMP    (input) INTEGER
          The number of training samples.  NSMP >= 0.

  NZ      (input) INTEGER
          The length of each input sample.  NZ >= 0.

  L       (input) INTEGER
          The length of each output sample.  L >= 0.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters needed.
          IPAR(1) must contain the number of neurons, n, per output
          variable, denoted NN in the sequel.  NN >= 0.

  LIPAR   (input) INTEGER
          The length of the vector IPAR.  LIPAR >= 1.

  WB      (input) DOUBLE PRECISION array, dimension (LWB)
          The leading (NN*(NZ+2)+1)*L part of this array must
          contain the weights and biases of the network. This vector
          is partitioned into L vectors of length NN*(NZ+2)+1,
          WB = [ wb(1), ..., wb(L) ]. Each wb(k), k = 1, ..., L,
          corresponds to one output variable, and has the structure
          wb(k) = [ w1(1), ..., w1(NZ), ..., wn(1), ..., wn(NZ),
                    ws(1), ..., ws(n), b(1), ..., b(n+1) ],
          where wi(j) are the weights of the hidden layer,
          ws(i) are the weights of the linear output layer, and
          b(i) are the biases, as in the scheme above.

  LWB     (input) INTEGER
          The length of the array WB.
          LWB >= ( NN*(NZ + 2) + 1 )*L.

  Z       (input) DOUBLE PRECISION array, dimension (LDZ, NZ)
          The leading NSMP-by-NZ part of this array must contain the
          set of input samples,
          Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ).

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= MAX(1,NSMP).

  Y       (output) DOUBLE PRECISION array, dimension (LDY, L)
          The leading NSMP-by-L part of this array contains the set
          of output samples,
          Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ).

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= MAX(1,NSMP).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 2*NN.
          For better performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  BLAS routines are used to compute the matrix-vector products.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BD.html000077500000000000000000000162311201767322700160610ustar00rootroot00000000000000 NF01BD - SLICOT Library Routine Documentation

NF01BD

Computing the Jacobian of a Wiener system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To calculate the Jacobian dy/dX of the Wiener system

     x(t+1) = A*x(t) + B*u(t)
     z(t)   = C*x(t) + D*u(t),

     y(t,i) = sum( ws(k, i)*f(w(k, i)*z(t) + b(k,i)) ) + b(k+1,i),

  where t = 1, 2, ...,  NSMP,
        i = 1, 2, ...,  L,
        k = 1, 2, ...,  NN.

  NN is arbitrary eligible and has to be provided in IPAR(2), and
  X = ( wb(1), ..., wb(L), theta ) is described below.

  Denoting y(j) = y(1:NSMP,j), the Jacobian J has the block form

    dy(1)/dwb(1)       0         .....       0         dy(1)/dtheta
         0        dy(2)/dwb(2)   .....       0         dy(2)/dtheta
       .....         .....       .....     .....          .....
         0           .....         0    dy(L)/dwb(L)   dy(L)/dtheta

  but it will be returned without the zero blocks, in the form

  dy(1)/dwb(1)    dy(1)/dtheta
               ...
  dy(L)/dwb(L)    dy(L)/dtheta.

  dy(i)/dwb(i) depends on f and is calculated by the routine NF01BY;
  dy(i)/dtheta is computed by a forward-difference approximation.
Specification 
      SUBROUTINE NF01BD( CJTE, NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU,
     $                   E, J, LDJ, JTE, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  CJTE    CHARACTER*1
          Specifies whether the matrix-vector product J'*e should be
          computed or not, as follows:
          = 'C' :  compute J'*e;
          = 'N' :  do not compute J'*e.
Input/Output Parameters 
  NSMP    (input) INTEGER
          The number of training samples.  NSMP >= 0.

  M       (input) INTEGER
          The length of each input sample.  M >= 0.

  L       (input) INTEGER
          The length of each output sample.  L >= 0.

  IPAR    (input/output) INTEGER array, dimension (LIPAR)
          On entry, the first entries of this array must contain
          the integer parameters needed; specifically,
          IPAR(1)  must contain the order of the linear part, N;
                   actually, N = abs(IPAR(1)), since setting
                   IPAR(1) < 0 has a special meaning (see below);
          IPAR(2)  must contain the number of neurons for the
                   nonlinear part, NN, NN >= 0.
          On exit, if IPAR(1) < 0 on entry, then no computations are
          performed, except the needed tests on input parameters,
          but the following values are returned:
          IPAR(1) contains the length of the array J, LJ;
          LDJ     contains the leading dimension of array J.
          Otherwise, IPAR(1) and LDJ are unchanged on exit.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 2.

  X       (input) DOUBLE PRECISION array, dimension (LX)
          The leading LPAR entries of this array must contain the
          set of system parameters, where
             LPAR = (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M.
          X has the form (wb(1), ..., wb(L), theta), where the
          vectors wb(i) have the structure
           (w(1,1), ..., w(1,L), ..., w(NN,1), ..., w(NN,L),
             ws(1), ..., ws(NN), b(1), ..., b(NN+1) ),
          and the vector theta represents the matrices A, B, C, D
          and x(1), and it can be retrieved from these matrices
          by SLICOT Library routine TB01VD and retranslated by
          TB01VY.

  LX      (input) INTEGER
          The length of X.
          LX >= (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M.

  U       (input) DOUBLE PRECISION array, dimension (LDU, M)
          The leading NSMP-by-M part of this array must contain the
          set of input samples,
          U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ).

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,NSMP).

  E       (input) DOUBLE PRECISION array, dimension (NSMP*L)
          If CJTE = 'C', this array must contain a vector e, which
          will be premultiplied with J', e = vec( Y - y ), where
          Y is set of output samples, and vec denotes the
          concatenation of the columns of a matrix.
          If CJTE = 'N', this array is not referenced.

  J       (output) DOUBLE PRECISION array, dimension (LDJ, *)
          The leading NSMP*L-by-NCOLJ part of this array contains
          the Jacobian of the error function stored in a compressed
          form, as described above, where
          NCOLJ = NN*(L + 2) + 1 + N*(M + L + 1) + L*M.

  LDJ     INTEGER
          The leading dimension of array J.  LDJ >= MAX(1,NSMP*L).
          Note that LDJ is an input parameter, except for
          IPAR(1) < 0 on entry, when it is an output parameter.

  JTE     (output) DOUBLE PRECISION array, dimension (LPAR)
          If CJTE = 'C', this array contains the matrix-vector
          product J'*e.
          If CJTE = 'N', this array is not referenced.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N +
                                    MAX( N*(N + L), N + M + L ) )
                                                           if M > 0;
          LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N +
                                    MAX( N*(N + L), L ) ), if M = 0.
          A larger value of LDWORK could improve the efficiency.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  BLAS routines are used for the matrix-vector multiplications, and
  the SLICOT Library routine TB01VY is called for the conversion of
  the output normal form parameters to an LTI-system; the routine
  NF01AD is then used for the simulation of the system with given
  parameters, and the routine NF01BY is called for the (analytically
  performed) calculation of the parts referring to the parameters
  of the static nonlinearity.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BP.html000077500000000000000000000271571201767322700161060ustar00rootroot00000000000000 NF01BP - SLICOT Library Routine Documentation

NF01BP

Levenberg-Marquardt parameter for Wiener system identification

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine a value for the Levenberg-Marquardt parameter PAR
  such that if x solves the system

        J*x = b ,     sqrt(PAR)*D*x = 0 ,

  in the least squares sense, where J is an m-by-n matrix, D is an
  n-by-n nonsingular diagonal matrix, and b is an m-vector, and if
  DELTA is a positive number, DXNORM is the Euclidean norm of D*x,
  then either PAR is zero and

        ( DXNORM - DELTA ) .LE. 0.1*DELTA ,

  or PAR is positive and

        ABS( DXNORM - DELTA ) .LE. 0.1*DELTA .

  The matrix J is the current Jacobian matrix of a nonlinear least
  squares problem, provided in a compressed form by SLICOT Library
  routine NF01BD. It is assumed that a block QR factorization, with
  column pivoting, of J is available, that is, J*P = Q*R, where P is
  a permutation matrix, Q has orthogonal columns, and R is an upper
  triangular matrix with diagonal elements of nonincreasing
  magnitude for each block, as returned by SLICOT Library
  routine NF01BS. The routine NF01BP needs the upper triangle of R
  in compressed form, the permutation matrix P, and the first
  n components of Q'*b (' denotes the transpose). On output,
  NF01BP also provides a compressed representation of an upper
  triangular matrix S, such that

        P'*(J'*J + PAR*D*D)*P = S'*S .

  Matrix S is used in the solution process. The matrix R has the
  following structure

      /   R_1    0    ..   0   |   L_1   \
      |    0    R_2   ..   0   |   L_2   |
      |    :     :    ..   :   |    :    | ,
      |    0     0    ..  R_l  |   L_l   |
      \    0     0    ..   0   |  R_l+1  /

  where the submatrices R_k, k = 1:l, have the same order BSN,
  and R_k, k = 1:l+1, are square and upper triangular. This matrix
  is stored in the compressed form

           /   R_1  |   L_1   \
           |   R_2  |   L_2   |
    Rc =   |    :   |    :    | ,
           |   R_l  |   L_l   |
           \    X   |  R_l+1  /

  where the submatrix X is irrelevant. The matrix S has the same
  structure as R, and its diagonal blocks are denoted by S_k,
  k = 1:l+1.

  If l <= 1, then the full upper triangle of the matrix R is stored.
Specification 
      SUBROUTINE NF01BP( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB,
     $                   DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  COND    CHARACTER*1
          Specifies whether the condition of the diagonal blocks R_k
          and S_k of the matrices R and S should be estimated,
          as follows:
          = 'E' :  use incremental condition estimation for each
                   diagonal block of R_k and S_k to find its
                   numerical rank;
          = 'N' :  do not use condition estimation, but check the
                   diagonal entries of R_k and S_k for zero values;
          = 'U' :  use the ranks already stored in RANKS (for R).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix R.  N = BN*BSN + ST >= 0.
          (See parameter description below.)

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix R, as follows:
          IPAR(1) must contain ST, the number of columns of the
                  submatrices L_k and the order of R_l+1.  ST >= 0.
          IPAR(2) must contain BN, the number of blocks, l, in the
                  block diagonal part of R.  BN >= 0.
          IPAR(3) must contain BSM, the number of rows of the blocks
                  R_k, k = 1:l.  BSM >= 0.
          IPAR(4) must contain BSN, the number of columns of the
                  blocks R_k, k = 1:l.  BSN >= 0.
          BSM is not used by this routine, but assumed equal to BSN.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 4.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR, NC)
          where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
          On entry, the leading N-by-NC part of this array must
          contain the (compressed) representation (Rc) of the upper
          triangular matrix R. If BN > 1, the submatrix X in Rc is
          not referenced. The zero strict lower triangles of R_k,
          k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then
          the full upper triangle of R must be stored.
          On exit, the full upper triangles of R_k, k = 1:l+1, and
          L_k, k = 1:l, are unaltered, and the strict lower
          triangles of R_k, k = 1:l+1, contain the corresponding
          strict upper triangles (transposed) of the upper
          triangular matrix S.
          If BN <= 1 or BSN = 0, then the transpose of the strict
          upper triangle of S is stored in the strict lower triangle
          of R.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  IPVT    (input) INTEGER array, dimension (N)
          This array must define the permutation matrix P such that
          J*P = Q*R. Column j of P is column IPVT(j) of the identity
          matrix.

  DIAG    (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the diagonal elements of the
          matrix D.  DIAG(I) <> 0, I = 1,...,N.

  QTB     (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the first n elements of the
          vector Q'*b.

  DELTA   (input) DOUBLE PRECISION
          An upper bound on the Euclidean norm of D*x.  DELTA > 0.

  PAR     (input/output) DOUBLE PRECISION
          On entry, PAR must contain an initial estimate of the
          Levenberg-Marquardt parameter.  PAR >= 0.
          On exit, it contains the final estimate of this parameter.

  RANKS   (input or output) INTEGER array, dimension (r), where
          r = BN + 1,  if ST > 0, BSN > 0, and BN > 1;
          r = BN,      if ST = 0 and BSN > 0;
          r = 1,       if ST > 0 and ( BSN = 0 or BN <= 1 );
          r = 0,       if ST = 0 and BSN = 0.
          On entry, if COND = 'U' and N > 0, this array must contain
          the numerical ranks of the submatrices R_k, k = 1:l(+1).
          On exit, if N > 0, this array contains the numerical ranks
          of the submatrices S_k, k = 1:l(+1).

  X       (output) DOUBLE PRECISION array, dimension (N)
          This array contains the least squares solution of the
          system J*x = b, sqrt(PAR)*D*x = 0.

  RX      (output) DOUBLE PRECISION array, dimension (N)
          This array contains the matrix-vector product -R*P'*x.
Tolerances 
  TOL     DOUBLE PRECISION
          If COND = 'E', the tolerance to be used for finding the
          ranks of the submatrices R_k and S_k. If the user sets
          TOL > 0, then the given value of TOL is used as a lower
          bound for the reciprocal condition number;  a (sub)matrix
          whose estimated condition number is less than 1/TOL is
          considered to be of full rank.  If the user sets TOL <= 0,
          then an implicitly computed, default tolerance, defined by
          TOLDEF = N*EPS,  is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not relevant if COND = 'U' or 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, the first N elements of this array contain the
          diagonal elements of the upper triangular matrix S.
          If BN > 1 and BSN > 0, the elements N+1 : N+ST*(N-ST)
          contain the submatrix (S(1:N-ST,N-ST+1:N))' of the
          matrix S.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 2*N,              if BN <= 1 or  BSN = 0 and
                                                     COND <> 'E';
          LDWORK >= 4*N,              if BN <= 1 or  BSN = 0 and
                                                     COND =  'E';
          LDWORK >= ST*(N-ST) + 2*N,  if BN >  1 and BSN > 0 and
                                                     COND <> 'E';
          LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST),
                                      if BN >  1 and BSN > 0 and
                                                     COND =  'E'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The algorithm computes the Gauss-Newton direction. An approximate
  basic least squares solution is found if the Jacobian is rank
  deficient. The computations exploit the special structure and
  storage scheme of the matrix R. If one or more of the submatrices
  R_k or S_k, k = 1:l+1, is singular, then the computed result is
  not the basic least squares solution for the whole problem, but a
  concatenation of (least squares) solutions of the individual
  subproblems involving R_k or S_k, k = 1:l+1 (with adapted right
  hand sides).

  If the Gauss-Newton direction is not acceptable, then an iterative
  algorithm obtains improved lower and upper bounds for the
  Levenberg-Marquardt parameter PAR. Only a few iterations are
  generally needed for convergence of the algorithm. If, however,
  the limit of ITMAX = 10 iterations is reached, then the output PAR
  will contain the best value obtained so far. If the Gauss-Newton
  step is acceptable, it is stored in x, and PAR is set to zero,
  hence S = R.
References 
  [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
      User's Guide for MINPACK-1.
      Applied Math. Division, Argonne National Laboratory, Argonne,
      Illinois, Report ANL-80-74, 1980.
Numerical Aspects 
  The algorithm requires 0(N*(BSN+ST)) operations and is backward
  stable, if R is nonsingular.
Further Comments 
  This routine is a structure-exploiting, LAPACK-based modification
  of LMPAR from the MINPACK package [1], and with optional condition
  estimation. The option COND = 'U' is useful when dealing with
  several right-hand side vectors, but RANKS array should be reset.
  If COND = 'E', but the matrix S is guaranteed to be nonsingular
  and well conditioned relative to TOL, i.e., rank(R) = N, and
  min(DIAG) > 0, then its condition is not estimated.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BQ.html000077500000000000000000000252411201767322700160770ustar00rootroot00000000000000 NF01BQ - SLICOT Library Routine Documentation

NF01BQ

Solving the linear system J x = b, D x = 0, D diagonal, for Wiener system identification

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine a vector x which solves the system of linear
  equations

        J*x = b ,     D*x = 0 ,

  in the least squares sense, where J is an m-by-n matrix,
  D is an n-by-n diagonal matrix, and b is an m-vector. The matrix J
  is the current Jacobian of a nonlinear least squares problem,
  provided in a compressed form by SLICOT Library routine NF01BD.
  It is assumed that a block QR factorization, with column pivoting,
  of J is available, that is, J*P = Q*R, where P is a permutation
  matrix, Q has orthogonal columns, and R is an upper triangular
  matrix with diagonal elements of nonincreasing magnitude for each
  block, as returned by SLICOT Library routine NF01BS. The routine
  NF01BQ needs the upper triangle of R in compressed form, the
  permutation matrix P, and the first n components of Q'*b
  (' denotes the transpose). The system J*x = b, D*x = 0, is then
  equivalent to

        R*z = Q'*b ,  P'*D*P*z = 0 ,                             (1)

  where x = P*z. If this system does not have full rank, then an
  approximate least squares solution is obtained (see METHOD).
  On output, NF01BQ also provides an upper triangular matrix S
  such that

        P'*(J'*J + D*D)*P = S'*S .

  The system (1) is equivalent to S*z = c , where c contains the
  first n components of the vector obtained by applying to
  [ (Q'*b)'  0 ]' the transformations which triangularized
  [ R'  P'*D*P ]', getting S.

  The matrix R has the following structure

      /   R_1    0    ..   0   |   L_1   \
      |    0    R_2   ..   0   |   L_2   |
      |    :     :    ..   :   |    :    | ,
      |    0     0    ..  R_l  |   L_l   |
      \    0     0    ..   0   |  R_l+1  /

  where the submatrices R_k, k = 1:l, have the same order BSN,
  and R_k, k = 1:l+1, are square and upper triangular. This matrix
  is stored in the compressed form

           /   R_1  |   L_1   \
           |   R_2  |   L_2   |
    Rc =   |    :   |    :    | ,
           |   R_l  |   L_l   |
           \    X   |  R_l+1  /

  where the submatrix X is irrelevant. The matrix S has the same
  structure as R, and its diagonal blocks are denoted by S_k,
  k = 1:l+1.

  If l <= 1, then the full upper triangle of the matrix R is stored.
Specification 
      SUBROUTINE NF01BQ( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB,
     $                   RANKS, X, TOL, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  COND    CHARACTER*1
          Specifies whether the condition of the matrices S_k should
          be estimated, as follows:
          = 'E' :  use incremental condition estimation and store
                   the numerical rank of S_k in the array entry
                   RANKS(k), for k = 1:l+1;
          = 'N' :  do not use condition estimation, but check the
                   diagonal entries of S_k for zero values;
          = 'U' :  use the ranks already stored in RANKS(1:l+1).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix R.  N = BN*BSN + ST >= 0.
          (See parameter description below.)

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix R, as follows:
          IPAR(1) must contain ST, the number of columns of the
                  submatrices L_k and the order of R_l+1.  ST >= 0.
          IPAR(2) must contain BN, the number of blocks, l, in the
                  block diagonal part of R.  BN >= 0.
          IPAR(3) must contain BSM, the number of rows of the blocks
                  R_k, k = 1:l.  BSM >= 0.
          IPAR(4) must contain BSN, the number of columns of the
                  blocks R_k, k = 1:l.  BSN >= 0.
          BSM is not used by this routine, but assumed equal to BSN.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 4.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR, NC)
          where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
          On entry, the leading N-by-NC part of this array must
          contain the (compressed) representation (Rc) of the upper
          triangular matrix R. If BN > 1, the submatrix X in Rc is
          not referenced. The zero strict lower triangles of R_k,
          k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then
          the full upper triangle of R must be stored.
          On exit, the full upper triangles of R_k, k = 1:l+1, and
          L_k, k = 1:l, are unaltered, and the strict lower
          triangles of R_k, k = 1:l+1, contain the corresponding
          strict upper triangles (transposed) of the upper
          triangular matrix S.
          If BN <= 1 or BSN = 0, then the transpose of the strict
          upper triangle of S is stored in the strict lower triangle
          of R.

  LDR     INTEGER
          The leading dimension of the array R.  LDR >= MAX(1,N).

  IPVT    (input) INTEGER array, dimension (N)
          This array must define the permutation matrix P such that
          J*P = Q*R. Column j of P is column IPVT(j) of the identity
          matrix.

  DIAG    (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the diagonal elements of the
          matrix D.

  QTB     (input) DOUBLE PRECISION array, dimension (N)
          This array must contain the first n elements of the
          vector Q'*b.

  RANKS   (input or output) INTEGER array, dimension (r), where
          r = BN + 1,  if ST > 0, BSN > 0, and BN > 1;
          r = BN,      if ST = 0 and BSN > 0;
          r = 1,       if ST > 0 and ( BSN = 0 or BN <= 1 );
          r = 0,       if ST = 0 and BSN = 0.
          On entry, if COND = 'U' and N > 0, this array must contain
          the numerical ranks of the submatrices S_k, k = 1:l(+1).
          On exit, if COND = 'E' or 'N' and N > 0, this array
          contains the numerical ranks of the submatrices S_k,
          k = 1:l(+1), estimated according to the value of COND.

  X       (output) DOUBLE PRECISION array, dimension (N)
          This array contains the least squares solution of the
          system J*x = b, D*x = 0.
Tolerances 
  TOL     DOUBLE PRECISION
          If COND = 'E', the tolerance to be used for finding the
          ranks of the submatrices S_k. If the user sets TOL > 0,
          then the given value of TOL is used as a lower bound for
          the reciprocal condition number;  a (sub)matrix whose
          estimated condition number is less than 1/TOL is
          considered to be of full rank.  If the user sets TOL <= 0,
          then an implicitly computed, default tolerance, defined by
          TOLDEF = N*EPS,  is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not relevant if COND = 'U' or 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, the first N elements of this array contain the
          diagonal elements of the upper triangular matrix S, and
          the next N elements contain the solution z.
          If BN > 1 and BSN > 0, the elements 2*N+1 : 2*N+ST*(N-ST)
          contain the submatrix (S(1:N-ST,N-ST+1:N))' of the
          matrix S.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 2*N,              if BN <= 1 or  BSN = 0 and
                                                     COND <> 'E';
          LDWORK >= 4*N,              if BN <= 1 or  BSN = 0 and
                                                     COND =  'E';
          LDWORK >= ST*(N-ST) + 2*N,  if BN >  1 and BSN > 0 and
                                                     COND <> 'E';
          LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST),
                                      if BN >  1 and BSN > 0 and
                                                     COND = 'E'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Standard plane rotations are used to annihilate the elements of
  the diagonal matrix D, updating the upper triangular matrix R
  and the first n elements of the vector Q'*b. A basic least squares
  solution is computed. The computations exploit the special
  structure and storage scheme of the matrix R. If one or more of
  the submatrices S_k, k = 1:l+1, is singular, then the computed
  result is not the basic least squares solution for the whole
  problem, but a concatenation of (least squares) solutions of the
  individual subproblems involving R_k, k = 1:l+1 (with adapted
  right hand sides).
References 
  [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
      User's Guide for MINPACK-1.
      Applied Math. Division, Argonne National Laboratory, Argonne,
      Illinois, Report ANL-80-74, 1980.
Numerical Aspects 
  The algorithm requires 0(N*(BSN+ST)) operations and is backward
  stable, if R is nonsingular.
Further Comments 
  This routine is a structure-exploiting, LAPACK-based modification
  of QRSOLV from the MINPACK package [1], and with optional
  condition estimation.
  The option COND = 'U' is useful when dealing with several
  right-hand side vectors.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BR.html000077500000000000000000000246671201767322700161130ustar00rootroot00000000000000 NF01BR - SLICOT Library Routine Documentation

NF01BR

Solving linear systems R x = b, or R' x = b, in the least squares sense

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve one of the systems of linear equations

        R*x = b ,  or  R'*x = b ,

  in the least squares sense, where R is an n-by-n block upper
  triangular matrix, with the structure

      /   R_1    0    ..   0   |   L_1   \
      |    0    R_2   ..   0   |   L_2   |
      |    :     :    ..   :   |    :    | ,
      |    0     0    ..  R_l  |   L_l   |
      \    0     0    ..   0   |  R_l+1  /

  with the upper triangular submatrices R_k, k = 1:l+1, square, and
  the first l of the same order, BSN. The diagonal elements of each
  block R_k have nonincreasing magnitude. The matrix R is stored in
  the compressed form, as returned by SLICOT Library routine NF01BS,

           /   R_1  |   L_1   \
           |   R_2  |   L_2   |
    Rc =   |    :   |    :    | ,
           |   R_l  |   L_l   |
           \    X   |  R_l+1  /

  where the submatrix X is irrelevant. If the matrix R does not have
  full rank, then a least squares solution is obtained. If l <= 1,
  then R is an upper triangular matrix and its full upper triangle
  is stored.

  Optionally, the transpose of the matrix R can be stored in the
  strict lower triangles of the submatrices R_k, k = 1:l+1, and in
  the arrays SDIAG and S, as described at the parameter UPLO below.
Specification 
      SUBROUTINE NF01BR( COND, UPLO, TRANS, N, IPAR, LIPAR, R, LDR,
     $                   SDIAG, S, LDS, B, RANKS, TOL, DWORK, LDWORK,
     $                   INFO )
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(*)
Arguments

Mode Parameters 

  COND    CHARACTER*1
          Specifies whether the condition of submatrices R_k should
          be estimated, as follows:
          = 'E' :  use incremental condition estimation and store
                   the numerical rank of R_k in the array entry
                   RANKS(k), for k = 1:l+1;
          = 'N' :  do not use condition estimation, but check the
                   diagonal entries of R_k for zero values;
          = 'U' :  use the ranks already stored in RANKS(1:l+1).

  UPLO    CHARACTER*1
          Specifies the storage scheme for the matrix R, as follows:
          = 'U' :  the upper triangular part is stored as in Rc;
          = 'L' :  the lower triangular part is stored, namely,
                   - the transpose of the strict upper triangle of
                     R_k is stored in the strict lower triangle of
                     R_k, for k = 1:l+1;
                   - the diagonal elements of R_k, k = 1:l+1, are
                     stored in the array SDIAG;
                   - the transpose of the last block column in R
                     (without R_l+1) is stored in the array S.

  TRANS   CHARACTER*1
          Specifies the form of the system of equations, as follows:
          = 'N':  R*x  = b  (No transpose);
          = 'T':  R'*x = b  (Transpose);
          = 'C':  R'*x = b  (Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix R.  N = BN*BSN + ST >= 0.
          (See parameter description below.)

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix R, as follows:
          IPAR(1) must contain ST, the number of columns of the
                  submatrices L_k and the order of R_l+1.  ST >= 0.
          IPAR(2) must contain BN, the number of blocks, l, in the
                  block diagonal part of R.  BN >= 0.
          IPAR(3) must contain BSM, the number of rows of the blocks
                  R_k, k = 1:l.  BSM >= 0.
          IPAR(4) must contain BSN, the number of columns of the
                  blocks R_k, k = 1:l.  BSN >= 0.
          BSM is not used by this routine, but assumed equal to BSN.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 4.

  R       (input) DOUBLE PRECISION array, dimension (LDR, NC)
          where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
          If UPLO = 'U', the leading N-by-NC part of this array must
          contain the (compressed) representation (Rc) of the upper
          triangular matrix R. The submatrix X in Rc and the strict
          lower triangular parts of the diagonal blocks R_k,
          k = 1:l+1, are not referenced. If BN <= 1 or BSN = 0, then
          the full upper triangle of R must be stored.
          If UPLO = 'L', BN > 1 and BSN > 0, the leading
          (N-ST)-by-BSN part of this array must contain the
          transposes of the strict upper triangles of R_k, k = 1:l,
          stored in the strict lower triangles of R_k, and the
          strict lower triangle of R_l+1 must contain the transpose
          of the strict upper triangle of R_l+1. The submatrix X
          in Rc is not referenced. The diagonal elements of R_k,
          and, if COND = 'E', the upper triangular parts of R_k,
          k = 1:l+1, are modified internally, but are restored
          on exit.
          If UPLO = 'L' and BN <= 1 or BSN = 0, the leading N-by-N
          strict lower triangular part of this array must contain
          the transpose of the strict upper triangular part of R.
          The diagonal elements and, if COND = 'E', the upper
          triangular elements are modified internally, but are
          restored on exit.

  LDR     INTEGER
          The leading dimension of the array R.  LDR >= MAX(1,N).

  SDIAG   (input) DOUBLE PRECISION array, dimension (N)
          If UPLO = 'L', this array must contain the diagonal
          entries of R_k, k = 1:l+1. This array is modified
          internally, but is restored on exit.
          This parameter is not referenced if UPLO = 'U'.

  S       (input) DOUBLE PRECISION array, dimension (LDS,N-ST)
          If UPLO = 'L', BN > 1, and BSN > 0, the leading
          ST-by-(N-ST) part of this array must contain the transpose
          of the rectangular part of the last block column in R,
          that is [ L_1' L_2' ... L_l' ] . If COND = 'E', S is
          modified internally, but is restored on exit.
          This parameter is not referenced if UPLO = 'U', or
          BN <= 1, or BSN = 0.

  LDS     INTEGER
          The leading dimension of the array S.
          LDS >= 1,         if UPLO = 'U', or BN <= 1, or BSN = 0;
          LDS >= MAX(1,ST), if UPLO = 'L', BN > 1, and BSN > 0.

  B       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the right hand side
          vector b.
          On exit, this array contains the (least squares) solution
          of the system R*x = b or R'*x = b.

  RANKS   (input or output) INTEGER array, dimension (r), where
          r = BN + 1,  if ST > 0, BSN > 0, and BN > 1;
          r = BN,      if ST = 0 and BSN > 0;
          r = 1,       if ST > 0 and ( BSN = 0 or BN <= 1 );
          r = 0,       if ST = 0 and BSN = 0.
          On entry, if COND = 'U' and N > 0, this array must contain
          the numerical ranks of the submatrices R_k, k = 1:l(+1).
          On exit, if COND = 'E' or 'N' and N > 0, this array
          contains the numerical ranks of the submatrices R_k,
          k = 1:l(+1), estimated according to the value of COND.
Tolerances 
  TOL     DOUBLE PRECISION
          If COND = 'E', the tolerance to be used for finding the
          ranks of the submatrices R_k. If the user sets TOL > 0,
          then the given value of TOL is used as a lower bound for
          the reciprocal condition number;  a (sub)matrix whose
          estimated condition number is less than 1/TOL is
          considered to be of full rank. If the user sets TOL <= 0,
          then an implicitly computed, default tolerance, defined by
          TOLDEF = N*EPS,  is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not relevant if COND = 'U' or 'N'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          Denote Full = ( BN <= 1 or  BSN = 0 );
                 Comp = ( BN >  1 and BSN > 0 ).
          LDWORK >= 2*N,           if Full and COND = 'E';
          LDWORK >= 2*MAX(BSN,ST), if Comp and COND = 'E';
          LDWORK >= 0,   in the remaining cases.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Block back or forward substitution is used (depending on TRANS
  and UPLO), exploiting the special structure and storage scheme of
  the matrix R. If a submatrix R_k, k = 1:l+1, is singular, a local
  basic least squares solution is computed. Therefore, the returned
  result is not the basic least squares solution for the whole
  problem, but a concatenation of (least squares) solutions of the
  individual subproblems involving R_k, k = 1:l+1 (with adapted
  right hand sides).
Numerical Aspects 
                                 2    2
  The algorithm requires 0(BN*BSN + ST + N*ST) operations and is
  backward stable, if R is nonsingular.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BS.html000077500000000000000000000213111201767322700160730ustar00rootroot00000000000000 NF01BS - SLICOT Library Routine Documentation

NF01BS

QR factorization with column pivoting for Wiener system identification

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the QR factorization of the Jacobian matrix J, as
  received in compressed form from SLICOT Library routine NF01BD,

         /  dy(1)/dwb(1)  |  dy(1)/ dtheta  \
    Jc = |       :        |       :         | ,
         \  dy(L)/dwb(L)  |  dy(L)/ dtheta  /

  and to apply the transformation Q on the error vector e (in-situ).
  The factorization is J*P = Q*R, where Q is a matrix with
  orthogonal columns, P a permutation matrix, and R an upper
  trapezoidal matrix with diagonal elements of nonincreasing
  magnitude for each block column (see below). The 1-norm of the
  scaled gradient is also returned.

  Actually, the Jacobian J has the block form

    dy(1)/dwb(1)       0         .....       0        dy(1)/dtheta
         0        dy(2)/dwb(2)   .....       0        dy(2)/dtheta
       .....         .....       .....     .....         .....
         0           .....         0    dy(L)/dwb(L)  dy(L)/dtheta

  but the zero blocks are omitted. The diagonal blocks have the
  same size and correspond to the nonlinear part. The last block
  column corresponds to the linear part. It is assumed that the
  Jacobian matrix has at least as many rows as columns. The linear
  or nonlinear parts can be empty. If L <= 1, the Jacobian is
  represented as a full matrix.
Specification 
      SUBROUTINE NF01BS( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS,
     $                   GNORM, IPVT, DWORK, LDWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of columns of the Jacobian matrix J.
          N = BN*BSN + ST >= 0.  (See parameter description below.)

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix J, as follows:
          IPAR(1) must contain ST, the number of parameters
                  corresponding to the linear part.  ST >= 0.
          IPAR(2) must contain BN, the number of blocks, BN = L,
                  for the parameters corresponding to the nonlinear
                  part.  BN >= 0.
          IPAR(3) must contain BSM, the number of rows of the blocks
                  J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the
                  number of rows of the matrix J, if BN <= 1.
                  BN*BSM >= N, if BN > 0;
                  BSM >= N,    if BN = 0.
          IPAR(4) must contain BSN, the number of columns of the
                  blocks J_k, k = 1:BN.  BSN >= 0.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 4.

  FNORM   (input) DOUBLE PRECISION
          The Euclidean norm of the vector e.  FNORM >= 0.

  J       (input/output) DOUBLE PRECISION array, dimension (LDJ, NC)
          where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
          On entry, the leading NR-by-NC part of this array must
          contain the (compressed) representation (Jc) of the
          Jacobian matrix J, where NR = BSM if BN <= 1, and
          NR = BN*BSM, if BN > 1.
          On exit, the leading N-by-NC part of this array contains
          a (compressed) representation of the upper triangular
          factor R of the Jacobian matrix. The matrix R has the same
          structure as the Jacobian matrix J, but with an additional
          diagonal block. Note that for efficiency of the later
          calculations, the matrix R is delivered with the leading
          dimension MAX(1,N), possibly much smaller than the value
          of LDJ on entry.

  LDJ     (input/output) INTEGER
          The leading dimension of array J.
          On entry, LDJ >= MAX(1,NR).
          On exit,  LDJ >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (NR)
          On entry, this array contains the vector e,
          e = vec( Y - y ), where Y is set of output samples, and
          vec denotes the concatenation of the columns of a matrix.
          On exit, this array contains the updated vector Z*Q'*e,
          where Z is the block row permutation matrix used in the
          QR factorization of J (see METHOD).

  JNORMS  (output) DOUBLE PRECISION array, dimension (N)
          This array contains the Euclidean norms of the columns
          of the Jacobian matrix, considered in the initial order.

  GNORM   (output) DOUBLE PRECISION
          If FNORM > 0, the 1-norm of the scaled vector J'*e/FNORM,
          with each element i further divided by JNORMS(i) (if
          JNORMS(i) is nonzero).
          If FNORM = 0, the returned value of GNORM is 0.

  IPVT    (output) INTEGER array, dimension (N)
          This array defines the permutation matrix P such that
          J*P = Q*R. Column j of P is column IPVT(j) of the identity
          matrix.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 1,      if N = 0 or BN <= 1 and BSM = N = 1;
                            otherwise,
          LDWORK >= 4*N+1,  if BN <= 1 or  BSN = 0;
          LDWORK >= JWORK,  if BN >  1 and BSN > 0, where JWORK is
                            given by the following procedure:
           JWORK  = BSN + MAX(3*BSN+1,ST);
           JWORK  = MAX(JWORK,4*ST+1),         if BSM > BSN;
           JWORK  = MAX(JWORK,(BSM-BSN)*(BN-1)),
                                               if BSN < BSM < 2*BSN.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  A QR factorization with column pivoting of the matrix J is
  computed, J*P = Q*R.

  If l = L > 1, the R factor of the QR factorization has the same
  structure as the Jacobian, but with an additional diagonal block.
  Denote

      /   J_1    0    ..   0   |  L_1  \
      |    0    J_2   ..   0   |  L_2  |
  J = |    :     :    ..   :   |   :   | .
      |    :     :    ..   :   |   :   |
      \    0     0    ..  J_l  |  L_l  /

  The algorithm consists in two phases. In the first phase, the
  algorithm uses QR factorizations with column pivoting for each
  block J_k, k = 1:l, and applies the orthogonal matrix Q'_k to the
  corresponding part of the last block column and of e. After all
  block rows have been processed, the block rows are interchanged
  so that the zeroed submatrices in the first l block columns are
  moved to the bottom part. The same block row permutation Z is
  also applied to the vector e. At the end of the first phase,
  the structure of the processed matrix J is

      /   R_1    0    ..   0   |  L^1_1  \
      |    0    R_2   ..   0   |  L^1_2  |
      |    :     :    ..   :   |    :    | .
      |    :     :    ..   :   |    :    |
      |    0     0    ..  R_l  |  L^1_l  |
      |    0     0    ..   0   |  L^2_1  |
      |    :     :    ..   :   |    :    |
      \    0     0    ..   0   |  L^2_l  /

  In the second phase, the submatrix L^2_1:l is triangularized
  using an additional QR factorization with pivoting. (The columns
  of L^1_1:l are also permuted accordingly.) Therefore, the column
  pivoting is restricted to each such local block column.

  If l <= 1, the matrix J is triangularized in one phase, by one
  QR factorization with pivoting. In this case, the column
  pivoting is global.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BU.html000077500000000000000000000125351201767322700161050ustar00rootroot00000000000000 NF01BU - SLICOT Library Routine Documentation

NF01BU

Computation of the matrix J' J + c I, for the Jacobian J given in a compressed form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix J'*J + c*I, for the Jacobian J as received
  from SLICOT Library routine NF01BD:

       /  dy(1)/dwb(1)  |  dy(1)/dtheta  \
  Jc = |       :        |       :        | .
       \  dy(L)/dwb(L)  |  dy(L)/dtheta  /

  This is a compressed representation of the actual structure

      /   J_1    0    ..   0   |  L_1  \
      |    0    J_2   ..   0   |  L_2  |
  J = |    :     :    ..   :   |   :   | .
      |    :     :    ..   :   |   :   |
      \    0     0    ..  J_L  |  L_L  /
Specification 
      SUBROUTINE NF01BU( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J,
     $                   LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  STOR    CHARACTER*1
          Specifies the storage scheme for the symmetric
          matrix J'*J + c*I, as follows:
          = 'F' :  full storage is used;
          = 'P' :  packed storage is used.

  UPLO    CHARACTER*1
          Specifies which part of the matrix J'*J + c*I is stored,
          as follows:
          = 'U' :  the upper triagular part is stored;
          = 'L' :  the lower triagular part is stored.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix J'*J + c*I.
          N = BN*BSN + ST >= 0.  (See parameter description below.)

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix J, as follows:
          IPAR(1) must contain ST, the number of parameters
                  corresponding to the linear part.  ST >= 0.
          IPAR(2) must contain BN, the number of blocks, BN = L,
                  for the parameters corresponding to the nonlinear
                  part.  BN >= 0.
          IPAR(3) must contain BSM, the number of rows of the blocks
                  J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the
                  number of rows of the matrix J, if BN <= 1.
          IPAR(4) must contain BSN, the number of columns of the
                  blocks J_k, k = 1:BN.  BSN >= 0.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 4.

  DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
          The real parameters needed for solving the problem.
          The entry DPAR(1) must contain the real scalar c.

  LDPAR   (input) INTEGER
          The length of the array DPAR.  LDPAR >= 1.

  J       (input) DOUBLE PRECISION array, dimension (LDJ, NC)
          where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
          The leading NR-by-NC part of this array must contain
          the (compressed) representation (Jc) of the Jacobian
          matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM,
          if BN > 1.

  LDJ     (input) INTEGER
          The leading dimension of array J.  LDJ >= MAX(1,NR).

  JTJ     (output) DOUBLE PRECISION array,
                   dimension (LDJTJ,N),    if STOR = 'F',
                   dimension (N*(N+1)/2),  if STOR = 'P'.
          The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if
          STOR = 'P') part of this array contains the upper or
          lower triangle of the matrix J'*J + c*I, depending on
          UPLO = 'U', or UPLO = 'L', respectively, stored either as
          a two-dimensional, or one-dimensional array, depending
          on STOR.

  LDJTJ   INTEGER
          The leading dimension of the array JTJ.
          LDJTJ >= MAX(1,N), if STOR = 'F'.
          LDJTJ >= 1,        if STOR = 'P'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          Currently, this array is not used.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix product is computed columnn-wise, exploiting the
  symmetry. BLAS 3 routines DGEMM and DSYRK are used if STOR = 'F',
  and BLAS 2 routine DGEMV is used if STOR = 'P'.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BV.html000077500000000000000000000106241201767322700161030ustar00rootroot00000000000000 NF01BV - SLICOT Library Routine Documentation

NF01BV

Computation of the matrix J' J + c I, for a full Jacobian J (one output variable)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix J'*J + c*I, for the Jacobian J as received
  from SLICOT Library routine NF01BY, for one output variable.

  NOTE: this routine must have the same arguments as SLICOT Library
  routine NF01BU.
Specification 
      SUBROUTINE NF01BV( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J,
     $                   LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  STOR    CHARACTER*1
          Specifies the storage scheme for the symmetric
          matrix J'*J + c*I, as follows:
          = 'F' :  full storage is used;
          = 'P' :  packed storage is used.

  UPLO    CHARACTER*1
          Specifies which part of the matrix J'*J + c*I is stored,
          as follows:
          = 'U' :  the upper triagular part is stored;
          = 'L' :  the lower triagular part is stored.
Input/Output Parameters 
  N       (input) INTEGER
          The number of columns of the Jacobian matrix J.  N >= 0.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix J, as follows:
          IPAR(1) must contain the number of rows M of the Jacobian
                  matrix J.  M >= 0.
          IPAR is provided for compatibility with SLICOT Library
          routine MD03AD.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 1.

  DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
          The real parameters needed for solving the problem.
          The entry DPAR(1) must contain the real scalar c.

  LDPAR   (input) INTEGER
          The length of the array DPAR.  LDPAR >= 1.

  J       (input) DOUBLE PRECISION array, dimension (LDJ,N)
          The leading M-by-N part of this array must contain the
          Jacobian matrix J.

  LDJ     INTEGER
          The leading dimension of the array J.  LDJ >= MAX(1,M).

  JTJ     (output) DOUBLE PRECISION array,
                   dimension (LDJTJ,N),    if STOR = 'F',
                   dimension (N*(N+1)/2),  if STOR = 'P'.
          The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if
          STOR = 'P') part of this array contains the upper or
          lower triangle of the matrix J'*J + c*I, depending on
          UPLO = 'U', or UPLO = 'L', respectively, stored either as
          a two-dimensional, or one-dimensional array, depending
          on STOR.

  LDJTJ   INTEGER
          The leading dimension of the array JTJ.
          LDJTJ >= MAX(1,N), if STOR = 'F'.
          LDJTJ >= 1,        if STOR = 'P'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          Currently, this array is not used.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The matrix product is computed columnn-wise, exploiting the
  symmetry. BLAS 3 routine DSYRK is used if STOR = 'F', and BLAS 2
  routine DGEMV is used if STOR = 'P'.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BW.html000077500000000000000000000107221201767322700161030ustar00rootroot00000000000000 NF01BW - SLICOT Library Routine Documentation

NF01BW

Matrix-vector product x <-- (J' J + c I) x, for J in a compressed form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrix-vector product x <-- (J'*J + c*I)*x, for the
  Jacobian J as received from SLICOT Library routine NF01BD:

       /  dy(1)/dwb(1)  |  dy(1)/dtheta  \
  Jc = |       :        |       :        | .
       \  dy(L)/dwb(L)  |  dy(L)/dtheta  /

  This is a compressed representation of the actual structure

      /   J_1    0    ..   0   |  L_1  \
      |    0    J_2   ..   0   |  L_2  |
  J = |    :     :    ..   :   |   :   | .
      |    :     :    ..   :   |   :   |
      \    0     0    ..  J_L  |  L_L  /
Specification 
      SUBROUTINE NF01BW( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N
C     .. Array Arguments ..
      DOUBLE PRECISION  DPAR(*), DWORK(*), J(LDJ,*), X(*)
      INTEGER           IPAR(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The dimension of the vector x.
          N = BN*BSN + ST >= 0.  (See parameter description below.)

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix J, as follows:
          IPAR(1) must contain ST, the number of parameters
                  corresponding to the linear part.  ST >= 0.
          IPAR(2) must contain BN, the number of blocks, BN = L,
                  for the parameters corresponding to the nonlinear
                  part.  BN >= 0.
          IPAR(3) must contain BSM, the number of rows of the blocks
                  J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the
                  number of rows of the matrix J, if BN <= 1.
          IPAR(4) must contain BSN, the number of columns of the
                  blocks J_k, k = 1:BN.  BSN >= 0.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 4.

  DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
          The real parameters needed for solving the problem.
          The entry DPAR(1) must contain the real scalar c.

  LDPAR   (input) INTEGER
          The length of the array DPAR.  LDPAR >= 1.

  J       (input) DOUBLE PRECISION array, dimension (LDJ, NC)
          where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
          The leading NR-by-NC part of this array must contain
          the (compressed) representation (Jc) of the Jacobian
          matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM,
          if BN > 1.

  LDJ     (input) INTEGER
          The leading dimension of array J.  LDJ >= MAX(1,NR).

  X       (input/output) DOUBLE PRECISION array, dimension
          (1+(N-1)*INCX)
          On entry, this incremented array must contain the
          vector x.
          On exit, this incremented array contains the value of the
          matrix-vector product (J'*J + c*I)*x.

  INCX    (input) INTEGER
          The increment for the elements of X.  INCX >= 1.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= NR.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The associativity of matrix multiplications is used; the result
  is obtained as:  x_out = J'*( J*x ) + c*x.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BX.html000077500000000000000000000070201201767322700161010ustar00rootroot00000000000000 NF01BX - SLICOT Library Routine Documentation

NF01BX

Matrix-vector product x <-- (A' A + c I) x, for a full matrix A

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute (J'*J + c*I)*x, where J is an m-by-n real matrix, c is
  a real scalar, I is the n-by-n identity matrix, and x is a real
  n-vector.

  NOTE: this routine must have the same arguments as SLICOT Library
  routine NF01BW.
Specification 
      SUBROUTINE NF01BX( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX,
     $                   DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N
C     .. Array Arguments ..
      INTEGER           IPAR(*)
      DOUBLE PRECISION  DPAR(*), DWORK(*), J(LDJ,*), X(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of columns of the Jacobian matrix J.  N >= 0.

  IPAR    (input) INTEGER array, dimension (LIPAR)
          The integer parameters describing the structure of the
          matrix J, as follows:
          IPAR(1) must contain the number of rows M of the Jacobian
                  matrix J.  M >= 0.
          IPAR is provided for compatibility with SLICOT Library
          routine MD03AD.

  LIPAR   (input) INTEGER
          The length of the array IPAR.  LIPAR >= 1.

  DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
          The real parameters needed for solving the problem.
          The entry DPAR(1) must contain the real scalar c.

  LDPAR   (input) INTEGER
          The length of the array DPAR.  LDPAR >= 1.

  J       (input) DOUBLE PRECISION array, dimension (LDJ,N)
          The leading M-by-N part of this array must contain the
          Jacobian matrix J.

  LDJ     INTEGER
          The leading dimension of the array J.  LDJ >= MAX(1,M).

  X       (input/output) DOUBLE PRECISION array, dimension
          (1+(N-1)*abs(INCX))
          On entry, this incremented array must contain the
          vector x.
          On exit, this incremented array contains the value of the
          matrix-vector product (J'*J + c*I)*x.

  INCX    (input) INTEGER
          The increment for the elements of X.  INCX <> 0.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= M.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The associativity of matrix multiplications is used; the result
  is obtained as:  x_out = J'*( J*x ) + c*x.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/NF01BY.html000077500000000000000000000134261201767322700161110ustar00rootroot00000000000000 NF01BY - SLICOT Library Routine Documentation

NF01BY

Computing the Jacobian of the error function for a neural network (one output variable)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Jacobian of the error function for a neural network
  of the structure

          - tanh(w1*z+b1) -
        /      :            \
      z ---    :          --- sum(ws(i)*...)+ b(n+1)  --- y,
        \      :            /
          - tanh(wn*z+bn) -

  for the single-output case. The Jacobian has the form

             d e(1)  / d WB(1)   ...    d e(1)  / d WB(NWB)
      J =            :                          :           ,
           d e(NSMP) / d WB(1)   ...  d e(NSMP) / d WB(NWB)

  where e(z) is the error function, WB is the set of weights and
  biases of the network (for the considered output), and NWB is
  the number of elements of this set, NWB = IPAR(1)*(NZ+2)+1
  (see below).

  In the multi-output case, this routine should be called for each
  output.

  NOTE: this routine must have the same arguments as SLICOT Library
  routine NF01BD.
Specification 
      SUBROUTINE NF01BY( CJTE, NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z,
     $                   LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  CJTE    CHARACTER*1
          Specifies whether the matrix-vector product J'*e should be
          computed or not, as follows:
          = 'C' :  compute J'*e;
          = 'N' :  do not compute J'*e.
Input/Output Parameters 
  NSMP    (input) INTEGER
          The number of training samples.  NSMP >= 0.

  NZ      (input) INTEGER
          The length of each input sample.  NZ >= 0.

  L       (input) INTEGER
          The length of each output sample.
          Currently, L must be 1.

  IPAR    (input/output) INTEGER array, dimension (LIPAR)
          The integer parameters needed.
          On entry, the first element of this array must contain
          a value related to the number of neurons, n; specifically,
          n = abs(IPAR(1)), since setting IPAR(1) < 0 has a special
          meaning (see below).
          On exit, if IPAR(1) < 0 on entry, then no computations are
          performed, except the needed tests on input parameters,
          but the following values are returned:
          IPAR(1) contains the length of the array J, LJ;
          LDJ     contains the leading dimension of array J.
          Otherwise, IPAR(1) and LDJ are unchanged on exit.

  LIPAR   (input) INTEGER
          The length of the vector IPAR.  LIPAR >= 1.

  WB      (input) DOUBLE PRECISION array, dimension (LWB)
          The leading NWB = IPAR(1)*(NZ+2)+1 part of this array
          must contain the weights and biases of the network,
          WB = ( w(1,1), ..., w(1,NZ), ..., w(n,1), ...,  w(n,NZ),
                 ws(1), ..., ws(n), b(1), ..., b(n+1) ),
          where w(i,j) are the weights of the hidden layer,
          ws(i) are the weights of the linear output layer and
          b(i) are the biases.

  LWB     (input) INTEGER
          The length of array WB.  LWB >= NWB.

  Z       (input) DOUBLE PRECISION array, dimension (LDZ, NZ)
          The leading NSMP-by-NZ part of this array must contain the
          set of input samples,
          Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ).

  LDZ     INTEGER
          The leading dimension of array Z.  LDZ >= MAX(1,NSMP).

  E       (input) DOUBLE PRECISION array, dimension (NSMP)
          If CJTE = 'C', this array must contain the error vector e.
          If CJTE = 'N', this array is not referenced.

  J       (output) DOUBLE PRECISION array, dimension (LDJ, NWB)
          The leading NSMP-by-NWB part of this array contains the
          Jacobian of the error function.

  LDJ     INTEGER
          The leading dimension of array J.  LDJ >= MAX(1,NSMP).
          Note that LDJ is an input parameter, except for
          IPAR(1) < 0 on entry, when it is an output parameter.

  JTE     (output) DOUBLE PRECISION array, dimension (NWB)
          If CJTE = 'C', this array contains the matrix-vector
          product J'*e.
          If CJTE = 'N', this array is not referenced.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          This argument is included for combatibility with SLICOT
          Library routine NF01BD.

  LDWORK  INTEGER
          Normally, the length of the array DWORK.  LDWORK >= 0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The Jacobian is computed analytically.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/ODESolver.html000077500000000000000000004124161201767322700170160ustar00rootroot00000000000000 IB01AD - SLICOT Library Routine Documentation

ODESolver

Solver for Ordinary Differential Equations (driver)

[Specification][Arguments][Method][References][Comments][Example]

Purpose 

  Interface for using a common entry point, DSblock compatible for
  defining Differential Algebraic Equations using several packages.


  The equations follow the form:

               dx/dt = f(x(t), (t), p, t)
                y(t) = g(x(t), (t), p, t)

  The user must define only the subroutines ODEDER and ODEOUT and
  the Jacobians (JACFX, JACFU, JACFP) if used, and the interface 
  adapts the structure to fit all the codes
Specification 
      SUBROUTINE ODESolver(ISOLVER, CODEDER_, CODEOUT_, CJACFX_, 
     $                     CJACFU_, CJACFP_,
     $                     NX, NY, NU, TINI, TOUT, X, U, Y,
     $                     IPAR, DPAR, RTOL, ATOL,
     $                     IWORK, LIWORK, DWORK, LDWORK,
     $                     IWARN, INFO)
      .. Scalar Arguments ..
      DOUBLE PRECISION   RTOL, TINI, TOUT
      INTEGER            ISOLVER, IWARN, INFO, NX, NY, NU,
     $                   LDWORK, LIWORK
      CHARACTER*9        CODEDER_, CODEOUT_, CJACFX_, CJACFU_, CJACFP_
      .. Array Arguments ..
      DOUBLE PRECISION   ATOL(*), DWORK(LDWORK), DPAR(*), 
     $                   X(NX), Y(NY), U(NU)
      INTEGER            IWORK(LIWORK), IPAR(*)
Arguments

Mode Parameters 

  ISOLVER     (input) INTEGER
             Indicates the nonlinear solver package to be used:
             = 1: LSODE,
             = 2: LSODA,
             = 3: LSODES,
             = 4: RADAU5,
             = 5: DASSL,
             = 6: DASPK,
             = 7: DGELDA.
Input/Output Parameters 
  ODEDER  (input) EXTERNAL                                  
          Evaluates the right hand side f of the ODE.       
                                                            
  ODEOUT  (input) EXTERNAL                                  
          Evaluates the output signals function g.          
                                                            
  JACFX   (input) EXTERNAL                                  
          Evaluates the jacobian matrix with respect to X.  
                                                            
  JACFU   (input) EXTERNAL                                  
          Evaluates the jacobian matrix with respect to U.  
                                                            
  JACFP   (input) EXTERNAL                                  
          Evaluates the jacobian matrix with respect to P.  
                                                            
  NX      (input) INTEGER                                   
          Dimension of the state vector.                    
                                                            
  NY      (input) INTEGER                                   
          Dimension of the output vector.                   
                                                            
  NU      (input) INTEGER                                   
          Dimension of the input vector.
  TINI    (input) DOUBLE PRECISION                               
          Initial value of time.                                 
                                                                 
  TOUT    (input) DOUBLE PRECISION                               
          Final value of time.                                   
                                                                 
  X       (input/output) DOUBLE PRECISION array, dimension (NX)  
          On entry, array containing the initial state variables.
          On exit, it has the last value of the state variables. 
                                                                 
  U       (input) DOUBLE PRECISION array, dimension (NU)         
          Array containing the input initial values.             
                                                                 
  Y       (input/output) DOUBLE PRECISION array, dimension (NY)  
          On entry, array containing the initial values of Y.    
          On exit, it has the results of the system.             
                                                                 
  IPAR    (input/output) INTEGER array, dimension (230)          
          INPUT:                                                 
             1..15   General                                     
            16..25   ODEPACK                                     
             26..35   RADAU5                           
            36..50   DASSL/PK                         
            51..60   GELDA                            
            61..100  Reserved                         
          OUTPUT:                                     
           101..110  General                          
           111..125  ODEPACK                          
           126..135  RADAU5                           
           136..145  DASSL/PK                         
           146..155  GELDA                            
           156..200  Reserved                         
          Any Mode:                                   
           201..     User Available                   
                                                      
          Common integer parameters for SOLVERS:      
             IPAR(1), Tolerance mode                  
                 0 : both RTOL and ATOL are scalars   
                 1 : RTOL is scalar and ATOL is vector
                 2 : both RTOL and ATOL are vectors               
             IPAR(2), Compute Output Values, must be 1            
             IPAR(3), mf, Method flag                             
                 0 : No jacobian used (non-stiff method).         
                 1 : User supplied full jacobian (stiff).         
                 2 : User supplied banded jacobian (stiff).       
                 3 : User supplied sparse jacobian (stiff).       
                10 : internally generated full jacobian (stiff).  
                11 : internally generated banded jacobian (stiff).
                12 : internally generated sparse jacobian (stiff).
             IPAR(5), Maximum number of steps allowed during one  
                call to the solver.                               
             IPAR(6), ml, lower half-bandwithds of the banded     
                jacobian, excluding tne main diagonal.            
             IPAR(7), mu, upper half-bandwithds of the banded     
                jacobian, excluding tne main diagonal.            
             IPAR(8), Flag to generate extra printing at method   
                switches:                                         
                    0 means no extra printing                     
                    1 for minimal printing                        
                    2 for full printing                           
             IPAR(101) = Number of steps taken for the problem. 
             IPAR(102) = Number of f evaluations.               
             IPAR(103) = Number of jacobian evaluations.          
                                                                    
          Common parameters for ODEPACK, DASSL and DASPK solvers:   
             IPAR(111) = The method order last used(successfully).  
             IPAR(112) = The order to be attempted on the next step.
                                                                    
          Common parameters for ODEPACK solver:                     
             IPAR(16), Status Flag                                  
             IPAR(17), Optional inputs                              
             IPAR(18), Maximum number of messages printed,          
                default value is 10.                                
             IPAR(113) = Index of the component of largest in the   
                weighted local error vector ( e(i)/ewt(i) ).        
             IPAR(114) = Length of rwork actually required.         
             IPAR(115) = Length of iwork actually required.         
                                                                    
           - LSODE and LSODES                                       
             IPAR(19), Maximum order to be allowed.                 
                12 if meth = 1                                      
                 5 if meth = 2                                      
                If exceds the default value, it will be reduced     
                to the default value.                              
                                                                   
           - LSODES                                                
             IPAR(118), Number of nonzero elements in the jacobian 
                matrix, including the diagonal (miter = 1 or 2).   
             IPAR(119), Number of groups of column indices, used in
                difference quotient jacobian aproximations if      
                miter = 2.                                         
             IPAR(120), Number of sparse LU decompositions.        
             IPAR(121), Base address in rwork of the history array.
             IPAR(122), Base address of the structure descriptor   
                array ian.                                         
             IPAR(123), Base address of the structure descriptor   
                array jan.                                         
             IPAR(124), Number of nonzero elements in the strict   
                lower triangle of the LU factorization.            
             IPAR(125),  Number of nonzero elements in the strict  
                upper triangle of the LU factorization.            
                                                                   
           - LSODA                                                 
             IPAR(22), Maximum order to be allowed for the         
                nonstiff method, default value is 12.              
                If exceds the default value, it will be reduced   
                to the default value.                             
             IPAR(23), Maximum order to be allowed for the stiff  
                method, default value is 5.                       
                If exceds the default value, it will be reduced   
                to the default value.                             
             IPAR(116), Method indicator for the last successful  
                step  1 adams (nonstiff)                          
                      2 bdf (stiff)                               
             IPAR(117), Current method indicator                  
                1 adams (nonstiff)                                
                2 bdf (stiff)                                     
                                                                  
          Parameters for RADAU5 solver:                           
             IPAR(26) Transforms the Jacobian matrix to           
                       Hessenberg form.                           
             IPAR(27) Maximum number of Newton iterations.        
             IPAR(28) Starting values for Newton's method         
                   if 0 then is taken the extrapolated collocation
                        solution                                  
                   if not equal 0 zero values are used.           
             IPAR(29) Dimension of the index 1 variables.         
             IPAR(30) Dimension of the index 2 variables.         
             IPAR(31) Dimension of the index 3 variables.         
             IPAR(32) Switch for step size strategy               
                   0,1 Mod. Predictive controller(Gustafsson)     
                   2   Classical step size control                
             IPAR(33) Value of M1.                                
             IPAR(34) Value of M2.                                
             IPAR(126), Number of accepted steps.                 
             IPAR(127), Number of rejected steps.                 
             IPAR(128), Number of LU-Decompositions of both       
                 matrices                                         
             IPAR(129), Number of forward-backward substitutions, 
                 of both systems.                                 
                                                                  
          Common parameters for DASSL and DASPK solvers:          
             IPAR(36),  this parameter enables the code to        
                  initialize itself. Must set to 0 to indicate the
                  start of every new problem.                     
                       0: Yes. (On each new problem)              
                       1: No. (Allows 500 new steps)              
             IPAR(37),  code solve the problem without invoking   
                  any special non negativity contraints:          
                       0: Yes                                      
                       1: To have constraint checking only in the  
                         initial condition calculation.            
                       2: To enforce nonnegativity in X during the 
                         integration.                              
                       3: To enforce both options 1 and 2.         
                                                                   
             IPAR(38), Solver try to compute the initial T, X      
                   and XPRIME:                                     
                       0: The initial T, X and XPRIME are          
                         consistent.                               
                       1: Given X_d calculate X_a and X'_d         
                       2: Given X' calculate X.                    
                       ( X_d differential variables in X           
                         X_a algebrac variables in X )             
             IPAR(136), Total number of error test failures so far.
             IPAR(137), Total number of convergence test failures. 
                                                                   
           -Parameters for DASPK                                   
             IPAR(39), DASPK use:                                  
                       0: direct methods (compatible with DASSL)   
                       1: Krylov method                            
                       2: Krylov method + Jac                             
             IPAR(40),  DASPK uses scalars MAXLm KMP, NRMAX and EPLI      
                     when uses Krylov method.                             
                       0: uses default values.                            
                       1: uses user values.                               
             IPAR(41), Proceed to the integration after the initial       
                    condition calculation is done. Used when INFOV(11)>0  
                                                                          
                       0: Yes                                             
                       1: No                                              
             IPAR(42), Errors are controled localy on all the variables.  
                       0: Yes                                             
                       1: No                                              
             IPAR(43), Use default values for initial condition heuristic 
                      controls.                                           
                       0: Yes                                             
                       1: No and provide MXNIT, MXNJ, MXNH, LSOFF, STPTOL,
                         EPINIT.                                          
             IPAR(138), number of convergence failures of the linear      
                      iteration                                           
             IPAR(139), length of IWORK actually required.                
             IPAR(140), length of RWORK actually required.                
             IPAR(141), total number of nonlinear iterations.     
             IPAR(142), total number of linear (Krylov) iterations
             IPAR(143), number of PSOL calls.                     
                                                                  
  DPAR    (input/output) DOUBLE PRECISION array, dimension (202)  
          INPUT:                                                  
             1..15   General                                      
            16..25   ODEPACK                                      
            26..35   RADAU5                                       
            36..50   DASSL/PK                                     
            51..60   GELDA                                        
            61..100  Reserved                                     
          OUTPUT:                                                 
           101..110  General                                      
           111..125  ODEPACK                                      
           126..135  RADAU5                                       
           136..145  DASSL/PK                                     
           146..155  GELDA                                        
           156..200  Reserved                                     
          Any Mode:                                               
           201..     User Available                                 
                                                                    
          Common real parameters for SOLVERS:                       
              DPAR(1), Initial step size guess. Optional in:        
                        ODEPACK, DASSL, ..                          
              DPAR(2), Maximum absolute step size allowed.          
                                                                    
          Common parameters for ODEPACK and DASSL:                  
              DPAR(111), Step size in t last used (successfully).   
              DPAR(113), Current value of the independent variable  
                 which the solver has actually reached              
                                                                    
          Common parameters for ODEPACK solvers:                    
              DPAR(16), Critical value of t which the solver is not 
                overshoot.                                          
              DPAR(17), Minimum absolute step size allowed.         
              DPAR(112), Step size to be attempted on the next step.
              DPAR(18), Tolerance scale factor, greater than 1.0.   
                                                                    
            - LSODA                                                 
              DPAR(115) Value of t at the time of the last method   
                 switch, if any.                                                                                                      
                                                                  
            - LSODA                                               
              DPAR(115) Value of t at the time of the last method 
                 switch, if any.                                  
                                                                  
            - LSODES                                              
              DPAR(19), The element threshhold for sparsity       
                determination when moss = 1 or 2.                 
                                                                  
          Parameters for RADAU5 solver:                           
              DPAR(26), The rounding unit, default 1E-16.         
              DPAR(27), The safety factor in step size prediction,
                default 0.9D0.                                    
              DPAR(28), Decides whether the jacobian should be    
                recomputed, default 0.001D0.                      
              DPAR(29), Stopping criterion for Newton's method,   
                default MIN(0.03D0, RTOL(1)**0.5D0)               
              DPAR(30), DPAR(31): This saves, together with a     
                large DPAR(28), LU-decompositions and computing   
                time for large systems.                           
              DPAR(32), DPAR(33), Parameters for step size        
                selection.                       
                                                 
          Parameters for DASSL and DASPK solvers:
              DPAR(36), Stopping point (Tstop)
Tolerances 
   RTOL    DOUBLE PREISION                                         
           Relative Tolerance.                                     
                                                                   
   ATOL    DOUBLE PREISION                                         
           Absolute Tolerance.
Workspace 
   IWORK   INTEGER array, dimension (LIWORK)                       
                                                                   
   LIWORK  INTEGER                                                 
           Size of IWORK, depending on solver:                     
           - LSODE                                                 
               20        for mf = 10,                              
               20 + neq  for mf = 21, 22, 24, or 25.               
               if mf = 24, 25, input in iwork(1),iwork(2) the lower
                  and upper half-bandwidths ml,mu.                 
           -LSODA                                                  
               20+NX                                               
           -LSODES                                                 
               30                                                        
           -DASSL                                                        
               20+NEQ                                                    
                                                                         
   DWORK   DOUBLE PREISION array, dimension (LDWORK)                     
                                                                         
   LDWORK  INTEGER                                                       
           Size of DWORK, depending on solver:                           
           - LSODE                                                       
              20+16*NX                       ,  IPAR(3) = 10,            
              22+ 9*NX+NX**2                 ,  IPAR(3) = 21 or 22,      
              22+10*NX+(2*IPAR(4)+IPAR(9))*NX,  IPAR(3) = 24 or 25.      
           - LSODA                                                       
              22+NX*max(16,NX+9)                                         
           - LSODES                                                      
              20+16*NX                                , mf=10            
              20+(2+1./lenrat)*nnz + (11+9./lenrat)*NX, mf=121,222       
           - DASSL                                                       
              >= 40 LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2, IPAR(3) = 1 or 10 
              >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ,    IPAR(3) = 2       
              >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ                       
                             +2*(NEQ/(ML+MU+1)+1),     IPAR(3) = 11
Warning Indicator 
    IWARN   INTEGER
            = 0:  no warning;
            = 1: LSODE/LSODA/LSODES/RADAU5 do not use
                  the input vector as argument;
            = 2:  Only the 1st element of RTOL is used;
            = 3:  Method (IPAR(3)) not allowed with
                  LSODE/LSODA/LSODES/RADAU5/DASSL/DASPK;
            = 4:  Only the 1st element of ATOL is used;
            = 5:  Option not allowed for IPAR(37);
            = 6:  Option not allowed for IPAR(38).
Error Indicator 
     INFO    INTEGER
            = 0:  Successful exit;
            < 0:  If INFO = -i, the i-th argument had an illegal
                  value;
            = 1:  Wrong tolerance mode;
            = 2:  Sparse storage (IPAR(4)=1) incompatible with
                  LSODE/LSODA/RADAU5;
            = 3:  Dense storage (IPAR(4)=0) incompatible with LSODES
            = 100+ERROR: ODEDER returned ERROR
            = 200+ERROR: RADAU5 returned -ERROR
            = 300+ERROR: DDASSL returned -ERROR
            = 400+ERROR: DDASPK returned -ERROR
            = 500+ERROR: DGELDA returned -ERROR

Method 
Since the package integrates 9 different solvers, it is possible to solve differential 
equations by means of Backward Differential Formulas, Runge-Kutta, using direct or 
iterative methods (including preconditioning) for the linear system associated, differential 
equations with time-varying coefficients or of order higher than one. The interface facilitates  
the user the work of changing the integrator and testing the results, thus leading a more robust 
and efficient integrated package.
References 
  [1]  A.C. Hindmarsh, Brief Description of ODEPACK: A Systematized Collection 
       of ODE Solvers, http://www.netlib.org/odepack/doc                        
                                                                                
  [2]  L.R. Petzold DASSL Library Documentation, http://www.netlib.org/ode/     
                                                                                
  [3]  P.N. Brown, A.C. Hindmarsh, L.R. Petzold, DASPK Package 1995 Revision  
                                                                                
  [4]  R.S. Maier, Using DASPK on the TMC CM5. Experiences with Two Programming 
       Models, Minesota Supercomputer Center, Technical Report.                 
                                                                                
  [5]  E. Hairer, G. Wanner, Solving Ordinary Dirential Equations II. Stiánd    
       Dirential- Algebraic Problems., Springer Seried in Computational         
       Mathermatics 14, Springer-Verlag 1991, Second Edition 1996.              
                                                                                
  [6]  P. Kunkel, V. Mehrmann, W. Rath und J. Weickert, `GELDA: A Software      
       Package for the Solution of General Linear Dirential Algebraic           
       equations', SIAM Journal Scienti^Lc Computing, Vol. 18, 1997, pp.        
       115 - 138.                                                               
                                                                                
  [7]  M. Otter, DSblock: A neutral description of dynamic systems.             
       Version 3.3, http://www.netlib.org/odepack/doc                           
                                                                                
  [8]  M. Otter, H. Elmqvist, The DSblock model interface for exchanging model 
       components, Proceedings of EUROSIM 95, ed. F.Brenenecker, Vienna, Sep.  
       11-15, 1995                                                             
                                                                               
  [9]  M. Otter, The DSblock model interface, version 4.0, Incomplete Draft,   
       http://dv.op.dlr.de/~otter7dsblock/dsblock4.0a.html                     
                                                                               
  [10] Ch. Lubich, U. Novak, U. Pohle, Ch. Engstler, MEXX - Numerical          
       Software for the Integration of Constrained Mechanical Multibody        
       Systems, http://www.netlib.org/odepack/doc                              
                                                                               
  [11] Working Group on Software (WGS), SLICOT Implementation and Documentation
       Standards (version 1.0), WGS-Report 90-1, Eindhoven University of       
       Technology, May 1990.                                                   
                                                                               
  [12] P. Kunkel and V. Mehrmann, Canonical forms for linear differential-     
       algebraic equations with variable coeÆcients., J. Comput. Appl.         
       Math., 56:225{259, 1994.                                                
                                                                               
  [13] Working Group on Software (WGS), SLICOT Implementation and Documentation
       Standards, WGS-Report 96-1, Eindhoven University of Technology, updated:
       Feb. 1998, ../../REPORTS/rep96-1.ps.Z. 
                                                                              
  [14] A. Varga, Standarization of Interface for Nonlinear Systems Software   
       in SLICOT, Deutsches Zentrum ur Luft un Raumfahrt, DLR. SLICOT-Working 
       Note 1998-4, 1998, Available at                                        
       ../../REPORTS/SLWN1998-4.ps.Z.         
                                                                              
  [15] D. Kirk, Optimal Control Theory: An Introduction, Prentice-Hall.       
       Englewood Cli, NJ, 1970.                                               
                                                                              
  [16] F.L. Lewis and V.L. Syrmos, Optimal Control, Addison-Wesley.           
       New York, 1995.                                                        
                                                                              
  [17] W.M.Lioen, J.J.B de Swart, Test Set for Initial Value Problem Solvers, 
       Technical Report NM-R9615, CWI, Amsterdam, 1996.                       
       http://www.cwi.nl/cwi/projects/IVPTestset/.                            
                                                                              
  [18] V.Hernandez, I.Blanquer, E.Arias, and P.Ruiz,                          
       Definition and Implementation of a SLICOT Standard Interface and the   
       associated MATLAB Gateway for the Solution of Nonlinear Control Systems
       by using ODE and DAE Packages}, Universidad Politecnica de Valencia,   
       DSIC. SLICOT Working Note 2000-3: July 2000. Available at             
       ../../REPORTS/SLWN2000-3.ps.Z.        
                                                                             
  [19] J.J.B. de Swart, W.M. Lioen, W.A. van der Veen, SIDE, November 25,    
       1998. Available at http://www.cwi.nl/cwi/projects/PSIDE/.             
                                                                             
  [20] Kim, H.Young, F.L.Lewis, D.M.Dawson, Intelligent optimal control of   
       robotic manipulators using neural networks.                           
                                                                             
  [21] J.C.Fernandez, E.Arias, V.Hernandez, L.Penalver, High Performance     
       Algorithm for Tracking Trajectories of Robot Manipulators,            
       Preprints of the Proceedings of the 6th IFAC International Workshop on
       Algorithms and Architectures for Real-Time Control (AARTC-2000),      
       pages 127-134.
Numerical Aspects 
  The numerical aspects of the routine lie on the features of the 
  different packages integrated. Several packages are more robust
  than others, and other packages simply cannot deal with problems 
  that others do. For a detailed description of the numerical aspects 
  of each method is recommended to check the references above.
Further Comments 
  Several packages (LSODES, LSOIBT) deal only with sparse matrices.  
  The interface checks the suitability of the methods to the 
  parameters and show a warning message if problems could arise.
Example

Program Text

*     ODESOLVER EXAMPLE PROGRAM TEXT FOR LSODEX PROBLEM
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER LSODE_, LSODA_, LSODES_, RADAU5_, DASSL_, DASPK_, DGELDA_
      PARAMETER (LSODE_  = 1, LSODA_ = 2, LSODES_ = 3)
      PARAMETER (RADAU5_ = 4, DASSL_ = 5, DASPK_  = 6)
      PARAMETER (DGELDA_  = 7)
*
      EXTERNAL IARGC_
      INTEGER IARGC_
      INTEGER NUMARGS
      CHARACTER*80 NAME
      CHARACTER*80 SOLVER
*
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*
      NUMARGS = IARGC_()
*
      CALL GETARG_(0, NAME)
      IF (NUMARGS .NE. 1) THEN
        WRITE (*,*) 'Syntax Error: ',NAME(1:8),' <solver>'
        WRITE (*,*) 'Solvers : LSODE, LSODA, LSODES, RADAU5, DASSL, DASP
     &K'
      ELSE
*
        CALL GETARG_(1, SOLVER)
*
        WRITE (*,*) 'Problem: LSODEX   Solver: ',SOLVER(1:7)
*
        IF (SOLVER(1:5) .EQ. 'LSODE') THEN
          CALL TEST(LSODE_)
        ELSEIF (SOLVER(1:5) .EQ. 'LSODA') THEN
          CALL TEST(LSODA_)
        ELSEIF (SOLVER(1:6) .EQ. 'LSODES') THEN
          CALL TEST(LSODES_)
        ELSEIF (SOLVER(1:6) .EQ. 'RADAU5') THEN
          CALL TEST(RADAU5_)
        ELSEIF (SOLVER(1:5) .EQ. 'DASSL') THEN
          CALL TEST(DASSL_)
        ELSEIF (SOLVER(1:5) .EQ. 'DASPK') THEN
          CALL TEST(DASPK_)
        ELSE
          WRITE (*,*) 'Error: Solver: ', SOLVER,' unknown'
        ENDIF
      ENDIF
*
99999 FORMAT (' ODESOLVER EXAMPLE PROGRAM RESULTS FOR LSODEX PROBLEM'
     .        ,/1X)
      END
*
*
*
*
      SUBROUTINE TEST( ISOLVER )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     Testing subroutine ODESolver
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     ISOLVER  (input) INTEGER
*             Indicates the nonlinear solver package to be used:
*             = 1: LSODE,
*             = 2: LSODA,
*             = 3: LSODES,
*             = 4: RADAU5,
*             = 5: DASSL,
*             = 6: DASPK,
*             = 7: DGELDA.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*     .. Parameters ..
      INTEGER LSODE_, LSODA_, LSODES_, RADAU5_, DASSL_, DASPK_, DGELDA_
      PARAMETER (LSODE_  = 1, LSODA_ = 2, LSODES_ = 3)
      PARAMETER (RADAU5_ = 4, DASSL_ = 5, DASPK_  = 6)
      PARAMETER (DGELDA_  = 7)
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MD, ND, LPAR, LWORK
      PARAMETER        ( MD = 400, ND = 100, LPAR = 250,
     $                   LWORK = 650000 )
*     .. Scalar Arguments ..
      INTEGER  ISOLVER
*     .. Local Scalars ..
      INTEGER          NEQN, NDISC, MLJAC, MUJAC, MLMAS, MUMAS
      INTEGER          IWARN, INFO
      DOUBLE PRECISION ATOL(MD), RTOL, NORM
      LOGICAL          NUMJAC, NUMMAS, CONSIS
*     .. Local Arrays ..
      CHARACTER FULLNM*40, PROBLM*8, TYPE*3
      CHARACTER*9 ODEDER, ODEOUT, JACFX, JACFU, JACFP
      INTEGER          IND(MD), IPAR(LPAR), IWORK(LWORK)
      DOUBLE PRECISION T(0:ND), RPAR(LPAR), DWORK(LWORK)
      DOUBLE PRECISION X(MD), XPRIME(MD), U(MD), Y(MD)
*     .. External Functions ..
      DOUBLE PRECISION DNRM2
      EXTERNAL         DNRM2
*     .. External Subroutines ..
      EXTERNAL         PLSODEX,ILSODEX,SLSODEX
      EXTERNAL         DAXPY
*     .. Executable Statements ..
*
      DO 20 I=1,NEQN
         U(I)=0D0
         Y(I)=0D0
   20 CONTINUE
      DO 40 I=1,LPAR
         IPAR(I)=0
         RPAR(I)=0D0
   40 CONTINUE
      DO 60 I=1,LWORK
         IWORK(I)=0
         DWORK(I)=0D0
   60 CONTINUE
      IPAR(2)=1
*     Get the problem dependent parameters.
      RPAR(1)=1D-3
      IPAR(1)=0
      ATOL(1)=1D-6
      ATOL(2)=1D-10
      ATOL(3)=1D-6
      RTOL=1D-4
      CALL PLSODEX(FULLNM,PROBLM,TYPE,NEQN,NDISC,T,NUMJAC,MLJAC,
     $             MUJAC,NUMMAS,MLMAS,MUMAS,IND)
      CALL ILSODEX(NEQN,T(0),X,XPRIME,CONSIS)
      CALL SLSODEX(NEQN,T(1),XPRIME)

      IF ( TYPE.NE.'ODE' ) THEN
         WRITE ( NOUT, FMT = 99998 )
      ELSE
         WRITE ( NOUT, FMT = 99997 ) FULLNM, PROBLM, TYPE, ISOLVER
         IF ( NUMJAC ) THEN
            IPAR(3)=0
         ELSE
            IPAR(3)=1
         END IF
         IPAR(6)=MLJAC
         IPAR(7)=MUJAC
         ODEDER=''
         ODEOUT=''
         JACFX=''
         JACFU=''
         JACFP=''

         CALL ODESolver( ISOLVER, ODEDER, ODEOUT, JACFX, JACFU, JACFP,
     $                   NEQN, NEQN, NEQN, T(0), T(1), X, U, Y,
     $                   IPAR, RPAR, RTOL, ATOL,
     $                   IWORK, LWORK, DWORK, LWORK, IWARN, INFO )

         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99996 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99995 ) IWARN
            ENDIF
            IF ( NEQN .LE. 10 ) THEN
               WRITE ( NOUT, FMT = 99994 )
               DO 80 I=1,NEQN
                  WRITE ( NOUT, FMT = 99993 ) X(I), XPRIME(I)
   80          CONTINUE
            END IF
            NORM=DNRM2(NEQN,XPRIME,1)
            IF ( NORM.EQ.0D0 ) THEN
               NORM=1D0
            END IF
            CALL DAXPY(NEQN,-1D0,X,1,XPRIME,1)
            NORM=DNRM2(NEQN,XPRIME,1)/NORM
            WRITE ( NOUT, FMT = 99992 ) NORM
         END IF
      END IF
*
99998 FORMAT (' ERROR: This test is only intended for ODE problems')
99997 FORMAT (' ',A,' (',A,' , ',A,') with SOLVER ',I2)
99996 FORMAT (' INFO on exit from ODESolver = ',I3)
99995 FORMAT (' IWARN on exit from ODESolver = ',I3)
99994 FORMAT (' Solution: (calculated) (reference)')
99993 FORMAT (F,F)
99992 FORMAT (' Relative error comparing with the reference solution:'
     $        ,E,/1X)
* *** Last line of TEST ***
      END
 
 
 

      SUBROUTINE ODEDER_( NX, NU, T, X, U, RPAR, IPAR, F, INFO )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     Interface routine between ODESolver and the problem function FEVAL
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     NX       (input) INTEGER
*              Dimension of the state vector.
*
*     NU       (input) INTEGER
*              Dimension of the input vector.
*
*     T        (input) INTEGER
*              The time point where the function is evaluated.
*
*     X        (input) DOUBLE PRECISION array, dimension (NX)
*              Array containing the state variables.
*
*     U        (input) DOUBLE PRECISION array, dimension (NU)
*              Array containing the input values.
*
*     RPAR     (input/output) DOUBLE PRECISION array
*              Array for communication between the driver and FEVAL.
*
*     IPAR     (input/output) INTEGER array
*              Array for communication between the driver and FEVAL.
*
*     F        (output) DOUBLE PRECISION array, dimension (NX)
*              The resulting function value f(T,X).
*
*     Error Indicator
*
*     INFO     INTEGER
*              Return values of error from FEVAL or 100 in case
*              a bad problem was choosen.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*
*     .. Scalar Arguments ..
      INTEGER          NX, NU, INFO
      DOUBLE PRECISION T
*     .. Array Arguments ..
      INTEGER          IPAR(*)
      DOUBLE PRECISION X(NX), U(NU), RPAR(*), F(NX)
*     .. External Subroutines ..
      EXTERNAL         FLSODEX
*     .. Executable Statements ..
      CALL FLSODEX(NX,T,X,X,F,INFO,RPAR,IPAR)
* *** Last line of ODEDER_ ***
      END
 
 
 

      SUBROUTINE  JACFX_( NX, DUMMY, LDFX, T, X, DUMMY2, RPAR, IPAR, FX,
     $                    INFO )
*
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     PURPOSE
*
*     Interface routine between ODESolver and the problem function JEVAL
*
*     ARGUMENTS
*
*     Input/Output Parameters
*
*     NX       (input) INTEGER
*              Dimension of the state vector.
*
*     DUMMY    (input) INTEGER
*
*     LDFX     (input) INTEGER
*              The leading dimension of the array FX.
*
*     T        (input) INTEGER
*              The time point where the derivative is evaluated.
*
*     X        (input) DOUBLE PRECISION array, dimension (NX)
*              Array containing the state variables.
*
*     DUMMY2   (input) DOUBLE PRECISION
*
*     RPAR     (input/output) DOUBLE PRECISION array
*              Array for communication between the driver and FEVAL.
*
*     IPAR     (input/output) INTEGER array
*              Array for communication between the driver and FEVAL.
*
*     FX       (output) DOUBLE PRECISION array, dimension (LDFX,NX)
*              The array with the resulting Jacobian matrix.
*
*     Error Indicator
*
*     INFO     INTEGER
*              Return values of error from JEVAL or 100 in case
*              a bad problem was choosen.
*
*     METHOD
*
*     REFERENCES
*
*     CONTRIBUTORS
*
*     REVISIONS
*
*     -
*
*     KEYWORDS
*
*
*     ******************************************************************
*
*     .. Scalar Arguments ..
      INTEGER          NX, DUMMY, LDFX, INFO
      DOUBLE PRECISION T
*     .. Array Arguments ..
      INTEGER          IPAR(*)
      DOUBLE PRECISION X(NX), DUMMY2(*), RPAR(*), FX(NX)
*     .. External Subroutines ..
      EXTERNAL         JLSODEX
*     .. Executable Statements ..
      CALL JLSODEX(LDFX,NX,T,X,X,FX,INFO,RPAR,IPAR)
* *** Last line of JACFX_ ***
      END

Program Data 

No data required
Program Results 
 ODESOLVER EXAMPLE PROGRAM RESULTS                                        
                                                                         
 Problem: LSODEX   Solver: LSODE                                          
 IWARN on exit from ODESolver =   1                                       
 Solution: (calculated)                                        
 8.287534436182735E-08                                                    
 3.329129749822125E-13                                                    
 1.118553835127275E-07

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.
Return to index slicot-5.0+20101122/doc/SB01BD.html000077500000000000000000000401771201767322700160700ustar00rootroot00000000000000 SB01BD - SLICOT Library Routine Documentation

SB01BD

Pole assignment for a given matrix pair (A,B)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine the state feedback matrix F for a given system (A,B)
  such that the closed-loop state matrix A+B*F has specified
  eigenvalues.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector, i.e. the order of the
          matrix A, and also the number of rows of the matrix B and
          the number of columns of the matrix F.  N >= 0.

  M       (input) INTEGER
          The dimension of input vector, i.e. the number of columns
          of the matrix B and the number of rows of the matrix F.
          M >= 0.

  NP      (input) INTEGER
          The number of given eigenvalues. At most N eigenvalues
          can be assigned.  0 <= NP.

  ALPHA   (input) DOUBLE PRECISION
          Specifies the maximum admissible value, either for real
          parts, if DICO = 'C', or for moduli, if DICO = 'D',
          of the eigenvalues of A which will not be modified by
          the eigenvalue assignment algorithm.
          ALPHA >= 0 if DICO = 'D'.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading N-by-N part of this array contains
          the matrix Z'*(A+B*F)*Z in a real Schur form.
          The leading NFP-by-NFP diagonal block of A corresponds
          to the fixed (unmodified) eigenvalues having real parts
          less than ALPHA, if DICO = 'C', or moduli less than ALPHA,
          if DICO = 'D'. The trailing NUP-by-NUP diagonal block of A
          corresponds to the uncontrollable eigenvalues detected by
          the eigenvalue assignment algorithm. The elements under
          the first subdiagonal are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  WR,WI   (input/output) DOUBLE PRECISION array, dimension (NP)
          On entry, these arrays must contain the real and imaginary
          parts, respectively, of the desired eigenvalues of the
          closed-loop system state-matrix A+B*F. The eigenvalues
          can be unordered, except that complex conjugate pairs
          must appear consecutively in these arrays.
          On exit, if INFO = 0, the leading NAP elements of these
          arrays contain the real and imaginary parts, respectively,
          of the assigned eigenvalues. The trailing NP-NAP elements
          contain the unassigned eigenvalues.

  NFP     (output) INTEGER
          The number of eigenvalues of A having real parts less than
          ALPHA, if DICO = 'C', or moduli less than ALPHA, if
          DICO = 'D'. These eigenvalues are not modified by the
          eigenvalue assignment algorithm.

  NAP     (output) INTEGER
          The number of assigned eigenvalues. If INFO = 0 on exit,
          then NAP = N-NFP-NUP.

  NUP     (output) INTEGER
          The number of uncontrollable eigenvalues detected by the
          eigenvalue assignment algorithm (see METHOD).

  F       (output) DOUBLE PRECISION array, dimension (LDF,N)
          The leading M-by-N part of this array contains the state
          feedback F, which assigns NAP closed-loop eigenvalues and
          keeps unaltered N-NAP open-loop eigenvalues.

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          The leading N-by-N part of this array contains the
          orthogonal matrix Z which reduces the closed-loop
          system state matrix A + B*F to upper real Schur form.

  LDZ     INTEGER
          The leading dimension of array Z.  LDZ >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          The absolute tolerance level below which the elements of A
          or B are considered zero (used for controllability tests).
          If the user sets TOL <= 0, then the default tolerance
          TOL = N * EPS * max(NORM(A),NORM(B)) is used, where EPS is
          the machine precision (see LAPACK Library routine DLAMCH)
          and NORM(A) denotes the 1-norm of A.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LDWORK >= MAX( 1,5*M,5*N,2*N+4*M ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = K:  K violations of the numerical stability condition
                NORM(F) <= 100*NORM(A)/NORM(B) occured during the
                assignment of eigenvalues.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the ordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + B*F)*Z
                along the diagonal.
          = 3:  the number of eigenvalues to be assigned is less
                than the number of possibly assignable eigenvalues;
                NAP eigenvalues have been properly assigned,
                but some assignable eigenvalues remain unmodified.
          = 4:  an attempt is made to place a complex conjugate
                pair on the location of a real eigenvalue. This
                situation can only appear when N-NFP is odd,
                NP > N-NFP-NUP is even, and for the last real
                eigenvalue to be modified there exists no available
                real eigenvalue to be assigned. However, NAP
                eigenvalues have been already properly assigned.
Method 
  SB01BD is based on the factorization algorithm of [1].
  Given the matrices A and B of dimensions N-by-N and N-by-M,
  respectively, this subroutine constructs an M-by-N matrix F such
  that A + BF has eigenvalues as follows.
  Let NFP eigenvalues of A have real parts less than ALPHA, if
  DICO = 'C', or moduli less then ALPHA, if DICO = 'D'. Then:
  1) If the pair (A,B) is controllable, then A + B*F has
     NAP = MIN(NP,N-NFP) eigenvalues assigned from those specified
     by WR + j*WI and N-NAP unmodified eigenvalues;
  2) If the pair (A,B) is uncontrollable, then the number of
     assigned eigenvalues NAP satifies generally the condition
     NAP <= MIN(NP,N-NFP).

  At the beginning of the algorithm, F = 0 and the matrix A is
  reduced to an ordered real Schur form by separating its spectrum
  in two parts. The leading NFP-by-NFP part of the Schur form of
  A corresponds to the eigenvalues which will not be modified.
  These eigenvalues have real parts less than ALPHA, if
  DICO = 'C', or moduli less than ALPHA, if DICO = 'D'.
  The performed orthogonal transformations are accumulated in Z.
  After this preliminary reduction, the algorithm proceeds
  recursively.

  Let F be the feedback matrix at the beginning of a typical step i.
  At each step of the algorithm one real eigenvalue or two complex
  conjugate eigenvalues are placed by a feedback Fi of rank 1 or
  rank 2, respectively. Since the feedback Fi affects only the
  last 1 or 2 columns of Z'*(A+B*F)*Z, the matrix Z'*(A+B*F+B*Fi)*Z
  therefore remains in real Schur form. The assigned eigenvalue(s)
  is (are) then moved to another diagonal position of the real
  Schur form using reordering techniques and a new block is
  transfered in the last diagonal position. The feedback matrix F
  is updated as F <-- F + Fi. The eigenvalue(s) to be assigned at
  each step is (are) chosen such that the norm of each Fi is
  minimized.

  If uncontrollable eigenvalues are encountered in the last diagonal
  position of the real Schur matrix Z'*(A+B*F)*Z, the algorithm
  deflates them at the bottom of the real Schur form and redefines
  accordingly the position of the "last" block.

  Note: Not all uncontrollable eigenvalues of the pair (A,B) are
  necessarily detected by the eigenvalue assignment algorithm.
  Undetected uncontrollable eigenvalues may exist if NFP > 0 and/or
  NP < N-NFP.
References 
  [1] Varga A.
      A Schur method for pole assignment.
      IEEE Trans. Autom. Control, Vol. AC-26, pp. 517-519, 1981.
Numerical Aspects 
                                         3
  The algorithm requires no more than 14N  floating point
  operations. Although no proof of numerical stability is known,
  the algorithm has always been observed to yield reliable
  numerical results.
Further Comments 
  None
Example

Program Text 

*     SB01BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDF, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDF = MMAX,
     $                   LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 5*MMAX,5*NMAX,2*NMAX+4*MMAX ) )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, ANORM, NRM, TOL
      INTEGER          I, INFO, IWARN, J, M, N, NAP, NFP, NP, NUP
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), AIN(LDA,NMAX), B(LDB,MMAX),
     $                 DWORK(LDWORK), F(LDF,NMAX), WI(NMAX), WR(NMAX),
     $                 Z(LDZ,NMAX), ZTA(LDZ,NMAX)
C     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAMCH, DLANGE
      EXTERNAL         DLAMCH, DLANGE, LSAME
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, MB03QX, SB01BD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP, ALPHA, TOL, DICO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF( NP.LT.0 .OR. NP.GT.NMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) NP
            ELSE
               DO 10 I = 1, NP
                  READ ( NIN, FMT = * ) WR(I), WI(I)
   10          CONTINUE
*              Perform "eigenvalue assignment" to compute F.
               CALL DLACPY( 'G', N, N, A, LDA, AIN, LDA )
               CALL SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB,
     $                      WR, WI, NFP, NAP, NUP, F, LDF, Z, LDZ,
     $                      TOL, DWORK, LDWORK, IWARN, INFO )
*
               IF ( INFO.NE.0 .AND. INFO.LT.3 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO
               ELSE
                  IF ( INFO  .NE. 0 ) WRITE ( NOUT, FMT = 99997 ) INFO
                  IF ( IWARN .NE. 0 ) WRITE ( NOUT, FMT = 99991 ) IWARN
                  WRITE ( NOUT, FMT = 99990 ) NAP
                  WRITE ( NOUT, FMT = 99989 ) NFP
                  WRITE ( NOUT, FMT = 99988 ) NUP
                  WRITE ( NOUT, FMT = 99996 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,N )
   60             CONTINUE
                  CALL MB03QX( N, A, LDA, WR, WI, INFO )
                  WRITE ( NOUT, FMT = 99998 ) ( WR(I), WI(I), I = 1,N )
*                 Compute NORM (Z*Aout*Z'-(A+B*F)) / (eps*NORM(A))
                  ANORM = DLANGE( 'F', N, N, AIN, LDA, DWORK )
                  CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, F, LDF,
     $                        ONE, AIN, LDA )
                  CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, A, LDA,
     $                        ZERO, ZTA, LDZ )
                  CALL DGEMM( 'N', 'T', N, N, N, ONE, ZTA, LDZ, Z, LDZ,
     $                        -ONE, AIN, LDA )
                  NRM = DLANGE( 'F', N, N, AIN, LDA, DWORK ) /
     $                  ( DLAMCH( 'E' )*ANORM )
                  WRITE ( NOUT, FMT = 99987 ) NRM
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB01BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/,' The eigenvalues of closed-loop matrix A+B*F',/
     $          ( ' ( ',F8.4,',',F8.4,' )' ) )
99997 FORMAT (' INFO on exit from SB01BD = ',I2)
99996 FORMAT (/,' The state feedback matrix F is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' NP is out of range.',/' NP = ',I5)
99991 FORMAT (/' IWARN on exit from SB01BD = ', I2)
99990 FORMAT ( ' Number of assigned eigenvalues: NAP = ', I2 )
99989 FORMAT ( ' Number of fixed eigenvalues:    NFP = ', I2)
99988 FORMAT ( ' Number of uncontrollable poles: NUP = ', I2)
99987 FORMAT (/,' NORM(A+B*F - Z*Aout*Z'') / (eps*NORM(A)) =',1PD12.5)
      END
Program Data 
 SB01BD EXAMPLE PROGRAM DATA
   4   2   2   -.4  1.E-8   C
  -6.8000   0.0000  -207.0000   0.0000
   1.0000   0.0000     0.0000   0.0000
  43.2000   0.0000     0.0000  -4.2000
   0.0000   0.0000     1.0000   0.0000
   5.6400   0.0000
   0.0000   0.0000
   0.0000   1.1800
   0.0000   0.0000
  -0.5000   0.1500
  -0.5000  -0.1500
  -2.0000   0.0000
  -0.4000   0.0000
Program Results 
 SB01BD EXAMPLE PROGRAM RESULTS

 Number of assigned eigenvalues: NAP =  2
 Number of fixed eigenvalues:    NFP =  2
 Number of uncontrollable poles: NUP =  0

 The state feedback matrix F is 
  -0.0876  -4.2138   0.0837 -18.1412
  -0.0233  18.2483  -0.4259  -4.8120

 The eigenvalues of closed-loop matrix A+B*F
 (  -3.3984, 94.5253 )
 (  -3.3984,-94.5253 )
 (  -0.5000,  0.1500 )
 (  -0.5000, -0.1500 )

 NORM(A+B*F - Z*Aout*Z') / (eps*NORM(A)) = 1.03505D+01

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB01BX.html000077500000000000000000000065101201767322700161050ustar00rootroot00000000000000 SB01BX - SLICOT Library Routine Documentation

SB01BX

Choosing the closest real (complex conjugate) eigenvalue(s) to a given real (complex) value

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To choose a real eigenvalue or a pair of complex conjugate
  eigenvalues at "minimal" distance to a given real or complex
  value.
Specification 
      SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P )
C     .. Scalar Arguments ..
      LOGICAL          REIG
      INTEGER          N
      DOUBLE PRECISION P, S, XI ,XR
C     .. Array Arguments ..
      DOUBLE PRECISION WI(*), WR(*)
Arguments

Mode Parameters 

  REIG    LOGICAL
          Specifies the type of eigenvalues as follows:
          = .TRUE.,  a real eigenvalue is to be selected;
          = .FALSE., a pair of complex eigenvalues is to be
                     selected.
Input/Output Parameters 
  N       (input) INTEGER
          The number of eigenvalues contained in the arrays WR
          and WI.  N >= 1.

  XR,XI   (input) DOUBLE PRECISION
          If REIG = .TRUE., XR must contain the real value and XI
          is assumed zero and therefore not referenced.
          If REIG = .FALSE., XR must contain the real part and XI
          the imaginary part, respectively, of the complex value.

  WR,WI   (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, if REIG = .TRUE., WR must contain the real
          eigenvalues from which an eigenvalue at minimal distance
          to XR is to be selected. In this case, WI is considered
          zero and therefore not referenced.
          On entry, if REIG = .FALSE., WR and WI must contain the
          real and imaginary parts, respectively, of the eigenvalues
          from which a pair of complex conjugate eigenvalues at
          minimal "distance" to XR + jXI is to be selected.
          The eigenvalues of each pair of complex conjugate
          eigenvalues must appear consecutively.
          On exit, the elements of these arrays are reordered such
          that the selected eigenvalue(s) is (are) found in the
          last element(s) of these arrays.

  S,P     (output) DOUBLE PRECISION
          If REIG = .TRUE., S (and also P) contains the value of
          the selected real eigenvalue.
          If REIG = .FALSE., S and P contain the sum and product,
          respectively, of the selected complex conjugate pair of
          eigenvalues.
Further Comments 
  For efficiency reasons, |x| + |y| is used for a complex number
  x + jy, instead of its modulus.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB01BY.html000077500000000000000000000072641201767322700161150ustar00rootroot00000000000000 SB01BY - SLICOT Library Routine Documentation

SB01BY

Pole placement for systems of order 1 or 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve an N-by-N pole placement problem for the simple cases
  N = 1 or N = 2: given the N-by-N matrix A and N-by-M matrix B,
  construct an M-by-N matrix F such that A + B*F has prescribed
  eigenvalues. These eigenvalues are specified by their sum S and
  product P (if N = 2). The resulting F has minimum Frobenius norm.
Specification 
      SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, M, N
      DOUBLE PRECISION  P, S, TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(N,*), B(N,*), DWORK(*), F(M,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A and also the number of rows of
          the matrix B and the number of columns of the matrix F.
          N is either 1, if a single real eigenvalue is prescribed
          or 2, if a complex conjugate pair or a set of two real
          eigenvalues are prescribed.

  M       (input) INTEGER
          The number of columns of the matrix B and also the number
          of rows of the matrix F.  M >= 1.

  S       (input) DOUBLE PRECISION
          The sum of the prescribed eigenvalues if N = 2 or the
          value of prescribed eigenvalue if N = 1.

  P       (input) DOUBLE PRECISION
          The product of the prescribed eigenvalues if N = 2.
          Not referenced if N = 1.

  A       (input/output) DOUBLE PRECISION array, dimension (N,N)
          On entry, this array must contain the N-by-N state
          dynamics matrix whose eigenvalues have to be moved to
          prescribed locations.
          On exit, this array contains no useful information.

  B       (input/output) DOUBLE PRECISION array, dimension (N,M)
          On entry, this array must contain the N-by-M input/state
          matrix B.
          On exit, this array contains no useful information.

  F       (output) DOUBLE PRECISION array, dimension (M,N)
          The state feedback matrix F which assigns one pole or two
          poles of the closed-loop matrix A + B*F.
          If N = 2 and the pair (A,B) is not controllable
          (INFO = 1), then F(1,1) and F(1,2) contain the elements of
          an orthogonal rotation which can be used to remove the
          uncontrollable part of the pair (A,B).
Tolerances 
  TOL     DOUBLE PRECISION
          The absolute tolerance level below which the elements of A
          and B are considered zero (used for controllability test).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if uncontrollability of the pair (A,B) is detected.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB01DD.html000077500000000000000000000273051201767322700160700ustar00rootroot00000000000000 SB01DD - SLICOT Library Routine Documentation

SB01DD

Eigenstructure assignment for a multi-input system in orthogonal canonical form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute for a controllable matrix pair ( A, B ) a matrix G
  such that the matrix A - B*G has the desired eigenstructure,
  specified by desired eigenvalues and free eigenvector elements.

  The pair ( A, B ) should be given in orthogonal canonical form
  as returned by the SLICOT Library routine AB01ND.
Specification 
      SUBROUTINE SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI,
     $                   Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            COUNT, INDCON, INFO, LDA, LDB, LDG, LDWORK,
     $                   LDZ, M, N
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IWORK( * ), NBLK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   G( LDG, * ), WI( * ), WR( * ), Y( * ),
     $                   Z( LDZ, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A and the number of rows of the
          matrix B.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrix B.  M >= 0.

  INDCON  (input) INTEGER
          The controllability index of the pair ( A, B ).
          0 <= INDCON <= N.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the N-by-N matrix A in orthogonal canonical form,
          as returned by SLICOT Library routine AB01ND.
          On exit, the leading N-by-N part of this array contains
          the real Schur form of the matrix A - B*G.
          The elements below the real Schur form of A are set to
          zero.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the N-by-M matrix B in orthogonal canonical form,
          as returned by SLICOT Library routine AB01ND.
          On exit, the leading N-by-M part of this array contains
          the transformed matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  NBLK    (input) INTEGER array, dimension (N)
          The leading INDCON elements of this array must contain the
          orders of the diagonal blocks in the orthogonal canonical
          form of A, as returned by SLICOT Library routine AB01ND.
          The values of these elements must satisfy the following
          conditions:
          NBLK(1) >= NBLK(2) >= ... >= NBLK(INDCON),
          NBLK(1) + NBLK(2) + ... + NBLK(INDCON) = N.

  WR      (input) DOUBLE PRECISION array, dimension (N)
  WI      (input) DOUBLE PRECISION array, dimension (N)
          These arrays must contain the real and imaginary parts,
          respectively, of the desired poles of the closed-loop
          system, i.e., the eigenvalues of A - B*G. The poles can be
          unordered, except that complex conjugate pairs of poles
          must appear consecutively.
          The elements of WI for complex eigenvalues are modified
          internally, but restored on exit.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          On entry, the leading N-by-N part of this array must
          contain the orthogonal matrix Z generated by SLICOT
          Library routine AB01ND in the reduction of ( A, B ) to
          orthogonal canonical form.
          On exit, the leading N-by-N part of this array contains
          the orthogonal transformation matrix which reduces A - B*G
          to real Schur form.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= max(1,N).

  Y       (input) DOUBLE PRECISION array, dimension (M*N)
          Y contains elements which are used as free parameters
          in the eigenstructure design. The values of these
          parameters are often set by an external optimization
          procedure.

  COUNT   (output) INTEGER
          The actual number of elements in Y used as free
          eigenvector and feedback matrix elements in the
          eigenstructure design.

  G       (output) DOUBLE PRECISION array, dimension (LDG,N)
          The leading M-by-N part of this array contains the
          feedback matrix which assigns the desired eigenstructure
          of A - B*G.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= max(1,M).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*N*EPS,  is used instead, where
          EPS  is the machine precision (see LAPACK Library routine
          DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(M*N,M*M+2*N+4*M+1).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the pair ( A, B ) is not controllable or the free
                parameters are not set appropriately.
Method 
  The routine implements the method proposed in [1], [2].
References 
  [1] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and
      Postlethwaite, I.
      Optimal pole assignment design of linear multi-input systems.
      Report 96-11, Department of Engineering, Leicester University,
      1996.

  [2] Petkov, P.Hr., Christov, N.D. and Konstantinov, M.M.
      A computational algorithm for pole assignment of linear multi
      input systems. IEEE Trans. Automatic Control, vol. AC-31,
      pp. 1044-1047, 1986.
Numerical Aspects 
  The method implemented is backward stable.
Further Comments 
  The eigenvalues of the real Schur form matrix As, returned in the
  array A, are very close to the desired eigenvalues WR+WI*i.
  However, the eigenvalues of the closed-loop matrix A - B*G,
  computed by the QR algorithm using the matrices A and B, given on
  entry, may be far from WR+WI*i, although the relative error
     norm( Z'*(A - B*G)*Z - As )/norm( As )
  is close to machine accuracy. This may happen when the eigenvalue
  problem for the matrix A - B*G is ill-conditioned.
Example

Program Text 

*     SB01DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDG, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDG = MMAX,
     $                   LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 3*NMAX, MMAX*NMAX,
     $                                 MMAX*MMAX + 2*NMAX + 4*MMAX + 1 )
     $                 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          COUNT, I, INDCON, INFO1, INFO2, J, M, N, NCONT
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      INTEGER          IWORK(MMAX), NBLK(NMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX,MMAX), DWORK(LDWORK),
     $                 G(LDG,NMAX), WI(NMAX), WR(NMAX), Y(MMAX*NMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB01ND, SB01DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, JOBZ
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            READ ( NIN, FMT = * ) ( WR(I), I = 1,N )
            READ ( NIN, FMT = * ) ( WI(I), I = 1,N )
            READ ( NIN, FMT = * ) ( Y(I),  I = 1,M*N )
*           First reduce the given system to canonical form.
            CALL AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON,
     $                   NBLK, Z, LDZ, DWORK, TOL, IWORK, DWORK(N+1),
     $                   LDWORK-N, INFO1 )
*
            IF ( INFO1.EQ.0 ) THEN
*              Find the state feedback matrix G.
               CALL SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI,
     $                      Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK,
     $                      LDWORK, INFO2 )
*
               IF ( INFO2.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO2
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 10 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,N )
   10             CONTINUE
               END IF
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO1
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB01DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01ND =',I2)
99997 FORMAT (' INFO on exit from SB01DD =',I2)
99996 FORMAT (' The state feedback matrix G is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 SB01DD EXAMPLE PROGRAM DATA
   4   2     0.0     I
  -1.0  0.0  2.0 -3.0
   1.0 -4.0  3.0 -1.0
   0.0  2.0  4.0 -5.0
   0.0  0.0 -1.0 -2.0
   1.0  0.0
   0.0  0.0
   0.0  0.0
   0.0  1.0
  -1.0 -1.0 -1.0 -1.0
   0.0  0.0  0.0  0.0
   1.0  2.0  2.0  1.0 -1.0 -2.0  3.0  1.0
Program Results 
 SB01DD EXAMPLE PROGRAM RESULTS

 The state feedback matrix G is
  -5.2339   3.1725 -15.7885  21.7043
  -1.6022   0.8504  -5.1914   6.2339

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB01FY.html000077500000000000000000000077641201767322700161260ustar00rootroot00000000000000 SB01FY - SLICOT Library Routine Documentation

SB01FY

Inner denominator of a right-coprime factorization of an unstable system of order 1 or 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the inner denominator of a right-coprime factorization
  of a system of order N, where N is either 1 or 2. Specifically,
  given the N-by-N unstable system state matrix A and the N-by-M
  system input matrix B, an M-by-N state-feedback matrix F and
  an M-by-M matrix V are constructed, such that the system
  (A + B*F, B*V, F, V) is inner.
Specification 
      SUBROUTINE SB01FY( DISCR, N, M, A, LDA, B, LDB, F, LDF, V, LDV,
     $                   INFO )
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,*)
Arguments

Mode Parameters 

  DISCR   LOGICAL
          Specifies the type of system as follows:
          = .FALSE.:  continuous-time system;
          = .TRUE. :  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A and also the number of rows of
          the matrix B and the number of columns of the matrix F.
          N is either 1 or 2.

  M       (input) INTEGER
          The number of columns of the matrices B and V, and also
          the number of rows of the matrix F.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A whose eigenvalues must have positive
          real parts if DISCR = .FALSE. or moduli greater than unity
          if DISCR = .TRUE..

  LDA     INTEGER
          The leading dimension of array A.  LDA >= N.

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= N.

  F       (output) DOUBLE PRECISION array, dimension (LDF,N)
          The leading M-by-N part of this array contains the state-
          feedback matrix F which assigns one eigenvalue (if N = 1)
          or two eigenvalues (if N = 2) of the matrix A + B*F in
          symmetric positions with respect to the imaginary axis
          (if DISCR = .FALSE.) or the unit circle (if
          DISCR = .TRUE.).

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).

  V       (output) DOUBLE PRECISION array, dimension (LDV,M)
          The leading M-by-M upper triangular part of this array
          contains the input/output matrix V of the resulting inner
          system in upper triangular form.
          If DISCR = .FALSE., the resulting V is an identity matrix.

  LDV     INTEGER
          The leading dimension of array V.  LDF >= MAX(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if uncontrollability of the pair (A,B) is detected;
          = 2:  if A is stable or at the stability limit;
          = 3:  if N = 2 and A has a pair of real eigenvalues.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB01MD.html000077500000000000000000000201441201767322700160730ustar00rootroot00000000000000 SB01MD - SLICOT Library Routine Documentation

SB01MD

State feedback matrix of a linear time-invariant single-input system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To determine the one-dimensional state feedback matrix G of the
  linear time-invariant single-input system

        dX/dt = A * X + B * U,

  where A is an NCONT-by-NCONT matrix and B is an NCONT element
  vector such that the closed-loop system

        dX/dt = (A - B * G) * X

  has desired poles. The system must be preliminarily reduced
  to orthogonal canonical form using the SLICOT Library routine
  AB01MD.
Specification 
      SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDZ, N, NCONT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*),
     $                  Z(LDZ,*)
Arguments

Input/Output Parameters 

  NCONT   (input) INTEGER
          The order of the matrix A as produced by SLICOT Library
          routine AB01MD.  NCONT >= 0.

  N       (input) INTEGER
          The order of the matrix Z.  N >= NCONT.

  A       (input/output) DOUBLE PRECISION array, dimension
          (LDA,NCONT)
          On entry, the leading NCONT-by-NCONT part of this array
          must contain the canonical form of the state dynamics
          matrix A as produced by SLICOT Library routine AB01MD.
          On exit, the leading NCONT-by-NCONT part of this array
          contains the upper quasi-triangular form S of the closed-
          loop system matrix (A - B * G), that is triangular except
          for possible 2-by-2 diagonal blocks.
          (To reconstruct the closed-loop system matrix see
          FURTHER COMMENTS below.)

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,NCONT).

  B       (input/output) DOUBLE PRECISION array, dimension (NCONT)
          On entry, this array must contain the canonical form of
          the input/state vector B as produced by SLICOT Library
          routine AB01MD.
          On exit, this array contains the transformed vector Z * B
          of the closed-loop system.

  WR      (input) DOUBLE PRECISION array, dimension (NCONT)
  WI      (input) DOUBLE PRECISION array, dimension (NCONT)
          These arrays must contain the real and imaginary parts,
          respectively, of the desired poles of the closed-loop
          system. The poles can be unordered, except that complex
          conjugate pairs of poles must appear consecutively.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          On entry, the leading N-by-N part of this array must
          contain the orthogonal transformation matrix as produced
          by SLICOT Library routine AB01MD, which reduces the system
          to canonical form.
          On exit, the leading NCONT-by-NCONT part of this array
          contains the orthogonal matrix Z which reduces the closed-
          loop system matrix (A - B * G) to upper quasi-triangular
          form.

  LDZ     INTEGER
          The leading dimension of array Z.  LDZ >= MAX(1,N).

  G       (output) DOUBLE PRECISION array, dimension (NCONT)
          This array contains the one-dimensional state feedback
          matrix G of the original system.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (3*NCONT)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The method is based on the orthogonal reduction of the closed-loop
  system matrix (A - B * G) to upper quasi-triangular form S whose
  1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles.
  That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix.
References 
  [1] Petkov, P. Hr.
      A Computational Algorithm for Pole Assignment of Linear
      Single Input Systems.
      Internal Report 81/2, Control Systems Research Group, School
      of Electronic Engineering and Computer Science, Kingston
      Polytechnic, 1981.
Numerical Aspects 
                                3
  The algorithm requires 0(NCONT ) operations and is backward
  stable.
Further Comments 
  If required, the closed-loop system matrix (A - B * G) can be
  formed from the matrix product Z * S * Z' (where S and Z are the
  matrices output in arrays A and Z respectively).
Example

Program Text 

*     SB01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDZ
      PARAMETER        ( LDA = NMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO1, INFO2, J, N, NCONT
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), G(NMAX),
     $                 WI(NMAX), WR(NMAX), Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB01MD, SB01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, TOL, JOBZ
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( B(I), I = 1,N )
         READ ( NIN, FMT = * ) ( WR(I), I = 1,N )
         READ ( NIN, FMT = * ) ( WI(I), I = 1,N )
*        First reduce the given system to canonical form.
         CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, DWORK, TOL,
     $                DWORK(N+1), LDWORK-N, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
*           Find the one-dimensional state feedback matrix G.
            CALL SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK,
     $                   INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            ELSE
               WRITE ( NOUT, FMT = 99996 ) ( G(I), I = 1,NCONT )
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01MD =',I2)
99997 FORMAT (' INFO on exit from SB01MD =',I2)
99996 FORMAT (' The one-dimensional state feedback matrix G is',
     $       /20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 SB01MD EXAMPLE PROGRAM DATA
   4     0.0     I
  -1.0  0.0  2.0 -3.0
   1.0 -4.0  3.0 -1.0
   0.0  2.0  4.0 -5.0
   0.0  0.0 -1.0 -2.0
   1.0  0.0  0.0  0.0
  -1.0 -1.0 -1.0 -1.0
   0.0  0.0  0.0  0.0
Program Results 
 SB01MD EXAMPLE PROGRAM RESULTS

 The one-dimensional state feedback matrix G is
   1.0000  29.0000  93.0000 -76.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02MD.html000077500000000000000000000372351201767322700161050ustar00rootroot00000000000000 SB02MD - SLICOT Library Routine Documentation

SB02MD

Solution of continuous- or discrete-time algebraic Riccati equations (Schur vectors method)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the continuous-time algebraic Riccati
  equation
                           -1
     Q + A'*X + X*A - X*B*R  B'*X = 0                            (1)

  or the discrete-time algebraic Riccati equation
                                     -1
     X = A'*X*A - A'*X*B*(R + B'*X*B)  B'*X*A + Q                (2)

  where A, B, Q and R are N-by-N, N-by-M, N-by-N and M-by-M matrices
  respectively, with Q symmetric and R symmetric nonsingular; X is
  an N-by-N symmetric matrix.
                    -1
  The matrix G = B*R  B' must be provided on input, instead of B and
  R, that is, for instance, the continuous-time equation

     Q + A'*X + X*A - X*G*X = 0                                  (3)

  is solved, where G is an N-by-N symmetric matrix. SLICOT Library
  routine SB02MT should be used to compute G, given B and R. SB02MT
  also enables to solve Riccati equations corresponding to optimal
  problems with coupling terms.

  The routine also returns the computed values of the closed-loop
  spectrum of the optimal system, i.e., the stable eigenvalues
  lambda(1),...,lambda(N) of the corresponding Hamiltonian or
  symplectic matrix associated to the optimal problem.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of Riccati equation to be solved as
          follows:
          = 'C':  Equation (3), continuous-time case;
          = 'D':  Equation (2), discrete-time case.

  HINV    CHARACTER*1
          If DICO = 'D', specifies which symplectic matrix is to be
          constructed, as follows:
          = 'D':  The matrix H in (5) (see METHOD) is constructed;
          = 'I':  The inverse of the matrix H in (5) is constructed.
          HINV is not used if DICO = 'C'.

  UPLO    CHARACTER*1
          Specifies which triangle of the matrices G and Q is
          stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.

  SCAL    CHARACTER*1
          Specifies whether or not a scaling strategy should be
          used, as follows:
          = 'G':  General scaling should be used;
          = 'N':  No scaling should be used.

  SORT    CHARACTER*1
          Specifies which eigenvalues should be obtained in the top
          of the Schur form, as follows:
          = 'S':  Stable   eigenvalues come first;
          = 'U':  Unstable eigenvalues come first.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, Q, G and X.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the coefficient matrix A of the equation.
          On exit, if DICO = 'D', and INFO = 0 or INFO > 1, the
                                                                 -1
          leading N-by-N part of this array contains the matrix A  .
          Otherwise, the array A is unchanged on exit.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  G       (input) DOUBLE PRECISION array, dimension (LDG,N)
          The leading N-by-N upper triangular part (if UPLO = 'U')
          or lower triangular part (if UPLO = 'L') of this array
          must contain the upper triangular part or lower triangular
          part, respectively, of the symmetric matrix G. The stricly
          lower triangular part (if UPLO = 'U') or stricly upper
          triangular part (if UPLO = 'L') is not referenced.

  LDG     INTEGER
          The leading dimension of array G.  LDG >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, the leading N-by-N upper triangular part (if
          UPLO = 'U') or lower triangular part (if UPLO = 'L') of
          this array must contain the upper triangular part or lower
          triangular part, respectively, of the symmetric matrix Q.
          The stricly lower triangular part (if UPLO = 'U') or
          stricly upper triangular part (if UPLO = 'L') is not used.
          On exit, if INFO = 0, the leading N-by-N part of this
          array contains the solution matrix X of the problem.

  LDQ     INTEGER
          The leading dimension of array N.  LDQ >= MAX(1,N).

  RCOND   (output) DOUBLE PRECISION
          An estimate of the reciprocal of the condition number (in
          the 1-norm) of the N-th order system of algebraic
          equations from which the solution matrix X is obtained.

  WR      (output) DOUBLE PRECISION array, dimension (2*N)
  WI      (output) DOUBLE PRECISION array, dimension (2*N)
          If INFO = 0 or INFO = 5, these arrays contain the real and
          imaginary parts, respectively, of the eigenvalues of the
          2N-by-2N matrix S, ordered as specified by SORT (except
          for the case HINV = 'D', when the order is opposite to
          that specified by SORT). The leading N elements of these
          arrays contain the closed-loop spectrum of the system
                        -1
          matrix A - B*R  *B'*X, if DICO = 'C', or of the matrix
                            -1
          A - B*(R + B'*X*B)  B'*X*A, if DICO = 'D'. Specifically,
             lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N.

  S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
          If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this
          array contains the ordered real Schur form S of the
          Hamiltonian or symplectic matrix H. That is,

                 (S   S  )
                 ( 11  12)
             S = (       ),
                 (0   S  )
                 (     22)

          where S  , S   and S   are N-by-N matrices.
                 11   12      22

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,2*N).

  U       (output) DOUBLE PRECISION array, dimension (LDU,2*N)
          If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this
          array contains the transformation matrix U which reduces
          the Hamiltonian or symplectic matrix H to the ordered real
          Schur form S. That is,

                 (U   U  )
                 ( 11  12)
             U = (       ),
                 (U   U  )
                 ( 21  22)

          where U  , U  , U   and U   are N-by-N matrices.
                 11   12   21      22

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,2*N).
Workspace 
  IWORK   INTEGER array, dimension (2*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK and DWORK(2) returns the scaling factor used
          (set to 1 if SCAL = 'N'), also set if INFO = 5;
          if DICO = 'D', DWORK(3) returns the reciprocal condition
          number of the given matrix  A.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(2,6*N) if DICO = 'C';
          LDWORK >= MAX(3,6*N) if DICO = 'D'.
          For optimum performance LDWORK should be larger.

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if matrix A is (numerically) singular in discrete-
                time case;
          = 2:  if the Hamiltonian or symplectic matrix H cannot be
                reduced to real Schur form;
          = 3:  if the real Schur form of the Hamiltonian or
                symplectic matrix H cannot be appropriately ordered;
          = 4:  if the Hamiltonian or symplectic matrix H has less
                than N stable eigenvalues;
          = 5:  if the N-th order system of linear algebraic
                equations, from which the solution matrix X would
                be obtained, is singular to working precision.
Method 
  The method used is the Schur vector approach proposed by Laub.
  It is assumed that [A,B] is a stabilizable pair (where for (3) B
  is any matrix such that B*B' = G with rank(B) = rank(G)), and
  [E,A] is a detectable pair, where E is any matrix such that
  E*E' = Q with rank(E) = rank(Q). Under these assumptions, any of
  the algebraic Riccati equations (1)-(3) is known to have a unique
  non-negative definite solution. See [2].
  Now consider the 2N-by-2N Hamiltonian or symplectic matrix

              ( A   -G )
         H =  (        ),                                    (4)
              (-Q   -A'),

  for continuous-time equation, and
                 -1        -1
              ( A         A  *G   )
         H =  (   -1          -1  ),                         (5)
              (Q*A    A' + Q*A  *G)
                                                         -1
  for discrete-time equation, respectively, where G = B*R  *B'.
  The assumptions guarantee that H in (4) has no pure imaginary
  eigenvalues, and H in (5) has no eigenvalues on the unit circle.
  If Y is an N-by-N matrix then there exists an orthogonal matrix U
  such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U
  can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks
  (corresponding to the complex conjugate eigenvalues and real
  eigenvalues respectively) appear in any desired order. This is the
  ordered real Schur form. Thus, we can find an orthogonal
  similarity transformation U which puts (4) or (5) in ordered real
  Schur form

         U'*H*U = S = (S(1,1)  S(1,2))
                      (  0     S(2,2))

  where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1)
  have negative real parts in case of (4), or moduli greater than
  one in case of (5). If U is conformably partitioned into four
  N-by-N blocks

            U = (U(1,1)  U(1,2))
                (U(2,1)  U(2,2))

  with respect to the assumptions we then have
  (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1),
      (2), or (3) with X = X' and non-negative definite;
  (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if
      DICO = 'D') are equal to the eigenvalues of optimal system
      (the 'closed-loop' spectrum).

  [A,B] is stabilizable if there exists a matrix F such that (A-BF)
  is stable. [E,A] is detectable if [A',E'] is stabilizable.
References 
  [1] Laub, A.J.
      A Schur Method for Solving Algebraic Riccati equations.
      IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979.

  [2] Wonham, W.M.
      On a matrix Riccati equation of stochastic control.
      SIAM J. Contr., 6, pp. 681-697, 1968.

  [3] Sima, V.
      Algorithms for Linear-Quadratic Optimization.
      Pure and Applied Mathematics: A Series of Monographs and
      Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  To obtain a stabilizing solution of the algebraic Riccati
  equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set
  SORT = 'S', if HINV = 'I'.

  The routine can also compute the anti-stabilizing solutions of
  the algebraic Riccati equations, by specifying
      SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or
      SORT = 'S' if DICO = 'D' and HINV = 'D'.

  Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I'
  and SORT = 'U', will be faster then the other combinations [3].
Example

Program Text 

*     SB02MD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDS, LDU
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX,
     $                   LDS = 2*NMAX, LDU = 2*NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 6*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION RCOND
      INTEGER          I, INFO, J, N
      CHARACTER        DICO, HINV, SCAL, SORT, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX),
     $                 Q(LDQ,NMAX), S(LDS,2*NMAX), U(LDU,2*NMAX),
     $                 WI(2*NMAX), WR(2*NMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB02MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DICO, HINV, UPLO, SCAL, SORT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X.
         CALL 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 )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) RCOND
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( Q(I,J), J = 1,N )
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02MD = ',I2)
99997 FORMAT (' RCOND = ',F4.2,//' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 SB02MD EXAMPLE PROGRAM DATA
   2     C     D     U     N     S
   0.0   1.0
   0.0   0.0
   1.0   0.0
   0.0   2.0
   0.0   0.0
   0.0   1.0
Program Results 
 SB02MD EXAMPLE PROGRAM RESULTS

 RCOND = 0.31

 The solution matrix X is 
   2.0000   1.0000
   1.0000   2.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02MT.html000077500000000000000000000265611201767322700161250ustar00rootroot00000000000000 SB02MT - SLICOT Library Routine Documentation

SB02MT

Conversion of optimal problems with coupling weighting terms to standard problems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the following matrices

             -1
      G = B*R  *B',

      -          -1
      A = A - B*R  *L',

      -          -1
      Q = Q - L*R  *L',

  where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M,
  N-by-M, and N-by-N matrices, respectively, with Q, R and G
  symmetric matrices.

  When R is well-conditioned with respect to inversion, standard
  algorithms for solving linear-quadratic optimization problems will
  then also solve optimization problems with coupling weighting
  matrix L. Moreover, a gain in efficiency is possible using matrix
  G in the deflating subspace algorithms (see SLICOT Library routine
  SB02OD).
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOBG    CHARACTER*1
          Specifies whether or not the matrix G is to be computed,
          as follows:
          = 'G':  Compute G;
          = 'N':  Do not compute G.

  JOBL    CHARACTER*1
          Specifies whether or not the matrix L is zero, as follows:
          = 'Z':  L is zero;
          = 'N':  L is nonzero.

  FACT    CHARACTER*1
          Specifies how the matrix R is given (factored or not), as
          follows:
          = 'N':  Array R contains the matrix R;
          = 'C':  Array R contains the Cholesky factor of R;
          = 'U':  Array R contains the symmetric indefinite UdU' or
                  LdL' factorization of R.

  UPLO    CHARACTER*1
          Specifies which triangle of the matrices R and Q (if
          JOBL = 'N') is stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, Q, and G, and the number of
          rows of the matrices B and L.  N >= 0.

  M       (input) INTEGER
          The order of the matrix R, and the number of columns of
          the matrices B and L.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, if JOBL = 'N', the leading N-by-N part of this
          array must contain the matrix A.
          On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N
                                                 -          -1
          part of this array contains the matrix A = A - B*R  L'.
          If JOBL = 'Z', this array is not referenced.

  LDA     INTEGER
          The leading dimension of array A.
          LDA >= MAX(1,N) if JOBL = 'N';
          LDA >= 1        if JOBL = 'Z'.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the matrix B.
          On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M
                                                          -1
          part of this array contains the matrix B*chol(R)  .
          On exit, B is unchanged if OUFACT = 2 (hence also when
          FACT = 'U').

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, if JOBL = 'N', the leading N-by-N upper
          triangular part (if UPLO = 'U') or lower triangular part
          (if UPLO = 'L') of this array must contain the upper
          triangular part or lower triangular part, respectively, of
          the symmetric matrix Q. The stricly lower triangular part
          (if UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.
          On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N
          upper triangular part (if UPLO = 'U') or lower triangular
          part (if UPLO = 'L') of this array contains the upper
          triangular part or lower triangular part, respectively, of
                               -          -1
          the symmetric matrix Q = Q - L*R  *L'.
          If JOBL = 'Z', this array is not referenced.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= MAX(1,N) if JOBL = 'N';
          LDQ >= 1        if JOBL = 'Z'.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
          On entry, if FACT = 'N', the leading M-by-M upper
          triangular part (if UPLO = 'U') or lower triangular part
          (if UPLO = 'L') of this array must contain the upper
          triangular part or lower triangular part, respectively,
          of the symmetric input weighting matrix R.
          On entry, if FACT = 'C', the leading M-by-M upper
          triangular part (if UPLO = 'U') or lower triangular part
          (if UPLO = 'L') of this array must contain the Cholesky
          factor of the positive definite input weighting matrix R
          (as produced by LAPACK routine DPOTRF).
          On entry, if FACT = 'U', the leading M-by-M upper
          triangular part (if UPLO = 'U') or lower triangular part
          (if UPLO = 'L') of this array must contain the factors of
          the UdU' or LdL' factorization, respectively, of the
          symmetric indefinite input weighting matrix R (as produced
          by LAPACK routine DSYTRF).
          If FACT = 'N', the stricly lower triangular part (if UPLO
          = 'U') or stricly upper triangular part (if UPLO = 'L') of
          this array is used as workspace.
          On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1),
          the leading M-by-M upper triangular part (if UPLO = 'U')
          or lower triangular part (if UPLO = 'L') of this array
          contains the Cholesky factor of the given input weighting
          matrix.
          On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1),
          the leading M-by-M upper triangular part (if UPLO = 'U')
          or lower triangular part (if UPLO = 'L') of this array
          contains the factors of the UdU' or LdL' factorization,
          respectively, of the given input weighting matrix.
          On exit R is unchanged if FACT = 'C' or 'U'.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,M).

  L       (input/output) DOUBLE PRECISION array, dimension (LDL,M)
          On entry, if JOBL = 'N', the leading N-by-M part of this
          array must contain the matrix L.
          On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the
          leading N-by-M part of this array contains the matrix
                   -1
          L*chol(R)  .
          On exit, L is unchanged if OUFACT = 2 (hence also when
          FACT = 'U').
          L is not referenced if JOBL = 'Z'.

  LDL     INTEGER
          The leading dimension of array L.
          LDL >= MAX(1,N) if JOBL = 'N';
          LDL >= 1        if JOBL = 'Z'.

  IPIV    (input/output) INTEGER array, dimension (M)
          On entry, if FACT = 'U', this array must contain details
          of the interchanges performed and the block structure of
          the d factor in the UdU' or LdL' factorization of matrix R
          (as produced by LAPACK routine DSYTRF).
          On exit, if OUFACT = 2, this array contains details of
          the interchanges performed and the block structure of the
          d factor in the UdU' or LdL' factorization of matrix R,
          as produced by LAPACK routine DSYTRF.
          This array is not referenced if FACT = 'C'.

  OUFACT  (output) INTEGER
          Information about the factorization finally used.
          OUFACT = 1:  Cholesky factorization of R has been used;
          OUFACT = 2:  UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L')
                       factorization of R has been used.

  G       (output) DOUBLE PRECISION array, dimension (LDG,N)
          If JOBG = 'G', and INFO = 0, the leading N-by-N upper
          triangular part (if UPLO = 'U') or lower triangular part
          (if UPLO = 'L') of this array contains the upper
          triangular part (if UPLO = 'U') or lower triangular part
                                                              -1
          (if UPLO = 'L'), respectively, of the matrix G = B*R  B'.
          If JOBG = 'N', this array is not referenced.

  LDG     INTEGER
          The leading dimension of array G.
          LDG >= MAX(1,N) if JOBG = 'G',
          LDG >= 1        if JOBG = 'N'.
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK; if FACT = 'N', DWORK(2) contains the reciprocal
          condition number of the given matrix R.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 1              if FACT = 'C';
          LDWORK >= MAX(2,3*M,N*M) if FACT = 'N';
          LDWORK >= MAX(1,N*M)     if FACT = 'U'.
          For optimum performance LDWORK should be larger than 3*M,
          if FACT = 'N'.
          The N*M workspace is not needed for FACT = 'N', if matrix
          R is positive definite.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = i:  if the i-th element (1 <= i <= M) of the d factor is
                exactly zero; the UdU' (or LdL') factorization has
                been completed, but the block diagonal matrix d is
                exactly singular;
          = M+1:  if the matrix R is numerically singular.
Method 
                         -     -
  The matrices G, and/or A and Q are evaluated using the given or
  computed symmetric factorization of R.
Numerical Aspects 
  The routine should not be used when R is ill-conditioned.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02MU.html000077500000000000000000000147661201767322700161320ustar00rootroot00000000000000 SB02MU - SLICOT Library Routine Documentation

SB02MU

Constructing the 2n-by-2n Hamiltonian or symplectic matrix for linear-quadratic optimization problems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the 2n-by-2n Hamiltonian or symplectic matrix S
  associated to the linear-quadratic optimization problem, used to
  solve the continuous- or discrete-time algebraic Riccati equation,
  respectively.

  For a continuous-time problem, S is defined by

          (  A  -G )
      S = (        ),                                       (1)
          ( -Q  -A')

  and for a discrete-time problem by

              -1       -1
          (  A        A  *G     )
      S = (   -1           -1   ),                          (2)
          ( QA     A' + Q*A  *G )

  or

                    -T         -T
          (  A + G*A  *Q   -G*A   )
      S = (      -T            -T ),                        (3)
          (    -A  *Q         A   )

  where A, G, and Q are N-by-N matrices, with G and Q symmetric.
  Matrix A must be nonsingular in the discrete-time case.
Specification 
      SUBROUTINE SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S,
     $                   LDS, IWORK, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system as follows:
          = 'C':  Continuous-time system;
          = 'D':  Discrete-time system.

  HINV    CHARACTER*1
          If DICO = 'D', specifies which of the matrices (2) or (3)
          is constructed, as follows:
          = 'D':  The matrix S in (2) is constructed;
          = 'I':  The (inverse) matrix S in (3) is constructed.
          HINV is not referenced if DICO = 'C'.

  UPLO    CHARACTER*1
          Specifies which triangle of the matrices G and Q is
          stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, G, and Q.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A.
          On exit, if DICO = 'D', and INFO = 0, the leading N-by-N
                                                  -1
          part of this array contains the matrix A  .
          Otherwise, the array A is unchanged on exit.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  G       (input) DOUBLE PRECISION array, dimension (LDG,N)
          The leading N-by-N upper triangular part (if UPLO = 'U')
          or lower triangular part (if UPLO = 'L') of this array
          must contain the upper triangular part or lower triangular
          part, respectively, of the symmetric matrix G. The stricly
          lower triangular part (if UPLO = 'U') or stricly upper
          triangular part (if UPLO = 'L') is not referenced.

  LDG     INTEGER
          The leading dimension of array G.  LDG >= MAX(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
          The leading N-by-N upper triangular part (if UPLO = 'U')
          or lower triangular part (if UPLO = 'L') of this array
          must contain the upper triangular part or lower triangular
          part, respectively, of the symmetric matrix Q. The stricly
          lower triangular part (if UPLO = 'U') or stricly upper
          triangular part (if UPLO = 'L') is not referenced.

  LDQ     INTEGER
          The leading dimension of array Q.  LDQ >= MAX(1,N).

  S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
          If INFO = 0, the leading 2N-by-2N part of this array
          contains the Hamiltonian or symplectic matrix of the
          problem.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,2*N).
Workspace 
  IWORK   INTEGER array, dimension (2*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal
          condition number of the given matrix  A.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 1          if DICO = 'C';
          LDWORK >= MAX(2,4*N) if DICO = 'D'.
          For optimum performance LDWORK should be larger, if
          DICO = 'D'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = i:  if the leading i-by-i (1 <= i <= N) upper triangular
                submatrix of A is singular in discrete-time case;
          = N+1:  if matrix A is numerically singular in discrete-
                time case.
Method 
  For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1)
  is constructed.
  For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or
  (3) - the inverse of the matrix in (2) - is constructed.
Numerical Aspects 
  The discrete-time case needs the inverse of the matrix A, hence
  the routine should not be used when A is ill-conditioned.
                            3
  The algorithm requires 0(n ) floating point operations in the
  discrete-time case.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB02ND.html000077500000000000000000000430661201767322700161050ustar00rootroot00000000000000 SB02ND - SLICOT Library Routine Documentation

SB02ND

Optimal state feedback matrix for an optimal control problem

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the optimal feedback matrix F for the problem of
  optimal control given by

                     -1
       F = (R + B'XB)  (B'XA + L')                           (1)

  in the discrete-time case and

            -1
       F = R  (B'X + L')                                     (2)

  in the continuous-time case, where A, B and L are N-by-N, N-by-M
  and N-by-M matrices respectively; R and X are M-by-M and N-by-N
  symmetric matrices respectively.

  Optionally, matrix R may be specified in a factored form, and L
  may be zero.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the equation from which F is to be determined,
          as follows:
          = 'D':  Equation (1), discrete-time case;
          = 'C':  Equation (2), continuous-time case.

  FACT    CHARACTER*1
          Specifies how the matrix R is given (factored or not), as
          follows:
          = 'N':  Array R contains the matrix R;
          = 'D':  Array R contains a P-by-M matrix D, where R = D'D;
          = 'C':  Array R contains the Cholesky factor of R;
          = 'U':  Array R contains the symmetric indefinite UdU' or
                  LdL' factorization of R. This option is not
                  available for DICO = 'D'.

  UPLO    CHARACTER*1
          Specifies which triangle of the possibly factored matrix R
          (or R + B'XB, on exit) is or should be stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.

  JOBL    CHARACTER*1
          Specifies whether or not the matrix L is zero, as follows:
          = 'Z':  L is zero;
          = 'N':  L is nonzero.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and X.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.
          This parameter must be specified only for FACT = 'D'.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If DICO = 'D', the leading N-by-N part of this array must
          contain the state matrix A of the system.
          If DICO = 'C', this array is not referenced.

  LDA     INTEGER
          The leading dimension of array A.
          LDA >= MAX(1,N) if DICO = 'D';
          LDA >= 1        if DICO = 'C'.

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input matrix B of the system.
          If DICO = 'D' and FACT = 'D' or 'C', the contents of this
          array is destroyed.
          Otherwise, B is unchanged on exit.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
          On entry, if FACT = 'N', the leading M-by-M upper
          triangular part (if UPLO = 'U') or lower triangular part
          (if UPLO = 'L') of this array must contain the upper
          triangular part or lower triangular part, respectively,
          of the symmetric input weighting matrix R.
          On entry, if FACT = 'D', the leading P-by-M part of this
          array must contain the direct transmission matrix D of the
          system.
          On entry, if FACT = 'C', the leading M-by-M upper
          triangular part (if UPLO = 'U') or lower triangular part
          (if UPLO = 'L') of this array must contain the Cholesky
          factor of the positive definite input weighting matrix R
          (as produced by LAPACK routine DPOTRF).
          On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M
          upper triangular part (if UPLO = 'U') or lower triangular
          part (if UPLO = 'L') of this array must contain the
          factors of the UdU' or LdL' factorization, respectively,
          of the symmetric indefinite input weighting matrix R (as
          produced by LAPACK routine DSYTRF).
          The stricly lower triangular part (if UPLO = 'U') or
          stricly upper triangular part (if UPLO = 'L') of this
          array is used as workspace.
          On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1),
          the leading M-by-M upper triangular part (if UPLO = 'U')
          or lower triangular part (if UPLO = 'L') of this array
          contains the Cholesky factor of the given input weighting
          matrix (for DICO = 'C'), or that of the matrix R + B'XB
          (for DICO = 'D').
          On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1),
          the leading M-by-M upper triangular part (if UPLO = 'U')
          or lower triangular part (if UPLO = 'L') of this array
          contains the factors of the UdU' or LdL' factorization,
          respectively, of the given input weighting matrix
          (for DICO = 'C'), or that of the matrix R + B'XB
          (for DICO = 'D').
          On exit R is unchanged if FACT = 'U'.

  LDR     INTEGER.
          The leading dimension of the array R.
          LDR >= MAX(1,M)   if FACT <> 'D';
          LDR >= MAX(1,M,P) if FACT =  'D'.

  IPIV    (input/output) INTEGER array, dimension (M)
          On entry, if FACT = 'U', this array must contain details
          of the interchanges performed and the block structure of
          the d factor in the UdU' or LdL' factorization of matrix R
          (as produced by LAPACK routine DSYTRF).
          On exit, if OUFACT(1) = 2, this array contains details of
          the interchanges performed and the block structure of the
          d factor in the UdU' or LdL' factorization of matrix R (or
          D'D) or R + B'XB (or D'D + B'XB), as produced by LAPACK
          routine DSYTRF.
          This array is not referenced for DICO = 'D' or FACT = 'D',
          or 'C'.

  L       (input) DOUBLE PRECISION array, dimension (LDL,M)
          If JOBL = 'N', the leading N-by-M part of this array must
          contain the cross weighting matrix L.
          If JOBL = 'Z', this array is not referenced.

  LDL     INTEGER
          The leading dimension of array L.
          LDL >= MAX(1,N) if JOBL = 'N';
          LDL >= 1        if JOBL = 'Z'.

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, the leading N-by-N part of this array must
          contain the solution matrix X of the algebraic Riccati
          equation as produced by SLICOT Library routines SB02MD or
          SB02OD. Matrix X is assumed non-negative definite.
          On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 1,
          and INFO = 0, the N-by-N upper triangular part of this
          array contains the Cholesky factor of the given matrix X,
          which is found to be positive definite.
          On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2,
          and INFO = 0, the leading N-by-N part of this array
          contains the matrix of orthonormal eigenvectors of X.
          On exit X is unchanged if DICO = 'C' or FACT = 'N'.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= MAX(1,N).

  RNORM   (input) DOUBLE PRECISION
          If FACT = 'U', this parameter must contain the 1-norm of
          the original matrix R (before factoring it).
          Otherwise, this parameter is not used.

  F       (output) DOUBLE PRECISION array, dimension (LDF,N)
          The leading M-by-N part of this array contains the
          optimal feedback matrix F.

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).

  OUFACT  (output) INTEGER array, dimension (2)
          Information about the factorization finally used.
          OUFACT(1) = 1:  Cholesky factorization of R (or R + B'XB)
                          has been used;
          OUFACT(1) = 2:  UdU' (if UPLO = 'U') or LdL' (if UPLO =
                          'L') factorization of R (or R + B'XB)
                          has been used;
          OUFACT(2) = 1:  Cholesky factorization of X has been used;
          OUFACT(2) = 2:  Spectral factorization of X has been used.
          The value of OUFACT(2) is not set for DICO = 'C' or for
          DICO = 'D' and FACT = 'N'.
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and DWORK(2) contains the reciprocal condition
          number of the matrix R (for DICO = 'C') or of R + B'XB
          (for DICO = 'D').
          If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),...,
          DWORK(N+2) contain the eigenvalues of X, in ascending
          order.

  LDWORK  INTEGER
          Dimension of working array DWORK.
          LDWORK >= max(2,3*M)         if FACT = 'N';
          LDWORK >= max(2,2*M)         if FACT = 'U';
          LDWORK >= max(2,3*M)         if FACT = 'C', DICO = 'C';
          LDWORK >= N+3*M+2            if FACT = 'C', DICO = 'D';
          LDWORK >= max(2,min(P,M)+M)  if FACT = 'D', DICO = 'C';
          LDWORK >= max(N+3*M+2,4*N+1) if FACT = 'D', DICO = 'D'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = i:  if the i-th element of the d factor is exactly zero;
                the UdU' (or LdL') factorization has been completed,
                but the block diagonal matrix d is exactly singular;
          = M+1:  if the matrix R (if DICO = 'C'), or R + B'XB
                (if DICO = 'D') is numerically singular (to working
                precision);
          = M+2:  if one or more of the eigenvalues of X has not
                converged.
Method 
  The optimal feedback matrix F is obtained as the solution to the
  system of linear equations

     (R + B'XB) * F = B'XA + L'

  in the discrete-time case and

     R * F = B'X + L'

  in the continuous-time case, with R replaced by D'D if FACT = 'D'.
  The factored form of R, specified by FACT <> 'N', is taken into
  account. If FACT = 'N', Cholesky factorization is tried first, but
  if the coefficient matrix is not positive definite, then UdU' (or
  LdL') factorization is used. The discrete-time case involves
  updating of a triangular factorization of R (or D'D); Cholesky or
  symmetric spectral factorization of X is employed to avoid
  squaring of the condition number of the matrix. When D is given,
  its QR factorization is determined, and the triangular factor is
  used as described above.
Numerical Aspects 
  The algorithm consists of numerically stable steps.
                                 3     2
  For DICO = 'C', it requires O(m  + mn ) floating point operations
                        2
  if FACT = 'N' and O(mn ) floating point operations, otherwise.
  For DICO = 'D', the operation counts are similar, but additional
     3
  O(n ) floating point operations may be needed in the worst case.
Further Comments 
  None
Example

Program Text 

*     SB02ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          NMAX2
      PARAMETER        ( NMAX2 = 2*NMAX )
      INTEGER          LDA, LDB, LDC, LDL, LDR, LDS, LDT, LDU, LDX, LDF
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDL = NMAX,
     $                   LDR = MAX(MMAX,PMAX), LDS = NMAX2+MMAX,
     $                   LDT = NMAX2+MMAX, LDU = NMAX2, LDX = NMAX,
     $                   LDF = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( NMAX2,MMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX+3*MMAX+2, 14*NMAX+23,
     $                   16*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL, RCOND, RNORM
      INTEGER          I, INFO1, INFO2, J, M, N, P
      CHARACTER*1      DICO, FACT, JOBB, JOBL, SORT, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALFAI(2*NMAX), ALFAR(2*NMAX),
     $                 B(LDB,MMAX), BETA(2*NMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), F(LDF,NMAX), L(LDL,MMAX),
     $                 R(LDR,MMAX), S(LDS,NMAX2+MMAX), T(LDT,NMAX2),
     $                 U(LDU,NMAX2), X(LDX,NMAX)
      INTEGER          IPIV(LIWORK), IWORK(LIWORK), OUFACT(2)
      LOGICAL          BWORK(NMAX2)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB02ND, SB02OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO, FACT, JOBL, UPLO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               IF ( LSAME( FACT, 'D' ) ) THEN
                  READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,P )
               ELSE
                  READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,M )
               END IF
*              Find the solution matrix X.
               JOBB = 'B'
               SORT = 'S'
               CALL SB02OD( DICO, JOBB, 'Both', UPLO, JOBL, SORT, N, M,
     $                      P, A, LDA, B, LDB, C, LDC, R, LDR, L, LDL,
     $                      RCOND, X, LDX, ALFAR, ALFAI, BETA, S, LDS,
     $                      T, LDT, U, LDU, TOL, IWORK, DWORK, LDWORK,
     $                      BWORK, INFO1 )
*
               IF ( INFO1.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO1
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N )
   20             CONTINUE
*                 Compute the optimal feedback matrix F.
                  CALL 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, INFO2 )
*
                  IF ( INFO2.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99997 ) INFO2
                  ELSE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 40 I = 1, M
                        WRITE ( NOUT, FMT = 99994 ) ( F(I,J), J = 1,N )
   40                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02OD = ',I2)
99997 FORMAT (' INFO on exit from SB02ND = ',I2)
99996 FORMAT (' The solution matrix X is ')
99995 FORMAT (/' The optimal feedback matrix F is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 SB02ND EXAMPLE PROGRAM DATA
   2     1     3     0.0     D     N     Z     U
   2.0 -1.0
   1.0  0.0
   1.0
   0.0
   0.0  0.0
   0.0  0.0
   0.0  1.0
   0.0
   0.0
   0.0
Program Results 
 SB02ND EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   1.0000   0.0000
   0.0000   1.0000

 The optimal feedback matrix F is 
   2.0000  -1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02OD.html000077500000000000000000000550001201767322700160750ustar00rootroot00000000000000 SB02OD - SLICOT Library Routine Documentation

SB02OD

Solution of continuous- or discrete-time algebraic Riccati equations (generalized Schur vectors method)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the continuous-time algebraic Riccati
  equation
                           -1
     Q + A'X + XA - (L+XB)R  (L+XB)' = 0                       (1)

  or the discrete-time algebraic Riccati equation
                                  -1
     X = A'XA - (L+A'XB)(R + B'XB)  (L+A'XB)' + Q              (2)

  where A, B, Q, R, and L are N-by-N, N-by-M, N-by-N, M-by-M and
  N-by-M matrices, respectively, such that Q = C'C, R = D'D and
  L = C'D; X is an N-by-N symmetric matrix.
  The routine also returns the computed values of the closed-loop
  spectrum of the system, i.e., the stable eigenvalues lambda(1),
  ..., lambda(N) of the corresponding Hamiltonian or symplectic
  pencil, in the continuous-time case or discrete-time case,
  respectively.
                           -1
  Optionally, matrix G = BR  B' may be given instead of B and R.
  Other options include the case with Q and/or R given in a
  factored form, Q = C'C, R = D'D, and with L a zero matrix.

  The routine uses the method of deflating subspaces, based on
  reordering the eigenvalues in a generalized Schur matrix pair.
  A standard eigenproblem is solved in the continuous-time case
  if G is given.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of Riccati equation to be solved as
          follows:
          = 'C':  Equation (1), continuous-time case;
          = 'D':  Equation (2), discrete-time case.

  JOBB    CHARACTER*1
          Specifies whether or not the matrix G is given, instead
          of the matrices B and R, as follows:
          = 'B':  B and R are given;
          = 'G':  G is given.

  FACT    CHARACTER*1
          Specifies whether or not the matrices Q and/or R (if
          JOBB = 'B') are factored, as follows:
          = 'N':  Not factored, Q and R are given;
          = 'C':  C is given, and Q = C'C;
          = 'D':  D is given, and R = D'D;
          = 'B':  Both factors C and D are given, Q = C'C, R = D'D.

  UPLO    CHARACTER*1
          If JOBB = 'G', or FACT = 'N', specifies which triangle of
          the matrices G and Q (if FACT = 'N'), or Q and R (if
          JOBB = 'B'), is stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.

  JOBL    CHARACTER*1
          Specifies whether or not the matrix L is zero, as follows:
          = 'Z':  L is zero;
          = 'N':  L is nonzero.
          JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed.
          SLICOT Library routine SB02MT should be called just before
          SB02OD, for obtaining the results when JOBB = 'G' and
          JOBL = 'N'.

  SORT    CHARACTER*1
          Specifies which eigenvalues should be obtained in the top
          of the generalized Schur form, as follows:
          = 'S':  Stable   eigenvalues come first;
          = 'U':  Unstable eigenvalues come first.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e. the order of the matrices
          A, Q, and X, and the number of rows of the matrices B
          and L.  N >= 0.

  M       (input) INTEGER
          The number of system inputs. If JOBB = 'B', M is the
          order of the matrix R, and the number of columns of the
          matrix B.  M >= 0.
          M is not used if JOBB = 'G'.

  P       (input) INTEGER
          The number of system outputs. If FACT = 'C' or 'D' or 'B',
          P is the number of rows of the matrices C and/or D.
          P >= 0.
          Otherwise, P is not used.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,*)
          If JOBB = 'B', the leading N-by-M part of this array must
          contain the input matrix B of the system.
          If JOBB = 'G', the leading N-by-N upper triangular part
          (if UPLO = 'U') or lower triangular part (if UPLO = 'L')
          of this array must contain the upper triangular part or
          lower triangular part, respectively, of the matrix
                -1
          G = BR  B'. The stricly lower triangular part (if
          UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
          If FACT = 'N' or 'D', the leading N-by-N upper triangular
          part (if UPLO = 'U') or lower triangular part (if UPLO =
          'L') of this array must contain the upper triangular part
          or lower triangular part, respectively, of the symmetric
          state weighting matrix Q. The stricly lower triangular
          part (if UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.
          If JOBB = 'B', the triangular part of this array defined
          by UPLO is modified internally, but is restored on exit.
          If FACT = 'C' or 'B', the leading P-by-N part of this
          array must contain the output matrix C of the system.
          If JOBB = 'B', this part is modified internally, but is
          restored on exit.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= MAX(1,N) if FACT = 'N' or 'D',
          LDQ >= MAX(1,P) if FACT = 'C' or 'B'.

  R       (input) DOUBLE PRECISION array, dimension (LDR,M)
          If FACT = 'N' or 'C', the leading M-by-M upper triangular
          part (if UPLO = 'U') or lower triangular part (if UPLO =
          'L') of this array must contain the upper triangular part
          or lower triangular part, respectively, of the symmetric
          input weighting matrix R. The stricly lower triangular
          part (if UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.
          The triangular part of this array defined by UPLO is
          modified internally, but is restored on exit.
          If FACT = 'D' or 'B', the leading P-by-M part of this
          array must contain the direct transmission matrix D of the
          system. This part is modified internally, but is restored
          on exit.
          If JOBB = 'G', this array is not referenced.

  LDR     INTEGER
          The leading dimension of array R.
          LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C';
          LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B';
          LDR >= 1        if JOBB = 'G'.

  L       (input) DOUBLE PRECISION array, dimension (LDL,M)
          If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of
          this array must contain the cross weighting matrix L.
          This part is modified internally, but is restored on exit.
          If JOBL = 'Z' or JOBB = 'G', this array is not referenced.

  LDL     INTEGER
          The leading dimension of array L.
          LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B';
          LDL >= 1        if JOBL = 'Z' or  JOBB = 'G'.

  RCOND   (output) DOUBLE PRECISION
          An estimate of the reciprocal of the condition number (in
          the 1-norm) of the N-th order system of algebraic
          equations from which the solution matrix X is obtained.

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array contains the
          solution matrix X of the problem.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= MAX(1,N).

  ALFAR   (output) DOUBLE PRECISION array, dimension (2*N)
  ALFAI   (output) DOUBLE PRECISION array, dimension (2*N)
  BETA    (output) DOUBLE PRECISION array, dimension (2*N)
          The generalized eigenvalues of the 2N-by-2N matrix pair,
          ordered as specified by SORT (if INFO = 0). For instance,
          if SORT = 'S', the leading N elements of these arrays
          contain the closed-loop spectrum of the system matrix
          A - BF, where F is the optimal feedback matrix computed
          based on the solution matrix X. Specifically,
             lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for
          k = 1,2,...,N.
          If DICO = 'C' and JOBB = 'G', the elements of BETA are
          set to 1.

  S       (output) DOUBLE PRECISION array, dimension (LDS,*)
          The leading 2N-by-2N part of this array contains the
          ordered real Schur form S of the first matrix in the
          reduced matrix pencil associated to the optimal problem,
          or of the corresponding Hamiltonian matrix, if DICO = 'C'
          and JOBB = 'G'. That is,

                 (S   S  )
                 ( 11  12)
             S = (       ),
                 (0   S  )
                 (     22)

          where S  , S   and S   are N-by-N matrices.
                 11   12      22
          Array S must have 2*N+M columns if JOBB = 'B', and 2*N
          columns, otherwise.

  LDS     INTEGER
          The leading dimension of array S.
          LDS >= MAX(1,2*N+M) if JOBB = 'B',
          LDS >= MAX(1,2*N)   if JOBB = 'G'.

  T       (output) DOUBLE PRECISION array, dimension (LDT,2*N)
          If DICO = 'D' or JOBB = 'B', the leading 2N-by-2N part of
          this array contains the ordered upper triangular form T of
          the second matrix in the reduced matrix pencil associated
          to the optimal problem. That is,

                 (T   T  )
                 ( 11  12)
             T = (       ),
                 (0   T  )
                 (     22)

          where T  , T   and T   are N-by-N matrices.
                 11   12      22
          If DICO = 'C' and JOBB = 'G' this array is not referenced.

  LDT     INTEGER
          The leading dimension of array T.
          LDT >= MAX(1,2*N+M) if JOBB = 'B',
          LDT >= MAX(1,2*N)   if JOBB = 'G' and DICO = 'D',
          LDT >= 1            if JOBB = 'G' and DICO = 'C'.

  U       (output) DOUBLE PRECISION array, dimension (LDU,2*N)
          The leading 2N-by-2N part of this array contains the right
          transformation matrix U which reduces the 2N-by-2N matrix
          pencil to the ordered generalized real Schur form (S,T),
          or the Hamiltonian matrix to the ordered real Schur
          form S, if DICO = 'C' and JOBB = 'G'. That is,

                 (U   U  )
                 ( 11  12)
             U = (       ),
                 (U   U  )
                 ( 21  22)

          where U  , U  , U   and U   are N-by-N matrices.
                 11   12   21      22

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,2*N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the original matrix pencil, specifically of the triangular
          factor obtained during the reduction process. If the user
          sets TOL > 0, then the given value of TOL is used as a
          lower bound for the reciprocal condition number of that
          matrix; a matrix whose estimated condition number is less
          than 1/TOL is considered to be nonsingular. If the user
          sets TOL <= 0, then a default tolerance, defined by
          TOLDEF = EPS, is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not referenced if JOBB = 'G'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= MAX(1,M,2*N) if JOBB = 'B',
          LIWORK >= MAX(1,2*N)   if JOBB = 'G'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the
          reciprocal of the condition number of the M-by-M lower
          triangular matrix obtained after compressing the matrix
          pencil of order 2N+M to obtain a pencil of order 2N.
          If INFO = 0 or INFO = 6, DWORK(3) returns the scaling
          factor used internally, which should multiply the
          submatrix Y2 to recover X from the first N columns of U
          (see METHOD).

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(3,6*N),                       if JOBB = 'G',
                                                         DICO = 'C';
          LDWORK >= MAX(7*(2*N+1)+16,16*N),           if JOBB = 'G',
                                                         DICO = 'D';
          LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'.
          For optimum performance LDWORK should be larger.

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the computed extended matrix pencil is singular,
                possibly due to rounding errors;
          = 2:  if the QZ (or QR) algorithm failed;
          = 3:  if reordering of the (generalized) eigenvalues
                failed;
          = 4:  if after reordering, roundoff changed values of
                some complex eigenvalues so that leading eigenvalues
                in the (generalized) Schur form no longer satisfy
                the stability condition; this could also be caused
                due to scaling;
          = 5:  if the computed dimension of the solution does not
                equal N;
          = 6:  if a singular matrix was encountered during the
                computation of the solution matrix X.
Method 
  The routine uses a variant of the method of deflating subspaces
  proposed by van Dooren [1]. See also [2], [3].
  It is assumed that (A,B) is stabilizable and (C,A) is detectable.
  Under these assumptions the algebraic Riccati equation is known to
  have a unique non-negative definite solution.
  The first step in the method of deflating subspaces is to form the
  extended Hamiltonian matrices, dimension 2N + M given by

        discrete-time                   continuous-time

  |A   0   B|     |I   0   0|    |A   0   B|     |I   0   0|
  |Q  -I   L| - z |0  -A'  0|,   |Q   A'  L| - s |0  -I   0|.
  |L'  0   R|     |0  -B'  0|    |L'  B'  R|     |0   0   0|

  Next, these pencils are compressed to a form (see [1])

     lambda x A  - B .
               f    f

  This generalized eigenvalue problem is then solved using the QZ
  algorithm and the stable deflating subspace Ys is determined.
  If [Y1'|Y2']' is a basis for Ys, then the required solution is
                    -1
         X = Y2 x Y1  .
  A standard eigenvalue problem is solved using the QR algorithm in
  the continuous-time case when G is given (DICO = 'C', JOBB = 'G').
References 
  [1] Van Dooren, P.
      A Generalized Eigenvalue Approach for Solving Riccati
      Equations.
      SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981.

  [2] Mehrmann, V.
      The Autonomous Linear Quadratic Control Problem. Theory and
      Numerical Solution.
      Lect. Notes in Control and Information Sciences, vol. 163,
      Springer-Verlag, Berlin, 1991.

  [3] Sima, V.
      Algorithms for Linear-Quadratic Optimization.
      Pure and Applied Mathematics: A Series of Monographs and
      Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
  This routine is particularly suited for systems where the matrix R
  is ill-conditioned. Internal scaling is used.
Further Comments 
  To obtain a stabilizing solution of the algebraic Riccati
  equations set SORT = 'S'.

  The routine can also compute the anti-stabilizing solutions of
  the algebraic Riccati equations, by specifying SORT = 'U'.
Example

Program Text 

*     SB02OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          NMAX2M, NMAX2
      PARAMETER        ( NMAX2M = 2*NMAX+MMAX, NMAX2 = 2*NMAX )
      INTEGER          LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDL = NMAX,
     $                   LDQ = MAX(NMAX,PMAX), LDR = MAX(MMAX,PMAX),
     $                   LDS = NMAX2M, LDT = NMAX2M, LDU = NMAX2,
     $                   LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX(MMAX,NMAX2) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX(14*NMAX+23,16*NMAX) )
      INTEGER          LBWORK
      PARAMETER        ( LBWORK = NMAX2 )
*     .. Local Scalars ..
      DOUBLE PRECISION RCOND, TOL
      INTEGER          I, INFO, J, M, N, P
      CHARACTER*1      DICO, FACT, JOBB, JOBL, SORT, UPLO
      LOGICAL          LJOBB
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALFAI(NMAX2), ALFAR(NMAX2),
     $                 B(LDB,MMAX), BETA(NMAX2), DWORK(LDWORK),
     $                 L(LDL,MMAX), Q(LDQ,NMAX), R(LDR,MMAX),
     $                 S(LDS,NMAX2M), T(LDT,NMAX2), U(LDU,NMAX2),
     $                 X(LDX,NMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LBWORK)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL         SB02OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBB, FACT, UPLO, JOBL,
     $                      SORT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) M
         ELSE
            LJOBB = LSAME( JOBB, 'B' )
            IF ( LJOBB ) THEN
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
            END IF
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99993 ) P
            ELSE
               IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'D' ) ) THEN
                  READ ( NIN, FMT = * )
     $                                 ( ( Q(I,J), J = 1,N ), I = 1,N )
               ELSE
                  READ ( NIN, FMT = * )
     $                                 ( ( Q(I,J), J = 1,N ), I = 1,P )
               END IF
               IF ( LJOBB ) THEN
                  IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'C' ) ) THEN
                      READ ( NIN, FMT = * )
     $                                  ( ( R(I,J), J = 1,M ), I = 1,M )
                  ELSE
                      READ ( NIN, FMT = * )
     $                                  ( ( R(I,J), J = 1,M ), I = 1,P )
                  END IF
                  IF ( LSAME( JOBL, 'N' ) )
     $                READ ( NIN, FMT = * )
     $                                  ( ( L(I,J), J = 1,M ), I = 1,N )
               END IF
*              Find the solution matrix X.
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N )
   20             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02OD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
99993 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 SB02OD EXAMPLE PROGRAM DATA
   2     1     3     0.0     C     B     B     U     Z     S
   0.0  1.0
   0.0  0.0
   0.0
   1.0
   1.0  0.0
   0.0  1.0
   0.0  0.0
   0.0
   0.0
   1.0
Program Results 
 SB02OD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   1.7321   1.0000
   1.0000   1.7321

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02OY.html000077500000000000000000000325721201767322700161330ustar00rootroot00000000000000 SB02OY - SLICOT Library Routine Documentation

SB02OY

Constructing the extended Hamiltonian or symplectic matrix pairs for linear-quadratic optimization problems, and compressing them to 2N-by-2N matrices

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the extended matrix pairs for the computation of the
  solution of the algebraic matrix Riccati equations arising in the
  problems of optimal control, both discrete and continuous-time,
  and of spectral factorization, both discrete and continuous-time.
  These matrix pairs, of dimension 2N + M, are given by

        discrete-time                   continuous-time

  |A   0   B|     |E   0   0|    |A   0   B|     |E   0   0|
  |Q  -E'  L| - z |0  -A'  0|,   |Q   A'  L| - s |0  -E'  0|.   (1)
  |L'  0   R|     |0  -B'  0|    |L'  B'  R|     |0   0   0|

  After construction, these pencils are compressed to a form
  (see [1])

     lambda x A  - B ,
               f    f

  where A  and B  are 2N-by-2N matrices.
         f      f
                           -1
  Optionally, matrix G = BR  B' may be given instead of B and R;
  then, for L = 0, 2N-by-2N matrix pairs are directly constructed as

      discrete-time            continuous-time

  |A   0 |     |E   G |    |A  -G |     |E   0 |
  |      | - z |      |,   |      | - s |      |.               (2)
  |Q  -E'|     |0  -A'|    |Q   A'|     |0  -E'|

  Similar pairs are obtained for non-zero L, if SLICOT Library
  routine SB02MT is called before SB02OY.
  Other options include the case with E identity matrix, L a zero
  matrix, or Q and/or R given in a factored form, Q = C'C, R = D'D.
  For spectral factorization problems, there are minor differences
  (e.g., B is replaced by C').
  The second matrix in (2) is not constructed in the continuous-time
  case if E is specified as being an identity matrix.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  TYPE    CHARACTER*1
          Specifies the type of problem to be addressed as follows:
          = 'O':  Optimal control problem;
          = 'S':  Spectral factorization problem.

  DICO    CHARACTER*1
          Specifies the type of linear system considered as follows:
          = 'C':  Continuous-time system;
          = 'D':  Discrete-time system.

  JOBB    CHARACTER*1
          Specifies whether or not the matrix G is given, instead
          of the matrices B and R, as follows:
          = 'B':  B and R are given;
          = 'G':  G is given.
          For JOBB = 'G', a 2N-by-2N matrix pair is directly
          obtained assuming L = 0 (see the description of JOBL).

  FACT    CHARACTER*1
          Specifies whether or not the matrices Q and/or R (if
          JOBB = 'B') are factored, as follows:
          = 'N':  Not factored, Q and R are given;
          = 'C':  C is given, and Q = C'C;
          = 'D':  D is given, and R = D'D (if TYPE = 'O'), or
                  R = D + D' (if TYPE = 'S');
          = 'B':  Both factors C and D are given, Q = C'C, R = D'D
                  (or R = D + D').

  UPLO    CHARACTER*1
          If JOBB = 'G', or FACT = 'N', specifies which triangle of
          the matrices G and Q (if FACT = 'N'), or Q and R (if
          JOBB = 'B'), is stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.

  JOBL    CHARACTER*1
          Specifies whether or not the matrix L is zero, as follows:
          = 'Z':  L is zero;
          = 'N':  L is nonzero.
          JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed.
          Using SLICOT Library routine SB02MT to compute the
          corresponding A and Q in this case, before calling SB02OY,
          enables to obtain 2N-by-2N matrix pairs directly.

  JOBE    CHARACTER*1
          Specifies whether or not the matrix E is identity, as
          follows:
          = 'I':  E is the identity matrix;
          = 'N':  E is a general matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, Q, and E, and the number
          of rows of the matrices B and L.  N >= 0.

  M       (input) INTEGER
          If JOBB = 'B', M is the order of the matrix R, and the
          number of columns of the matrix B.  M >= 0.
          M is not used if JOBB = 'G'.

  P       (input) INTEGER
          If FACT = 'C' or 'D' or 'B', or if TYPE = 'S', P is the
          number of rows of the matrix C and/or D, respectively.
          P >= 0, and if JOBB = 'B' and TYPE = 'S', then P = M.
          Otherwise, P is not used.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,*)
          If JOBB = 'B', the leading N-by-M part of this array must
          contain the input matrix B of the system.
          If JOBB = 'G', the leading N-by-N upper triangular part
          (if UPLO = 'U') or lower triangular part (if UPLO = 'L')
          of this array must contain the upper triangular part or
          lower triangular part, respectively, of the matrix
                -1
          G = BR  B'. The stricly lower triangular part (if
          UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
          If FACT = 'N' or 'D', the leading N-by-N upper triangular
          part (if UPLO = 'U') or lower triangular part (if UPLO =
          'L') of this array must contain the upper triangular part
          or lower triangular part, respectively, of the symmetric
          output weighting matrix Q. The stricly lower triangular
          part (if UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.
          If FACT = 'C' or 'B', the leading P-by-N part of this
          array must contain the output matrix C of the system.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= MAX(1,N) if FACT = 'N' or 'D',
          LDQ >= MAX(1,P) if FACT = 'C' or 'B'.

  R       (input) DOUBLE PRECISION array, dimension (LDR,M)
          If FACT = 'N' or 'C', the leading M-by-M upper triangular
          part (if UPLO = 'U') or lower triangular part (if UPLO =
          'L') of this array must contain the upper triangular part
          or lower triangular part, respectively, of the symmetric
          input weighting matrix R. The stricly lower triangular
          part (if UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.
          If FACT = 'D' or 'B', the leading P-by-M part of this
          array must contain the direct transmission matrix D of the
          system.
          If JOBB = 'G', this array is not referenced.

  LDR     INTEGER
          The leading dimension of array R.
          LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C';
          LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B';
          LDR >= 1        if JOBB = 'G'.

  L       (input) DOUBLE PRECISION array, dimension (LDL,M)
          If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of
          this array must contain the cross weighting matrix L.
          If JOBL = 'Z' or JOBB = 'G', this array is not referenced.

  LDL     INTEGER
          The leading dimension of array L.
          LDL >= MAX(1,N) if JOBL = 'N';
          LDL >= 1        if JOBL = 'Z' or JOBB = 'G'.

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          If JOBE = 'N', the leading N-by-N part of this array must
          contain the matrix E of the descriptor system.
          If JOBE = 'I', E is taken as identity and this array is
          not referenced.

  LDE     INTEGER
          The leading dimension of array E.
          LDE >= MAX(1,N) if JOBE = 'N';
          LDE >= 1        if JOBE = 'I'.

  AF      (output) DOUBLE PRECISION array, dimension (LDAF,*)
          The leading 2N-by-2N part of this array contains the
          matrix A  in the matrix pencil.
                  f
          Array AF must have 2*N+M columns if JOBB = 'B', and 2*N
          columns, otherwise.

  LDAF    INTEGER
          The leading dimension of array AF.
          LDAF >= MAX(1,2*N+M) if JOBB = 'B',
          LDAF >= MAX(1,2*N)   if JOBB = 'G'.

  BF      (output) DOUBLE PRECISION array, dimension (LDBF,2*N)
          If DICO = 'D' or JOBB = 'B' or JOBE = 'N', the leading
          2N-by-2N part of this array contains the matrix B  in the
                                                           f
          matrix pencil.
          The last M zero columns are never constructed.
          If DICO = 'C' and JOBB = 'G' and JOBE = 'I', this array
          is not referenced.

  LDBF    INTEGER
          The leading dimension of array BF.
          LDBF >= MAX(1,2*N+M) if JOBB = 'B',
          LDBF >= MAX(1,2*N)   if JOBB = 'G' and ( DICO = 'D' or
                                                   JOBE = 'N' ),
          LDBF >= 1            if JOBB = 'G' and ( DICO = 'C' and
                                                   JOBE = 'I' ).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the original matrix pencil, specifically of the triangular
          factor obtained during the reduction process. If the user
          sets TOL > 0, then the given value of TOL is used as a
          lower bound for the reciprocal condition number of that
          matrix; a matrix whose estimated condition number is less
          than 1/TOL is considered to be nonsingular. If the user
          sets TOL <= 0, then a default tolerance, defined by
          TOLDEF = EPS, is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not referenced if JOBB = 'G'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= M if JOBB = 'B',
          LIWORK >= 1 if JOBB = 'G'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK. If JOBB = 'B', DWORK(2) returns the reciprocal
          of the condition number of the M-by-M lower triangular
          matrix obtained after compression.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 1                  if JOBB = 'G',
          LDWORK >= MAX(1,2*N + M,3*M) if JOBB = 'B'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the computed extended matrix pencil is singular,
                possibly due to rounding errors.
Method 
  The extended matrix pairs are constructed, taking various options
  into account. If JOBB = 'B', the problem order is reduced from
  2N+M to 2N (see [1]).
References 
  [1] Van Dooren, P.
      A Generalized Eigenvalue Approach for Solving Riccati
      Equations.
      SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981.

  [2] Mehrmann, V.
      The Autonomous Linear Quadratic Control Problem. Theory and
      Numerical Solution.
      Lect. Notes in Control and Information Sciences, vol. 163,
      Springer-Verlag, Berlin, 1991.

  [3] Sima, V.
      Algorithms for Linear-Quadratic Optimization.
      Pure and Applied Mathematics: A Series of Monographs and
      Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB02PD.html000077500000000000000000000311661201767322700161050ustar00rootroot00000000000000 SB02PD - SLICOT Library Routine Documentation

SB02PD

Solution of continuous-time algebraic Riccati equations (matrix sign function method) with error bounds and condition estimates

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the real continuous-time matrix algebraic Riccati
  equation

     op(A)'*X + X*op(A) + Q - X*G*X = 0,

  where op(A) = A or A' = A**T and G, Q are symmetric (G = G**T,
  Q = Q**T). The matrices A, G and Q are N-by-N and the solution X
  is an N-by-N symmetric matrix.

  An error bound on the solution and a condition estimate are also
  optionally provided.

  It is assumed that the matrices A, G and Q are such that the
  corresponding Hamiltonian matrix has N eigenvalues with negative
  real parts.
Specification 
      SUBROUTINE SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X,
     $                   LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER          JOB, TRANA, UPLO
      INTEGER            INFO, LDA, LDG, LDQ, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ), G( LDG, * ),
     $                   Q( LDQ, * ), WI( * ), WR( * ), X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'X':  Compute the solution only;
          = 'A':  Compute all: the solution, reciprocal condition
                  number, and the error bound.

  TRANA   CHARACTER*1
          Specifies the option op(A):
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which triangle of the matrices G and Q is
          stored, as follows:
          = 'U':  Upper triangles of G and Q are stored;
          = 'L':  Lower triangles of G and Q are stored.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, G, Q, and X.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          coefficient matrix A of the equation.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  G       (input) DOUBLE PRECISION array, dimension (LDG,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix G.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix G.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= max(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix Q.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix Q.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= max(1,N).

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          If INFO = 0, INFO = 2, or INFO = 4, the leading N-by-N
          part of this array contains the symmetric solution matrix
          X of the algebraic Riccati equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'A', the estimate of the reciprocal condition
          number of the Riccati equation.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'A', the estimated forward error bound for the
          solution X. If XTRUE is the true solution, FERR bounds the
          magnitude of the largest entry in (X - XTRUE) divided by
          the magnitude of the largest entry in X.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          If JOB = 'A' and TRANA = 'N', WR and WI contain the real
          and imaginary parts, respectively, of the eigenvalues of
          the matrix A - G*X, i.e., the closed-loop system poles.
          If JOB = 'A' and TRANA = 'T' or 'C', WR and WI contain the
          real and imaginary parts, respectively, of the eigenvalues
          of the matrix A - X*G, i.e., the closed-loop system poles.
          If JOB = 'X', these arrays are not referenced.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK), where
          LIWORK >= 2*N,          if JOB = 'X';
          LIWORK >= max(2*N,N*N), if JOB = 'A'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = 2, DWORK(1) contains the
          optimal value of LDWORK. If JOB = 'A', then DWORK(2:N*N+1)
          and DWORK(N*N+2:2*N*N+1) contain a real Schur form of the
          closed-loop system matrix, Ac = A - G*X (if TRANA = 'N')
          or Ac = A - X*G (if TRANA = 'T' or 'C'), and the
          orthogonal matrix which reduced Ac to real Schur form,
          respectively.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 4*N*N + 8*N + 1,               if JOB = 'X';
          LDWORK >= max( 4*N*N + 8*N, 6*N*N ) + 1, if JOB = 'A'.
          For good performance, LDWORK should be larger, e.g.,
          LDWORK >= 4*N*N + 6*N +( 2*N+1 )*NB,     if JOB = 'X',
          where NB is the optimal blocksize.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the Hamiltonian matrix has eigenvalues on the
                imaginary axis, so the solution and error bounds
                could not be computed;
          = 2:  the iteration for the matrix sign function failed to
                converge after 50 iterations, but an approximate
                solution and error bounds (if JOB = 'A') have been
                computed;
          = 3:  the system of linear equations for the solution is
                singular to working precision, so the solution and
                error bounds could not be computed;
          = 4:  the matrix A-G*X (or A-X*G) cannot be reduced to
                Schur canonical form and condition number estimate
                and forward error estimate have not been computed.
Method 
  The Riccati equation is solved by the matrix sign function
  approach [1], [2], implementing a scaling which enhances the
  numerical stability [4].
References 
  [1] Bai, Z., Demmel, J., Dongarra, J., Petitet, A., Robinson, H.,
      and Stanley, K.
      The spectral decomposition of nonsymmetric matrices on
      distributed memory parallel computers.
      SIAM J. Sci. Comput., vol. 18, pp. 1446-1461, 1997.

  [2] Byers, R., He, C., and Mehrmann, V.
      The matrix sign function method and the computation of
      invariant subspaces.
      SIAM J. Matrix Anal. Appl., vol. 18, pp. 615-632, 1997.

  [3] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.

  [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.,
      DGRSVX and DMSRIC: Fortran 77 subroutines for solving
      continuous-time matrix algebraic Riccati equations with
      condition and accuracy estimates.
      Preprint SFB393/98-16, Fak. f. Mathematik, Technical
      University Chemnitz, May 1998.
Numerical Aspects 
  The solution accuracy can be controlled by the output parameter
  FERR.
Further Comments 
  The condition number of the Riccati equation is estimated as

  cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) +
              norm(Pi)*norm(G) ) / norm(X),

  where Omega, Theta and Pi are linear operators defined by

  Omega(W) = op(Ac)'*W + W*op(Ac),
  Theta(W) = inv(Omega(op(W)'*X + X*op(W))),
     Pi(W) = inv(Omega(X*W*X)),

  and the matrix Ac (the closed-loop system matrix) is given by
     Ac = A - G*X, if TRANA = 'N', or
     Ac = A - X*G, if TRANA = 'T' or 'C'.

  The program estimates the quantities

  sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)),

  norm(Theta) and norm(Pi) using 1-norm condition estimator.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [3].
Example

Program Text 

*     SB02PD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDX
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX,
     $                   LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX, NMAX*NMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 4*NMAX*NMAX + 8*NMAX,
     $                                 6*NMAX*NMAX ) + 1 )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND
      INTEGER          I, INFO, J, N
      CHARACTER        JOB, TRANA, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX),
     $                 Q(LDQ,NMAX), WI(NMAX), WR(NMAX),
     $                 X(LDX,NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB02PD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, TRANA, UPLO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X.
         CALL SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X,
     $                LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         END IF
         IF ( INFO.EQ.0 .OR. INFO.EQ.2 .OR. INFO.EQ.4 ) THEN
             WRITE ( NOUT, FMT = 99997 )
             DO 20 I = 1, N
                WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N )
   20        CONTINUE
             IF ( LSAME( JOB, 'A' ) .AND. INFO.NE.4 ) THEN
                WRITE ( NOUT, FMT = 99994 ) RCOND
                WRITE ( NOUT, FMT = 99993 ) FERR
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02PD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99993 FORMAT (/' Estimated error bound = ',F20.16)
      END
Program Data 
 SB02PD EXAMPLE PROGRAM DATA
   2     A     N     U 
   0.0   1.0
   0.0   0.0
   1.0   0.0
   0.0   2.0
   0.0   0.0
   0.0   1.0
Program Results 
 SB02PD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   2.0000   1.0000
   1.0000   2.0000

 Estimated reciprocal condition number =   0.1333

 Estimated error bound =   0.0000000000000063

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02QD.html000077500000000000000000000443061201767322700161060ustar00rootroot00000000000000 SB02QD - SLICOT Library Routine Documentation

SB02QD

Estimating conditioning and forward error bound for the solution of continuous-time Riccati equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the conditioning and compute an error bound on the
  solution of the real continuous-time matrix algebraic Riccati
  equation

      op(A)'*X + X*op(A) + Q - X*G*X = 0,                        (1)

  where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T,
  G = G**T). The matrices A, Q and G are N-by-N and the solution X
  is N-by-N.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SEP
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ),  G( LDG, * ),
     $                   Q( LDQ, * ), T( LDT, * ), U( LDU, * ),
     $                   X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'C':  Compute the reciprocal condition number only;
          = 'E':  Compute the error bound only;
          = 'B':  Compute both the reciprocal condition number and
                  the error bound.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization of
          the matrix Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G
          (if TRANA = 'T' or 'C') is supplied on entry, as follows:
          = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
                  factors from the real Schur factorization of the
                  matrix Ac;
          = 'N':  The Schur factorization of Ac will be computed
                  and the factors will be stored in T and U (if
                  LYAPUN = 'O').

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrices Q and G is
          to be used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved in the iterative estimation process,
          as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., RHS <-- U'*RHS*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, Q, and G.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of
          this array must contain the matrix A.
          If FACT = 'F' and LYAPUN = 'R', A is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= max(1,N), if FACT = 'N' or  LYAPUN = 'O';
          LDA >= 1,        if FACT = 'F' and LYAPUN = 'R'.

  T       (input or output) DOUBLE PRECISION array, dimension
          (LDT,N)
          If FACT = 'F', then T is an input argument and on entry,
          the leading N-by-N upper Hessenberg part of this array
          must contain the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of Ac (see
          argument FACT).
          If FACT = 'N', then T is an output argument and on exit,
          if INFO = 0 or INFO = N+1, the leading N-by-N upper
          Hessenberg part of this array contains the upper quasi-
          triangular matrix T in Schur canonical form from a Schur
          factorization of Ac (see argument FACT).

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= max(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If LYAPUN = 'O' and FACT = 'F', then U is an input
          argument and on entry, the leading N-by-N part of this
          array must contain the orthogonal matrix U from a real
          Schur factorization of Ac (see argument FACT).
          If LYAPUN = 'O' and FACT = 'N', then U is an output
          argument and on exit, if INFO = 0 or INFO = N+1, it
          contains the orthogonal N-by-N matrix from a real Schur
          factorization of Ac (see argument FACT).
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  G       (input) DOUBLE PRECISION array, dimension (LDG,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix G.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix G.                     _
          Matrix G should correspond to G in the "reduced" Riccati
          equation (with matrix T, instead of A), if LYAPUN = 'R'.
          See METHOD.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= max(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix Q.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix Q.                     _
          Matrix Q should correspond to Q in the "reduced" Riccati
          equation (with matrix T, instead of A), if LYAPUN = 'R'.
          See METHOD.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= max(1,N).

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array must contain the
          symmetric solution matrix of the original Riccati
          equation (with matrix A), if LYAPUN = 'O', or of the
          "reduced" Riccati equation (with matrix T), if
          LYAPUN = 'R'. See METHOD.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  SEP     (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', the estimated quantity
          sep(op(Ac),-op(Ac)').
          If N = 0, or X = 0, or JOB = 'E', SEP is not referenced.

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', an estimate of the reciprocal
          condition number of the continuous-time Riccati equation.
          If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
          If JOB = 'E', RCOND is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'E' or JOB = 'B', an estimated forward error
          bound for the solution X. If XTRUE is the true solution,
          FERR bounds the magnitude of the largest entry in
          (X - XTRUE) divided by the magnitude of the largest entry
          in X.
          If N = 0 or X = 0, FERR is set to 0.
          If JOB = 'C', FERR is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          Let LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B';
              LWA = 0,   otherwise.
          If FACT = 'N', then
             LDWORK  = MAX(1, 5*N, 2*N*N),        if JOB = 'C';
             LDWORK  = MAX(1, LWA + 5*N, 4*N*N ), if JOB = 'E', 'B'.
          If FACT = 'F', then
             LDWORK  = MAX(1, 2*N*N),  if JOB = 'C';
             LDWORK  = MAX(1, 4*N*N ), if JOB = 'E' or 'B'.
          For good performance, LDWORK must generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, i <= N, the QR algorithm failed to
                complete the reduction of the matrix Ac to Schur
                canonical form (see LAPACK Library routine DGEES);
                on exit, the matrix T(i+1:N,i+1:N) contains the
                partially converged Schur form, and DWORK(i+1:N) and
                DWORK(N+i+1:2*N) contain the real and imaginary
                parts, respectively, of the converged eigenvalues;
                this error is unlikely to appear;
          = N+1:  if the matrices T and -T' have common or very
                close eigenvalues; perturbed values were used to
                solve Lyapunov equations, but the matrix T, if given
                (for FACT = 'F'), is unchanged.
Method 
  The condition number of the Riccati equation is estimated as

  cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) +
              norm(Pi)*norm(G) ) / norm(X),

  where Omega, Theta and Pi are linear operators defined by

  Omega(W) = op(Ac)'*W + W*op(Ac),
  Theta(W) = inv(Omega(op(W)'*X + X*op(W))),
     Pi(W) = inv(Omega(X*W*X)),

  and Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G (if TRANA = 'T'
  or 'C'). Note that the Riccati equation (1) is equivalent to
             _   _         _   _ _ _
      op(T)'*X + X*op(T) + Q + X*G*X = 0,                        (2)
        _           _               _
  where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the
  orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U.

  The routine estimates the quantities

  sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)),

  norm(Theta) and norm(Pi) using 1-norm condition estimator.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [2].
References 
  [1] Ghavimi, A.R. and Laub, A.J.
      Backward error, sensitivity, and refinement of computed
      solutions of algebraic Riccati equations.
      Numerical Linear Algebra with Applications, vol. 2, pp. 29-49,
      1995.

  [2] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.

  [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
      DGRSVX and DMSRIC: Fortran 77 subroutines for solving
      continuous-time matrix algebraic Riccati equations with
      condition and accuracy estimates.
      Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
      Chemnitz, May 1998.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
  The accuracy of the estimates obtained depends on the solution
  accuracy and on the properties of the 1-norm estimator.
Further Comments 
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
  When SEP is computed and it is zero, the routine returns
  immediately, with RCOND and FERR (if requested) set to 0 and 1,
  respectively. In this case, the equation is singular.
Example

Program Text 

*     SB02QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 8*NMAX*NMAX + 10*NMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCND, RCOND, SEP
      INTEGER          I, INFO1, INFO2, INFO3, IS, IU, IW, J, N, N2,
     $                 SDIM
      CHARACTER*1      FACT, JOB, JOBS, LYAPUN, TRANA, TRANAT, UPLO
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX),
     $                 Q(LDQ,NMAX), T(LDT,NMAX), U(LDU,NMAX),
     $                 X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME, SELECT
      EXTERNAL         LSAME, SELECT
*     .. External Subroutines ..
      EXTERNAL         DGEES, DLACPY, DSYMM, MA02ED, MB01RU, SB02MD,
     $                 SB02QD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( UPLO, N, N, Q, LDQ, X, LDX )
         N2 = 2*N
         IS = 2*N2 + 1
         IU = IS + N2*N2
         IW = IU + N2*N2
*        Solve the continuous-time Riccati equation.
         CALL SB02MD( 'continuous', 'direct', UPLO, 'no scaling',
     $                'stable', N, A, LDA, G, LDG, X, LDX, RCND,
     $                DWORK(1), DWORK(N2+1), DWORK(IS), N2, DWORK(IU),
     $                N2, IWORK, DWORK(IW), LDWORK-IW+1, BWORK, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99995 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N )
   10       CONTINUE
            IF ( LSAME( FACT, 'F' ) .OR. LSAME( LYAPUN, 'R' ) ) THEN
               CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
               IF ( LSAME( TRANA, 'N' ) ) THEN
*                 Compute Ac = A-G*X.
                  CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX,
     $                        ONE, T, LDT )
               ELSE
*                 Compute Ac = A-X*G.
                  CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX,
     $                        ONE, T, LDT )
               END IF
*              Compute the Schur factorization of Ac.
               JOBS = 'V'
               CALL DGEES( JOBS, 'Not ordered', SELECT, N, T, LDT, SDIM,
     $                     DWORK(1), DWORK(N+1), U, LDU, DWORK(2*N+1),
     $                     LDWORK-2*N, BWORK, INFO3 )
               IF( INFO3.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99996 ) INFO3
                  STOP
               END IF
            END IF
*
            IF ( LSAME( LYAPUN, 'R' ) ) THEN
               IF( LSAME( TRANA, 'N' )  ) THEN
                  TRANAT = 'T'
               ELSE
                  TRANAT = 'N'
               END IF
*
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX,
     $                      U, LDU, X, LDX, DWORK, N*N, INFO2 )
               CALL MA02ED( UPLO, N, X, LDX )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG,
     $                      U, LDU, G, LDG, DWORK, N*N, INFO2 )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ,
     $                      U, LDU, Q, LDQ, DWORK, N*N, INFO2 )
            END IF
*           Estimate the condition and error bound on the solution.
            CALL 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, INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            END IF
            IF ( INFO2.EQ.0 .OR. INFO2.EQ.N+1 ) THEN
               WRITE ( NOUT, FMT = 99992 ) SEP
               WRITE ( NOUT, FMT = 99991 ) RCOND
               WRITE ( NOUT, FMT = 99990 ) FERR
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02MD =',I2)
99997 FORMAT (' INFO on exit from SB02QD =',I2)
99996 FORMAT (' INFO on exit from DGEES  =',I2)
99995 FORMAT (' The solution matrix X is')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END
Program Data 
 SB02QD EXAMPLE PROGRAM DATA
   2     B     N     N     U     O
   0.0   1.0
   0.0   0.0
   1.0   0.0
   0.0   2.0
   0.0   0.0
   0.0   1.0
Program Results 
 SB02QD EXAMPLE PROGRAM RESULTS

 The solution matrix X is
   2.0000   1.0000
   1.0000   2.0000

 Estimated separation =   0.4000

 Estimated reciprocal condition number =   0.1333

 Estimated error bound =   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02RD.html000077500000000000000000000723601201767322700161100ustar00rootroot00000000000000 SB02RD - SLICOT Library Routine Documentation

SB02RD

Solution of continuous- or discrete-time algebraic Riccati equations (increased accuracy Schur vectors method) with condition and forward error bound estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the continuous-time algebraic Riccati
  equation
                                       -1
     Q + op(A)'*X + X*op(A) - X*op(B)*R  op(B)'*X = 0,           (1)

  or the discrete-time algebraic Riccati equation
                                                             -1
     X = op(A)'*X*op(A) - op(A)'*X*op(B)*(R + op(B)'*X*op(B))  *
                          op(B)'*X*op(A) + Q,                    (2)

  where op(M) = M or M' (M**T), A, op(B), Q, and R are N-by-N,
  N-by-M, N-by-N, and M-by-M matrices respectively, with Q symmetric
  and R symmetric nonsingular; X is an N-by-N symmetric matrix.
                        -1
  The matrix G = op(B)*R  *op(B)' must be provided on input, instead
  of B and R, that is, the continuous-time equation

     Q + op(A)'*X + X*op(A) - X*G*X = 0,                         (3)

  or the discrete-time equation
                             -1
     Q + op(A)'*X*(I_n + G*X)  *op(A) - X = 0,                   (4)

  are solved, where G is an N-by-N symmetric matrix. SLICOT Library
  routine SB02MT should be used to compute G, given B and R. SB02MT
  also enables to solve Riccati equations corresponding to optimal
  problems with coupling terms.

  The routine also returns the computed values of the closed-loop
  spectrum of the optimal system, i.e., the stable eigenvalues
  lambda(1),...,lambda(N) of the corresponding Hamiltonian or
  symplectic matrix associated to the optimal problem. It is assumed
  that the matrices A, G, and Q are such that the associated
  Hamiltonian or symplectic matrix has N stable eigenvalues, i.e.,
  with negative real parts, in the continuous-time case, and with
  moduli less than one, in the discrete-time case.

  Optionally, estimates of the conditioning and error bound on the
  solution of the Riccati equation (3) or (4) are returned.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'X':  Compute the solution only;
          = 'C':  Compute the reciprocal condition number only;
          = 'E':  Compute the error bound only;
          = 'A':  Compute all: the solution, reciprocal condition
                  number, and the error bound.

  DICO    CHARACTER*1
          Specifies the type of Riccati equation to be solved or
          analyzed, as follows:
          = 'C':  Equation (3), continuous-time case;
          = 'D':  Equation (4), discrete-time case.

  HINV    CHARACTER*1
          If DICO = 'D' and JOB = 'X' or JOB = 'A', specifies which
          symplectic matrix is to be constructed, as follows:
          = 'D':  The matrix H in (6) (see METHOD) is constructed;
          = 'I':  The inverse of the matrix H in (6) is constructed.
          HINV is not used if DICO = 'C', or JOB = 'C' or 'E'.

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which triangle of the matrices G and Q is
          stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.

  SCAL    CHARACTER*1
          If JOB = 'X' or JOB = 'A', specifies whether or not a
          scaling strategy should be used, as follows:
          = 'G':  General scaling should be used;
          = 'N':  No scaling should be used.
          SCAL is not used if JOB = 'C' or 'E'.

  SORT    CHARACTER*1
          If JOB = 'X' or JOB = 'A', specifies which eigenvalues
          should be obtained in the top of the Schur form, as
          follows:
          = 'S':  Stable   eigenvalues come first;
          = 'U':  Unstable eigenvalues come first.
          SORT is not used if JOB = 'C' or 'E'.

  FACT    CHARACTER*1
          If JOB <> 'X', specifies whether or not a real Schur
          factorization of the closed-loop system matrix Ac is
          supplied on entry, as follows:
          = 'F':  On entry, T and V contain the factors from a real
                  Schur factorization of the matrix Ac;
          = 'N':  A Schur factorization of Ac will be computed
                  and the factors will be stored in T and V.
          For a continuous-time system, the matrix Ac is given by
             Ac = A - G*X, if TRANA = 'N', or
             Ac = A - X*G, if TRANA = 'T' or 'C',
          and for a discrete-time system, the matrix Ac is given by
             Ac = inv(I_n + G*X)*A, if TRANA = 'N', or
             Ac = A*inv(I_n + X*G), if TRANA = 'T' or 'C'.
          FACT is not used if JOB = 'X'.

  LYAPUN  CHARACTER*1
          If JOB <> 'X', specifies whether or not the original or
          "reduced" Lyapunov equations should be solved for
          estimating reciprocal condition number and/or the error
          bound, as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix V, e.g., X <-- V'*X*V;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
                  This means that a real Schur form T of Ac appears
                  in the equations, instead of Ac.
          LYAPUN is not used if JOB = 'X'.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, Q, G, and X.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If JOB = 'X' or JOB = 'A' or FACT = 'N' or LYAPUN = 'O',
          the leading N-by-N part of this array must contain the
          coefficient matrix A of the equation.
          If JOB = 'C' or 'E' and FACT = 'F' and LYAPUN = 'R', A is
          not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N), if JOB  = 'X' or JOB = 'A' or
                              FACT = 'N' or LYAPUN = 'O'.
          LDA >= 1,        otherwise.

  T       (input or output) DOUBLE PRECISION array, dimension
          (LDT,N)
          If JOB <> 'X' and FACT = 'F', then T is an input argument
          and on entry, the leading N-by-N upper Hessenberg part of
          this array must contain the upper quasi-triangular matrix
          T in Schur canonical form from a Schur factorization of Ac
          (see argument FACT).
          If JOB <> 'X' and FACT = 'N', then T is an output argument
          and on exit, if INFO = 0 or INFO = 7, the leading N-by-N
          upper Hessenberg part of this array contains the upper
          quasi-triangular matrix T in Schur canonical form from a
          Schur factorization of Ac (see argument FACT).
          If JOB = 'X', the array T is not referenced.

  LDT     INTEGER
          The leading dimension of the array T.
          LDT >= 1,        if JOB =  'X';
          LDT >= MAX(1,N), if JOB <> 'X'.

  V       (input or output) DOUBLE PRECISION array, dimension
          (LDV,N)
          If JOB <> 'X' and FACT = 'F', then V is an input argument
          and on entry, the leading N-by-N part of this array must
          contain the orthogonal matrix V from a real Schur
          factorization of Ac (see argument FACT).
          If JOB <> 'X' and FACT = 'N', then V is an output argument
          and on exit, if INFO = 0 or INFO = 7, the leading N-by-N
          part of this array contains the orthogonal N-by-N matrix
          from a real Schur factorization of Ac (see argument FACT).
          If JOB = 'X', the array V is not referenced.

  LDV     INTEGER
          The leading dimension of the array V.
          LDV >= 1,        if JOB =  'X';
          LDV >= MAX(1,N), if JOB <> 'X'.

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, the leading N-by-N upper triangular part (if
          UPLO = 'U') or lower triangular part (if UPLO = 'L') of
          this array must contain the upper triangular part or lower
          triangular part, respectively, of the symmetric matrix G.
          On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and
          LYAPUN = 'R', the leading N-by-N part of this array
          contains the symmetric matrix G fully stored.
          If JOB <> 'X' and LYAPUN = 'R', this array is modified
          internally, but restored on exit.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, the leading N-by-N upper triangular part (if
          UPLO = 'U') or lower triangular part (if UPLO = 'L') of
          this array must contain the upper triangular part or lower
          triangular part, respectively, of the symmetric matrix Q.
          On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and
          LYAPUN = 'R', the leading N-by-N part of this array
          contains the symmetric matrix Q fully stored.
          If JOB <> 'X' and LYAPUN = 'R', this array is modified
          internally, but restored on exit.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= MAX(1,N).

  X       (input or output) DOUBLE PRECISION array, dimension
          (LDX,N)
          If JOB = 'C' or JOB = 'E', then X is an input argument
          and on entry, the leading N-by-N part of this array must
          contain the symmetric solution matrix of the algebraic
          Riccati equation. If LYAPUN = 'R', this array is modified
          internally, but restored on exit; however, it could differ
          from the input matrix at the round-off error level.
          If JOB = 'X' or JOB = 'A', then X is an output argument
          and on exit, if INFO = 0 or INFO >= 6, the leading N-by-N
          part of this array contains the symmetric solution matrix
          X of the algebraic Riccati equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= MAX(1,N).

  SEP     (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, the
          estimated quantity
             sep(op(Ac),-op(Ac)'), if DICO = 'C', or
             sepd(op(Ac),op(Ac)'), if DICO = 'D'. (See METHOD.)
          If JOB = 'C' or JOB = 'A' and X = 0, or JOB = 'E', SEP is
          not referenced.
          If JOB = 'X', and INFO = 0, INFO = 5 or INFO = 7,
          SEP contains the scaling factor used, which should
          multiply the (2,1) submatrix of U to recover X from the
          first N columns of U (see METHOD). If SCAL = 'N', SEP is
          set to 1.

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, an
          estimate of the reciprocal condition number of the
          algebraic Riccati equation.
          If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
          If JOB = 'X', or JOB = 'E', RCOND is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = 7, an
          estimated forward error bound for the solution X. If XTRUE
          is the true solution, FERR bounds the magnitude of the
          largest entry in (X - XTRUE) divided by the magnitude of
          the largest entry in X.
          If N = 0 or X = 0, FERR is set to 0.
          If JOB = 'X', or JOB = 'C', FERR is not referenced.

  WR      (output) DOUBLE PRECISION array, dimension (2*N)
  WI      (output) DOUBLE PRECISION array, dimension (2*N)
          If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5,
          these arrays contain the real and imaginary parts,
          respectively, of the eigenvalues of the 2N-by-2N matrix S,
          ordered as specified by SORT (except for the case
          HINV = 'D', when the order is opposite to that specified
          by SORT). The leading N elements of these arrays contain
          the closed-loop spectrum of the system matrix Ac (see
          argument FACT). Specifically,
             lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N.
          If JOB = 'C' or JOB = 'E', these arrays are not
          referenced.

  S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
          If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, the
          leading 2N-by-2N part of this array contains the ordered
          real Schur form S of the (scaled, if SCAL = 'G')
          Hamiltonian or symplectic matrix H. That is,

                 ( S    S   )
                 (  11   12 )
             S = (          ),
                 ( 0    S   )
                 (       22 )

          where S  , S   and S   are N-by-N matrices.
                 11   12      22
          If JOB = 'C' or JOB = 'E', this array is not referenced.

  LDS     INTEGER
          The leading dimension of the array S.
          LDS >= MAX(1,2*N), if JOB = 'X' or JOB = 'A';
          LDS >= 1,          if JOB = 'C' or JOB = 'E'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= 2*N,          if JOB = 'X';
          LIWORK >= N*N,          if JOB = 'C' or JOB = 'E';
          LIWORK >= MAX(2*N,N*N), if JOB = 'A'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, or INFO = 7, DWORK(1) returns the
          optimal value of LDWORK. If INFO = 0, or INFO >= 5, and
          JOB = 'X', or JOB = 'A', then DWORK(2) returns an estimate
          RCONDU of the reciprocal of the condition number (in the
          1-norm) of the N-th order system of algebraic equations
          from which the solution matrix X is obtained, and DWORK(3)
          returns the reciprocal pivot growth factor for the LU
          factorization of the coefficient matrix of that system
          (see SLICOT Library routine MB02PD); if DWORK(3) is much
          less than 1, then the computed X and RCONDU could be
          unreliable.
          If DICO = 'D', and JOB = 'X', or JOB = 'A', then DWORK(4)
          returns the reciprocal condition number RCONDA of the
          given matrix A, and DWORK(5) returns the reciprocal pivot
          growth factor for A or for its leading columns, if A is
          singular (see SLICOT Library routine MB02PD); if DWORK(5)
          is much less than 1, then the computed S and RCONDA could
          be unreliable.
          On exit, if INFO = 0, or INFO >= 4, and JOB = 'X', the
          elements DWORK(6:5+4*N*N) contain the 2*N-by-2*N
          transformation matrix  U  which reduced the Hamiltonian or
          symplectic matrix  H  to the ordered real Schur form  S.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 5+MAX(1,4*N*N+8*N), if JOB = 'X' or JOB = 'A';
          This may also be used for JOB = 'C' or JOB = 'E', but
          exact bounds are as follows:
          LDWORK >= 5 + MAX(1,LWS,LWE) + LWN, where
          LWS = 0,       if FACT = 'F' or  LYAPUN = 'R';
              = 5*N,     if FACT = 'N' and LYAPUN = 'O' and
                                           DICO = 'C' and JOB = 'C';
              = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and
                                           DICO = 'C' and JOB = 'E';
              = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and
                                           DICO = 'D';
          LWE = 2*N*N,                if DICO = 'C' and JOB = 'C';
              = 4*N*N,                if DICO = 'C' and JOB = 'E';
              = MAX(3,2*N*N) + N*N,   if DICO = 'D' and JOB = 'C';
              = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and JOB = 'E';
          LWN = 0,   if LYAPUN = 'O' or   JOB = 'C';
              = 2*N, if LYAPUN = 'R' and DICO = 'C' and JOB = 'E';
              = 3*N, if LYAPUN = 'R' and DICO = 'D' and JOB = 'E'.
          For optimum performance LDWORK should sometimes be larger.

  BWORK   LOGICAL array, dimension (LBWORK)
          LBWORK >= 2*N,          if JOB = 'X' or JOB = 'A';
          LBWORK >= 1,            if JOB = 'C' or JOB = 'E', and
                                  FACT = 'N' and LYAPUN = 'R';
          LBWORK >= 0,            otherwise.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if matrix A is (numerically) singular in discrete-
                time case;
          = 2:  if the Hamiltonian or symplectic matrix H cannot be
                reduced to real Schur form;
          = 3:  if the real Schur form of the Hamiltonian or
                symplectic matrix H cannot be appropriately ordered;
          = 4:  if the Hamiltonian or symplectic matrix H has less
                than N stable eigenvalues;
          = 5:  if the N-th order system of linear algebraic
                equations, from which the solution matrix X would
                be obtained, is singular to working precision;
          = 6:  if the QR algorithm failed to complete the reduction
                of the matrix Ac to Schur canonical form, T;
          = 7:  if T and -T' have some almost equal eigenvalues, if
                DICO = 'C', or T has almost reciprocal eigenvalues,
                if DICO = 'D'; perturbed values were used to solve
                Lyapunov equations, but the matrix T, if given (for
                FACT = 'F'), is unchanged. (This is a warning
                indicator.)
Method 
  The method used is the Schur vector approach proposed by Laub [1],
  but with an optional scaling, which enhances the numerical
  stability [6]. It is assumed that [A,B] is a stabilizable pair
  (where for (3) or (4), B is any matrix such that B*B' = G with
  rank(B) = rank(G)), and [E,A] is a detectable pair, where E is any
  matrix such that E*E' = Q with rank(E) = rank(Q). Under these
  assumptions, any of the algebraic Riccati equations (1)-(4) is
  known to have a unique non-negative definite solution. See [2].
  Now consider the 2N-by-2N Hamiltonian or symplectic matrix

              ( op(A)   -G    )
         H =  (               ),                                 (5)
              (  -Q   -op(A)' ),

  for continuous-time equation, and
                      -1              -1
              (  op(A)           op(A)  *G       )
         H =  (        -1                   -1   ),              (6)
              ( Q*op(A)     op(A)' + Q*op(A)  *G )

  for discrete-time equation, respectively, where
                    -1
         G = op(B)*R  *op(B)'.
  The assumptions guarantee that H in (5) has no pure imaginary
  eigenvalues, and H in (6) has no eigenvalues on the unit circle.
  If Y is an N-by-N matrix then there exists an orthogonal matrix U
  such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U
  can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks
  (corresponding to the complex conjugate eigenvalues and real
  eigenvalues respectively) appear in any desired order. This is the
  ordered real Schur form. Thus, we can find an orthogonal
  similarity transformation U which puts (5) or (6) in ordered real
  Schur form

         U'*H*U = S = (S(1,1)  S(1,2))
                      (  0     S(2,2))

  where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1)
  have negative real parts in case of (5), or moduli greater than
  one in case of (6). If U is conformably partitioned into four
  N-by-N blocks

            U = (U(1,1)  U(1,2))
                (U(2,1)  U(2,2))

  with respect to the assumptions we then have
  (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1),
      (2), (3), or (4) with X = X' and non-negative definite;
  (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if
      DICO = 'D') are equal to the eigenvalues of optimal system
      (the 'closed-loop' spectrum).

  [A,B] is stabilizable if there exists a matrix F such that (A-BF)
  is stable. [E,A] is detectable if [A',E'] is stabilizable.

  The condition number of a Riccati equation is estimated as

  cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) +
              norm(Pi)*norm(G) ) / norm(X),

  where Omega, Theta and Pi are linear operators defined by

  Omega(W) = op(Ac)'*W + W*op(Ac),
  Theta(W) = inv(Omega(op(W)'*X + X*op(W))),
     Pi(W) = inv(Omega(X*W*X)),

  in the continuous-time case, and

  Omega(W) = op(Ac)'*W*op(Ac) - W,
  Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))),
     Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))),

  in the discrete-time case, and Ac has been defined (see argument
  FACT). Details are given in the comments of SLICOT Library
  routines SB02QD and SB02SD.

  The routine estimates the quantities

  sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)),
  sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)),

  norm(Theta) and norm(Pi) using 1-norm condition estimator.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [5].
References 
  [1] Laub, A.J.
      A Schur Method for Solving Algebraic Riccati equations.
      IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979.

  [2] Wonham, W.M.
      On a matrix Riccati equation of stochastic control.
      SIAM J. Contr., 6, pp. 681-697, 1968.

  [3] Sima, V.
      Algorithms for Linear-Quadratic Optimization.
      Pure and Applied Mathematics: A Series of Monographs and
      Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996.

  [4] Ghavimi, A.R. and Laub, A.J.
      Backward error, sensitivity, and refinement of computed
      solutions of algebraic Riccati equations.
      Numerical Linear Algebra with Applications, vol. 2, pp. 29-49,
      1995.

  [5] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.

  [6] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
      DGRSVX and DMSRIC: Fortran 77 subroutines for solving
      continuous-time matrix algebraic Riccati equations with
      condition and accuracy estimates.
      Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
      Chemnitz, May 1998.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations. The solution accuracy
  can be controlled by the output parameter FERR.
Further Comments 
  To obtain a stabilizing solution of the algebraic Riccati
  equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set
  SORT = 'S', if HINV = 'I'.

  The routine can also compute the anti-stabilizing solutions of
  the algebraic Riccati equations, by specifying
      SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or
      SORT = 'S' if DICO = 'D' and HINV = 'D'.

  Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I'
  and SORT = 'U', for stabilizing and anti-stabilizing solutions,
  respectively, will be faster then the other combinations [3].

  The option LYAPUN = 'R' may produce slightly worse or better
  estimates, and it is faster than the option 'O'.

  This routine is a functionally extended and more accurate
  version of the SLICOT Library routine SB02MD. Transposed problems
  can be dealt with as well. Iterative refinement is used whenever
  useful to solve linear algebraic systems. Condition numbers and
  error bounds on the solutions are optionally provided.
Example

Program Text 

*     SB02RD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDS, LDT, LDV, LDX
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX,
     $                   LDS = 2*NMAX, LDT = NMAX, LDV = NMAX,
     $                   LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX, NMAX*NMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 5 + 4*NMAX*NMAX + 8*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SEP
      INTEGER          I, INFO, J, N
      CHARACTER        DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, TRANA,
     $                 UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX),
     $                 Q(LDQ,NMAX), S(LDS,2*NMAX), T(LDT,NMAX),
     $                 V(LDV,NMAX), WI(2*NMAX), WR(2*NMAX), X(LDX,NMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB02RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT,
     $                      FACT, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) .OR.
     $        LSAME( FACT, 'N' ) .OR. LSAME( LYAPUN, 'O' ) )
     $      READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( .NOT.LSAME( JOB, 'X' ) .AND. LSAME( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N )
         END IF
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $      READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X.
         CALL 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 )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         END IF
         IF ( INFO.EQ.0 .OR. INFO.EQ.7 ) THEN
            IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N )
   20          CONTINUE
            END IF
            IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99994 ) SEP
               WRITE ( NOUT, FMT = 99993 ) RCOND
            END IF
            IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99992 ) FERR
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02RD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' Estimated separation = ',F8.4)
99993 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99992 FORMAT (/' Estimated error bound = ',F8.4)
      END
Program Data 
 SB02RD EXAMPLE PROGRAM DATA
   2     A     C     D     N     U     N     S     N     O
   0.0   1.0
   0.0   0.0
   1.0   0.0
   0.0   2.0
   0.0   0.0
   0.0   1.0
Program Results 
 SB02RD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   2.0000   1.0000
   1.0000   2.0000

 Estimated separation =   0.4000

 Estimated reciprocal condition number =   0.1333

 Estimated error bound =   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB02RU.html000077500000000000000000000172641201767322700161330ustar00rootroot00000000000000 SB02RU - SLICOT Library Routine Documentation

SB02RU

Constructing the 2n-by-2n Hamiltonian or symplectic matrix for linear-quadratic optimization problems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the 2n-by-2n Hamiltonian or symplectic matrix S
  associated to the linear-quadratic optimization problem, used to
  solve the continuous- or discrete-time algebraic Riccati equation,
  respectively.

  For a continuous-time problem, S is defined by

          ( op(A)   -G    )
      S = (               ),                                     (1)
          (  -Q   -op(A)' )

  and for a discrete-time problem by

                  -1              -1
          (  op(A)           op(A)  *G       )
      S = (        -1                   -1   ),                  (2)
          ( Q*op(A)     op(A)' + Q*op(A)  *G )

  or
                           -T             -T
          ( op(A) + G*op(A)  *Q   -G*op(A)   )
      S = (           -T                 -T  ),                  (3)
          (     -op(A)  *Q          op(A)    )

  where op(A) = A or A' (A**T), A, G, and Q are n-by-n matrices,
  with G and Q symmetric. Matrix A must be nonsingular in the
  discrete-time case.
Specification 
      SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q,
     $                   LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system as follows:
          = 'C':  Continuous-time system;
          = 'D':  Discrete-time system.

  HINV    CHARACTER*1
          If DICO = 'D', specifies which of the matrices (2) or (3)
          is constructed, as follows:
          = 'D':  The matrix S in (2) is constructed;
          = 'I':  The (inverse) matrix S in (3) is constructed.
          HINV is not referenced if DICO = 'C'.

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which triangle of the matrices G and Q is
          stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, G, and Q.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
          On entry, the leading N-by-N upper triangular part (if
          UPLO = 'U') or lower triangular part (if UPLO = 'L') of
          this array must contain the upper triangular part or lower
          triangular part, respectively, of the symmetric matrix G.
          On exit, if DICO = 'D', the leading N-by-N part of this
          array contains the symmetric matrix G fully stored.
          If DICO = 'C', this array is not modified on exit, and the
          strictly lower triangular part (if UPLO = 'U') or strictly
          upper triangular part (if UPLO = 'L') is not referenced.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, the leading N-by-N upper triangular part (if
          UPLO = 'U') or lower triangular part (if UPLO = 'L') of
          this array must contain the upper triangular part or lower
          triangular part, respectively, of the symmetric matrix Q.
          On exit, if DICO = 'D', the leading N-by-N part of this
          array contains the symmetric matrix Q fully stored.
          If DICO = 'C', this array is not modified on exit, and the
          strictly lower triangular part (if UPLO = 'U') or strictly
          upper triangular part (if UPLO = 'L') is not referenced.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= MAX(1,N).

  S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
          If INFO = 0, the leading 2N-by-2N part of this array
          contains the Hamiltonian or symplectic matrix of the
          problem.

  LDS     INTEGER
          The leading dimension of the array S.  LDS >= MAX(1,2*N).
Workspace 
  IWORK   INTEGER array, dimension (LIWORK), where
          LIWORK >= 0,   if DICO = 'C';
          LIWORK >= 2*N, if DICO = 'D'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if DICO = 'D', DWORK(1) returns the reciprocal
          condition number  RCOND  of the given matrix  A,  and
          DWORK(2) returns the reciprocal pivot growth factor
          norm(A)/norm(U) (see SLICOT Library routine MB02PD).
          If DWORK(2) is much less than 1, then the computed  S
          and  RCOND  could be unreliable. If 0 < INFO <= N, then
          DWORK(2) contains the reciprocal pivot growth factor for
          the leading INFO columns of  A.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 0,          if DICO = 'C';
          LDWORK >= MAX(2,6*N), if DICO = 'D'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = i:  if the leading i-by-i (1 <= i <= N) upper triangular
                submatrix of A is singular in discrete-time case;
          = N+1:  if matrix A is numerically singular in discrete-
                time case.
Method 
  For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1)
  is constructed.
  For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or
  (3) - the inverse of the matrix in (2) - is constructed.
Numerical Aspects 
  The discrete-time case needs the inverse of the matrix A, hence
  the routine should not be used when A is ill-conditioned.
                            3
  The algorithm requires 0(n ) floating point operations in the
  discrete-time case.
Further Comments 
  This routine is a functionally extended and with improved accuracy
  version of the SLICOT Library routine SB02MU. Transposed problems
  can be dealt with as well. The LU factorization of  op(A)  (with
  no equilibration) and iterative refinement are used for solving
  the various linear algebraic systems involved.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB02SD.html000077500000000000000000000472121201767322700161070ustar00rootroot00000000000000 SB02SD - SLICOT Library Routine Documentation

SB02SD

Estimating conditioning and forward error bound for the solution of discrete-time Riccati equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the conditioning and compute an error bound on the
  solution of the real discrete-time matrix algebraic Riccati
  equation (see FURTHER COMMENTS)
                              -1
      X = op(A)'*X*(I_n + G*X)  *op(A) + Q,                      (1)

  where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T,
  G = G**T). The matrices A, Q and G are N-by-N and the solution X
  is N-by-N.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SEPD
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ),  G( LDG, * ),
     $                   Q( LDQ, * ), T( LDT, * ), U( LDU, * ),
     $                   X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'C':  Compute the reciprocal condition number only;
          = 'E':  Compute the error bound only;
          = 'B':  Compute both the reciprocal condition number and
                  the error bound.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization of
          the matrix Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or
          Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'), is supplied
          on entry, as follows:
          = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
                  factors from the real Schur factorization of the
                  matrix Ac;
          = 'N':  The Schur factorization of Ac will be computed
                  and the factors will be stored in T and U (if
                  LYAPUN = 'O').

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrices Q and G is
          to be used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved in the iterative estimation process,
          as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., RHS <-- U'*RHS*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, Q, and G.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of
          this array must contain the matrix A.
          If FACT = 'F' and LYAPUN = 'R', A is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= max(1,N), if FACT = 'N' or  LYAPUN = 'O';
          LDA >= 1,        if FACT = 'F' and LYAPUN = 'R'.

  T       (input or output) DOUBLE PRECISION array, dimension
          (LDT,N)
          If FACT = 'F', then T is an input argument and on entry,
          the leading N-by-N upper Hessenberg part of this array
          must contain the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of Ac (see
          argument FACT).
          If FACT = 'N', then T is an output argument and on exit,
          if INFO = 0 or INFO = N+1, the leading N-by-N upper
          Hessenberg part of this array contains the upper quasi-
          triangular matrix T in Schur canonical form from a Schur
          factorization of Ac (see argument FACT).

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= max(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If LYAPUN = 'O' and FACT = 'F', then U is an input
          argument and on entry, the leading N-by-N part of this
          array must contain the orthogonal matrix U from a real
          Schur factorization of Ac (see argument FACT).
          If LYAPUN = 'O' and FACT = 'N', then U is an output
          argument and on exit, if INFO = 0 or INFO = N+1, it
          contains the orthogonal N-by-N matrix from a real Schur
          factorization of Ac (see argument FACT).
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  G       (input) DOUBLE PRECISION array, dimension (LDG,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix G.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix G.                     _
          Matrix G should correspond to G in the "reduced" Riccati
          equation (with matrix T, instead of A), if LYAPUN = 'R'.
          See METHOD.

  LDG     INTEGER
          The leading dimension of the array G.  LDG >= max(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix Q.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix Q.                     _
          Matrix Q should correspond to Q in the "reduced" Riccati
          equation (with matrix T, instead of A), if LYAPUN = 'R'.
          See METHOD.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= max(1,N).

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array must contain the
          symmetric solution matrix of the original Riccati
          equation (with matrix A), if LYAPUN = 'O', or of the
          "reduced" Riccati equation (with matrix T), if
          LYAPUN = 'R'. See METHOD.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  SEPD    (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', the estimated quantity
          sepd(op(Ac),op(Ac)').
          If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced.

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', an estimate of the reciprocal
          condition number of the discrete-time Riccati equation.
          If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
          If JOB = 'E', RCOND is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'E' or JOB = 'B', an estimated forward error
          bound for the solution X. If XTRUE is the true solution,
          FERR bounds the magnitude of the largest entry in
          (X - XTRUE) divided by the magnitude of the largest entry
          in X.
          If N = 0 or X = 0, FERR is set to 0.
          If JOB = 'C', FERR is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          Let LWA = N*N, if LYAPUN = 'O';
              LWA = 0,   otherwise,
          and LWN = N,   if LYAPUN = 'R' and JOB = 'E' or 'B';
              LWN = 0,   otherwise.
          If FACT = 'N', then
             LDWORK  = MAX(LWA + 5*N, MAX(3,2*N*N) + N*N),
                                              if JOB = 'C';
             LDWORK  = MAX(LWA + 5*N, MAX(3,2*N*N) + 2*N*N + LWN),
                                              if JOB = 'E' or 'B'.
          If FACT = 'F', then
             LDWORK  = MAX(3,2*N*N) + N*N,    if JOB = 'C';
             LDWORK  = MAX(3,2*N*N) + 2*N*N + LWN,
                                              if JOB = 'E' or 'B'.
          For good performance, LDWORK must generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, i <= N, the QR algorithm failed to
                complete the reduction of the matrix Ac to Schur
                canonical form (see LAPACK Library routine DGEES);
                on exit, the matrix T(i+1:N,i+1:N) contains the
                partially converged Schur form, and DWORK(i+1:N) and
                DWORK(N+i+1:2*N) contain the real and imaginary
                parts, respectively, of the converged eigenvalues;
                this error is unlikely to appear;
          = N+1:  if T has almost reciprocal eigenvalues; perturbed
                values were used to solve Lyapunov equations, but
                the matrix T, if given (for FACT = 'F'), is
                unchanged.
Method 
  The condition number of the Riccati equation is estimated as

  cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) +
              norm(Pi)*norm(G) ) / norm(X),

  where Omega, Theta and Pi are linear operators defined by

  Omega(W) = op(Ac)'*W*op(Ac) - W,
  Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))),
     Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))),

  and Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or
      Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C').

  Note that the Riccati equation (1) is equivalent to

      X = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q,           (2)

  and to
      _          _                _ _ _         _
      X = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q,               (3)
        _           _               _
  where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the
  orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U.

  The routine estimates the quantities

  sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)),

  norm(Theta) and norm(Pi) using 1-norm condition estimator.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [2].
References 
  [1] Ghavimi, A.R. and Laub, A.J.
      Backward error, sensitivity, and refinement of computed
      solutions of algebraic Riccati equations.
      Numerical Linear Algebra with Applications, vol. 2, pp. 29-49,
      1995.

  [2] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.

  [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
      DGRSVX and DMSRIC: Fortran 77 subroutines for solving
      continuous-time matrix algebraic Riccati equations with
      condition and accuracy estimates.
      Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
      Chemnitz, May 1998.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
  The accuracy of the estimates obtained depends on the solution
  accuracy and on the properties of the 1-norm estimator.
Further Comments 
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
  When SEPD is computed and it is zero, the routine returns
  immediately, with RCOND and FERR (if requested) set to 0 and 1,
  respectively. In this case, the equation is singular.

  Let B be an N-by-M matrix (if TRANA = 'N') or an M-by-N matrix
  (if TRANA = 'T' or 'C'), let R be an M-by-M symmetric positive
  definite matrix (R = R**T), and denote G = op(B)*inv(R)*op(B)'.
  Then, the Riccati equation (1) is equivalent to the standard
  discrete-time matrix algebraic Riccati equation

      X = op(A)'*X*op(A) -                                       (4)
                                             -1
          op(A)'*X*op(B)*(R + op(B)'*X*op(B))  *op(B)'*X*op(A) + Q.

  By symmetry, the equation (1) is also equivalent to
                            -1
      X = op(A)'*(I_n + X*G)  *X*op(A) + Q.
Example

Program Text 

*     SB02SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 8*NMAX*NMAX + 10*NMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCND, RCOND, SEPD
      INTEGER          I, INFO1, INFO2, INFO3, IS, IU, IW, J, N, N2,
     $                 SDIM
      CHARACTER*1      FACT, JOB, JOBS, LYAPUN, TRANA, TRANAT, UPLO
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AS(LDA,NMAX), DWORK(LDWORK),
     $                 G(LDG,NMAX), Q(LDQ,NMAX), T(LDT,NMAX),
     $                 U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME, SELECT
      EXTERNAL         LSAME, SELECT
*     .. External Subroutines ..
      EXTERNAL         DGEES, DGESV, DLACPY, DLASET, DSWAP, DSYMM,
     $                 MA02AD, MA02ED, MB01RU, SB02MD, SB02SD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'Full', N, N, A, LDA, AS, LDA )
         CALL DLACPY( UPLO, N, N, Q, LDQ, X, LDX )
         N2 = 2*N
         IS = 2*N2 + 1
         IU = IS + N2*N2
         IW = IU + N2*N2
*        Solve the discrete-time Riccati equation.
         CALL SB02MD( 'discrete', 'direct', UPLO, 'no scaling',
     $                'stable', N, AS, LDA, G, LDG, X, LDX, RCND,
     $                DWORK(1), DWORK(N2+1), DWORK(IS), N2, DWORK(IU),
     $                N2, IWORK, DWORK(IW), LDWORK-IW+1, BWORK, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99995 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N )
   10       CONTINUE
            IF ( LSAME( FACT, 'F' ) .OR. LSAME( LYAPUN, 'R' ) ) THEN
               CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK, N )
               CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX,
     $                     ONE, DWORK, N )
               IF ( LSAME( TRANA, 'N' ) ) THEN
*                 Compute Ac = inv(I_n + G*X)*A.
                  CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
                  CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 )
               ELSE
*                 Compute Ac = A*inv(I_n + X*G)
                  CALL MA02AD( 'Full', N, N, A, LDA, T, LDT )
                  CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 )
                  DO 20 J = 2, N
                     CALL DSWAP( J-1, T(1,J), 1, T(J,1), LDT )
   20             CONTINUE
               END IF
*              Compute the Schur factorization of Ac.
               JOBS = 'V'
               CALL DGEES( JOBS, 'Not ordered', SELECT, N, T, LDT, SDIM,
     $                     DWORK(1), DWORK(N+1), U, LDU, DWORK(2*N+1),
     $                     LDWORK-2*N, BWORK, INFO3 )
               IF( INFO3.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99996 ) INFO3
                  STOP
               END IF
            END IF
*
            IF ( LSAME( LYAPUN, 'R' ) ) THEN
               IF( LSAME( TRANA, 'N' )  ) THEN
                  TRANAT = 'T'
               ELSE
                  TRANAT = 'N'
               END IF
*
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX,
     $                      U, LDU, X, LDX, DWORK, N*N, INFO2 )
               CALL MA02ED( UPLO, N, X, LDX )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG,
     $                      U, LDU, G, LDG, DWORK, N*N, INFO2 )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ,
     $                      U, LDU, Q, LDQ, DWORK, N*N, INFO2 )
            END IF
*           Estimate the condition and error bound on the solution.
            CALL 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, INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            END IF
            IF ( INFO2.EQ.0 .OR. INFO2.EQ.N+1 ) THEN
               WRITE ( NOUT, FMT = 99992 ) SEPD
               WRITE ( NOUT, FMT = 99991 ) RCOND
               WRITE ( NOUT, FMT = 99990 ) FERR
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02MD =',I2)
99997 FORMAT (' INFO on exit from SB02SD =',I2)
99996 FORMAT (' INFO on exit from DGEES  =',I2)
99995 FORMAT (' The solution matrix X is')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END
Program Data 
 SB02SD EXAMPLE PROGRAM DATA
   2     B     N     N     U     O
   2.0 -1.0
   1.0  0.0
   0.0  0.0
   0.0  1.0
   1.0  0.0
   0.0  0.0
Program Results 
 SB02SD EXAMPLE PROGRAM RESULTS

 The solution matrix X is
  -0.7691   1.2496
   1.2496  -2.3306

 Estimated separation =   0.4456

 Estimated reciprocal condition number =   0.1445

 Estimated error bound =   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03MD.html000077500000000000000000000407371201767322700161070ustar00rootroot00000000000000 SB03MD - SLICOT Library Routine Documentation

SB03MD

Solution of continuous- or discrete-time Lyapunov equations and separation estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the real continuous-time Lyapunov equation

     op(A)'*X + X*op(A) = scale*C                             (1)

  or the real discrete-time Lyapunov equation

     op(A)'*X*op(A) - X = scale*C                             (2)

  and/or estimate an associated condition number, called separation,
  where op(A) = A or A' (A**T) and C is symmetric (C = C').
  (A' denotes the transpose of the matrix A.) A is N-by-N, the right
  hand side C and the solution X are N-by-N, and scale is an output
  scale factor, set less than or equal to 1 to avoid overflow in X.
Specification 
      SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C,
     $                   LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK,
     $                   LDWORK, INFO )
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( * )
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the equation from which X is to be determined
          as follows:
          = 'C':  Equation (1), continuous-time case;
          = 'D':  Equation (2), discrete-time case.

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'X':  Compute the solution only;
          = 'S':  Compute the separation only;
          = 'B':  Compute both the solution and the separation.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, A and U contain the factors from the
                  real Schur factorization of the matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in A and U.

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, and C.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A. If FACT = 'F', then A contains
          an upper quasi-triangular matrix in Schur canonical form;
          the elements below the upper Hessenberg part of the
          array A are not referenced.
          On exit, if INFO = 0 or INFO = N+1, the leading N-by-N
          upper Hessenberg part of this array contains the upper
          quasi-triangular matrix in Schur canonical form from the
          Schur factorization of A. The contents of array A is not
          modified if FACT = 'F'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If FACT = 'F', then U is an input argument and on entry
          the leading N-by-N part of this array must contain the
          orthogonal matrix U of the real Schur factorization of A.
          If FACT = 'N', then U is an output argument and on exit,
          if INFO = 0 or INFO = N+1, it contains the orthogonal
          N-by-N matrix from the real Schur factorization of A.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry with JOB = 'X' or 'B', the leading N-by-N part of
          this array must contain the symmetric matrix C.
          On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1,
          the leading N-by-N part of C has been overwritten by the
          symmetric solution matrix X.
          If JOB = 'S', C is not referenced.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= 1,        if JOB = 'S';
          LDC >= MAX(1,N), otherwise.

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.

  SEP     (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP
          contains the estimated separation of the matrices op(A)
          and -op(A)', if DICO = 'C' or of op(A) and op(A)', if
          DICO = 'D'.
          If JOB = 'X' or N = 0, SEP is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains an
          estimated forward error bound for the solution X.
          If XTRUE is the true solution, FERR bounds the relative
          error in the computed solution, measured in the Frobenius
          norm:  norm(X - XTRUE)/norm(XTRUE).
          If JOB = 'X' or JOB = 'S', FERR is not referenced.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
          contain the real and imaginary parts, respectively, of
          the eigenvalues of A.
          If FACT = 'F', WR and WI are not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)
          This array is not referenced if JOB = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 1, and
          If JOB = 'X' then
             If FACT = 'F', LDWORK >= N*N,           for DICO = 'C';
                            LDWORK >= MAX(N*N, 2*N), for DICO = 'D';
             If FACT = 'N', LDWORK >= MAX(N*N, 3*N).
          If JOB = 'S' or JOB = 'B' then
             If FACT = 'F', LDWORK >= 2*N*N,       for DICO = 'C';
                            LDWORK >= 2*N*N + 2*N, for DICO = 'D'.
             If FACT = 'N', LDWORK >= MAX(2*N*N, 3*N), DICO = 'C';
                            LDWORK >= 2*N*N + 2*N, for DICO = 'D'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, the QR algorithm failed to compute all
                the eigenvalues (see LAPACK Library routine DGEES);
                elements i+1:n of WR and WI contain eigenvalues
                which have converged, and A contains the partially
                converged Schur form;
          = N+1:  if DICO = 'C', and the matrices A and -A' have
                common or very close eigenvalues, or
                if DICO = 'D', and matrix A has almost reciprocal
                eigenvalues (that is, lambda(i) = 1/lambda(j) for
                some i and j, where lambda(i) and lambda(j) are
                eigenvalues of A and i <> j); perturbed values were
                used to solve the equation (but the matrix A is
                unchanged).
Method 
  The Schur factorization of a square matrix  A  is given by

     A = U*S*U'

  where U is orthogonal and S is block upper triangular with 1-by-1
  and 2-by-2 blocks on its diagonal, these blocks corresponding to
  the eigenvalues of A, the 2-by-2 blocks being complex conjugate
  pairs. This factorization is obtained by numerically stable
  methods: first A is reduced to upper Hessenberg form (if FACT =
  'N') by means of Householder transformations and then the
  QR Algorithm is applied to reduce the Hessenberg form to S, the
  transformation matrices being accumulated at each step to give U.
  If A has already been factorized prior to calling the routine
  however, then the factors U and S may be supplied and the initial
  factorization omitted.
                _            _
  If we now put C = U'CU and X = UXU' equations (1) and (2) (see
  PURPOSE) become (for TRANS = 'N')
       _   _    _
     S'X + XS = C,                                               (3)
  and
       _    _   _
     S'XS - X = C,                                               (4)

  respectively. Partition S, C and X as
                         _   _         _   _
         (s    s')      (c   c')      (x   x')
         ( 11    )  _   ( 11   )  _   ( 11   )
     S = (       ), C = (      ), X = (      )
         (       )      ( _    )      ( _    )
         ( 0   S )      ( c  C )      ( x  X )
                1             1             1
             _      _
  where s  , c  and x  are either scalars or 2-by-2 matrices and s,
         11   11     11
  _     _
  c and x are either (N-1) element vectors or matrices with two
  columns. Equations (3) and (4) can then be re-written as
        _     _        _
     s' x   + x  s   = c                                       (3.1)
      11 11    11 11    11

       _   _           _    _
     S'x + xs        = c - sx                                  (3.2)
      1      11              11

                             _    _
     S'X + X S       = C - (sx' + xs')                         (3.3)
      1 1   1 1         1
  and
        _       _       _
     s' x  s  - x     = c                                      (4.1)
      11 11 11   11      11

       _     _          _    _
     S'xs  - x        = c - sx  s                              (4.2)
      1  11                   11 11

                             _            _        _
     S'X S - X        = C - sx  s' - [s(S'x)' + (S'x)s']       (4.3)
      1 1 1   1          1    11         1        1
                                               _
  respectively. If DICO = 'C' ['D'], then once x   has been
                                                11
  found from equation (3.1) [(4.1)], equation (3.2) [(4.2)] can be
                                     _
  solved by forward substitution for x and then equation (3.3)
  [(4.3)] is of the same form as (3) [(4)] but of the order (N-1) or
  (N-2) depending upon whether s   is 1-by-1 or 2-by-2.
                                11
                          _      _
  When s   is 2-by-2 then x  and c   will be 1-by-2 matrices and s,
        11                 11     11
  _     _
  x and c are matrices with two columns. In this case, equation
  (3.1) [(4.1)] defines the three equations in the unknown elements
     _
  of x   and equation (3.2) [(4.2)] can then be solved by forward
      11                 _
  substitution, a row of x being found at each step.
References 
  [1] Barraud, A.Y.                   T
      A numerical algorithm to solve A XA - X = Q.
      IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977.

  [2] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [3] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-325, 1982.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  If DICO = 'C', SEP is defined as the separation of op(A) and
  -op(A)':

         sep( op(A), -op(A)' ) = sigma_min( T )

  and if DICO = 'D', SEP is defined as

         sep( op(A), op(A)' ) = sigma_min( T )

  where sigma_min(T) is the smallest singular value of the
  N*N-by-N*N matrix

    T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) )  (DICO = 'C'),

    T = kprod( op(A)', op(A)' ) - I(N**2)              (DICO = 'D').

  I(x) is an x-by-x identity matrix, and kprod denotes the Kronecker
  product. The program estimates sigma_min(T) by the reciprocal of
  an estimate of the 1-norm of inverse(T). The true reciprocal
  1-norm of inverse(T) cannot differ from sigma_min(T) by more
  than a factor of N.

  When SEP is small, small changes in A, C can cause large changes
  in the solution of the equation. An approximate bound on the
  maximum relative error in the computed solution is

                   EPS * norm(A) / SEP      (DICO = 'C'),

                   EPS * norm(A)**2 / SEP   (DICO = 'D'),

  where EPS is the machine precision.
Example

Program Text 

*     SB03MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDU
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDU = NMAX )
      INTEGER          LDWORK, LIWORK
      PARAMETER        ( LDWORK = 2*NMAX*NMAX + 3*NMAX,
     $                   LIWORK = NMAX*NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      CHARACTER*1      DICO, FACT, JOB, TRANA
      DOUBLE PRECISION FERR, SCALE, SEP
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 U(LDU,NMAX), WI(NMAX), WR(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB03MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DICO, FACT, JOB, TRANA
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X.
         CALL SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC,
     $                SCALE, SEP, FERR, WR, WI, IWORK, DWORK, LDWORK,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) SCALE
            IF ( .NOT.LSAME( JOB, 'X' ) )
     $         WRITE ( NOUT, FMT = 99993 ) SEP
            IF ( LSAME( JOB, 'B' ) )
     $         WRITE ( NOUT, FMT = 99992 ) FERR
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03MD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' Scaling factor = ',F8.4)
99993 FORMAT (/' Estimated separation = ',F8.4)
99992 FORMAT (/' Estimated forward error bound = ',F8.4)
      END
Program Data 
 SB03MD EXAMPLE PROGRAM DATA
   3     D     N     X     N
   3.0   1.0   1.0
   1.0   3.0   0.0
   0.0   0.0   3.0
  25.0  24.0  15.0
  24.0  32.0   8.0
  15.0   8.0  40.0
Program Results 
 SB03MD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   2.0000   1.0000   1.0000
   1.0000   3.0000   0.0000
   1.0000   0.0000   4.0000

 Scaling factor =   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03MU.html000077500000000000000000000112631201767322700161200ustar00rootroot00000000000000 SB03MU - SLICOT Library Routine Documentation

SB03MU

Solving a discrete-time Sylvester equation for an m-by-n matrix X, 1 <= m,n <= 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in

         ISGN*op(TL)*X*op(TR) - X = SCALE*B,

  where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1
  or -1.  op(T) = T or T', where T' denotes the transpose of T.
Specification 
      SUBROUTINE SB03MU( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
     $                   LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
C     .. Scalar Arguments ..
      LOGICAL            LTRANL, LTRANR
      INTEGER            INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
      DOUBLE PRECISION   SCALE, XNORM
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
     $                   X( LDX, * )
Arguments

Mode Parameters 

  LTRANL  LOGICAL
          Specifies the form of op(TL) to be used, as follows:
          = .FALSE.:  op(TL) = TL,
          = .TRUE. :  op(TL) = TL'.

  LTRANR  LOGICAL
          Specifies the form of op(TR) to be used, as follows:
          = .FALSE.:  op(TR) = TR,
          = .TRUE. :  op(TR) = TR'.

  ISGN    INTEGER
          Specifies the sign of the equation as described before.
          ISGN may only be 1 or -1.
Input/Output Parameters 
  N1      (input) INTEGER
          The order of matrix TL.  N1 may only be 0, 1 or 2.

  N2      (input) INTEGER
          The order of matrix TR.  N2 may only be 0, 1 or 2.

  TL      (input) DOUBLE PRECISION array, dimension (LDTL,2)
          The leading N1-by-N1 part of this array must contain the
          matrix TL.

  LDTL    INTEGER
          The leading dimension of array TL.  LDTL >= MAX(1,N1).

  TR      (input) DOUBLE PRECISION array, dimension (LDTR,2)
          The leading N2-by-N2 part of this array must contain the
          matrix TR.

  LDTR    INTEGER
          The leading dimension of array TR.  LDTR >= MAX(1,N2).

  B       (input) DOUBLE PRECISION array, dimension (LDB,2)
          The leading N1-by-N2 part of this array must contain the
          right-hand side of the equation.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N1).

  SCALE   (output) DOUBLE PRECISION
          The scale factor. SCALE is chosen less than or equal to 1
          to prevent the solution overflowing.

  X       (output) DOUBLE PRECISION array, dimension (LDX,N2)
          The leading N1-by-N2 part of this array contains the
          solution of the equation.
          Note that X may be identified with B in the calling
          statement.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= MAX(1,N1).

  XNORM   (output) DOUBLE PRECISION
          The infinity-norm of the solution.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if TL and TR have almost reciprocal eigenvalues, so
                TL or TR is perturbed to get a nonsingular equation.

          NOTE: In the interests of speed, this routine does not
                check the inputs for errors.
Method 
  The equivalent linear algebraic system of equations is formed and
  solved using Gaussian elimination with complete pivoting.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is stable and reliable, since Gaussian elimination
  with complete pivoting is used.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03MV.html000077500000000000000000000115301201767322700161160ustar00rootroot00000000000000 SB03MV - SLICOT Library Routine Documentation

SB03MV

Solving a discrete-time Lyapunov equation for a 2-by-2 matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for the 2-by-2 symmetric matrix X in

         op(T)'*X*op(T) - X = SCALE*B,

  where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T',
  where T' denotes the transpose of T.
Specification 
      SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX,
     $                   XNORM, INFO )
C     .. Scalar Arguments ..
      LOGICAL            LTRAN, LUPPER
      INTEGER            INFO, LDB, LDT, LDX
      DOUBLE PRECISION   SCALE, XNORM
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), T( LDT, * ), X( LDX, * )
Arguments

Mode Parameters 

  LTRAN   LOGICAL
          Specifies the form of op(T) to be used, as follows:
          = .FALSE.:  op(T) = T,
          = .TRUE. :  op(T) = T'.

  LUPPER  LOGICAL
          Specifies which triangle of the matrix B is used, and
          which triangle of the matrix X is computed, as follows:
          = .TRUE. :  The upper triangular part;
          = .FALSE.:  The lower triangular part.
Input/Output Parameters 
  T       (input) DOUBLE PRECISION array, dimension (LDT,2)
          The leading 2-by-2 part of this array must contain the
          matrix T.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= 2.

  B       (input) DOUBLE PRECISION array, dimension (LDB,2)
          On entry with LUPPER = .TRUE., the leading 2-by-2 upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix B and the strictly
          lower triangular part of B is not referenced.
          On entry with LUPPER = .FALSE., the leading 2-by-2 lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix B and the strictly
          upper triangular part of B is not referenced.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= 2.

  SCALE   (output) DOUBLE PRECISION
          The scale factor. SCALE is chosen less than or equal to 1
          to prevent the solution overflowing.

  X       (output) DOUBLE PRECISION array, dimension (LDX,2)
          On exit with LUPPER = .TRUE., the leading 2-by-2 upper
          triangular part of this array contains the upper
          triangular part of the symmetric solution matrix X and the
          strictly lower triangular part of X is not referenced.
          On exit with LUPPER = .FALSE., the leading 2-by-2 lower
          triangular part of this array contains the lower
          triangular part of the symmetric solution matrix X and the
          strictly upper triangular part of X is not referenced.
          Note that X may be identified with B in the calling
          statement.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= 2.

  XNORM   (output) DOUBLE PRECISION
          The infinity-norm of the solution.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if T has almost reciprocal eigenvalues, so T
                is perturbed to get a nonsingular equation.

          NOTE: In the interests of speed, this routine does not
                check the inputs for errors.
Method 
  The equivalent linear algebraic system of equations is formed and
  solved using Gaussian elimination with complete pivoting.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is stable and reliable, since Gaussian elimination
  with complete pivoting is used.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03MW.html000077500000000000000000000115321201767322700161210ustar00rootroot00000000000000 SB03MW - SLICOT Library Routine Documentation

SB03MW

Solving a continuous-time Lyapunov equation for a 2-by-2 matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for the 2-by-2 symmetric matrix X in

         op(T)'*X + X*op(T) = SCALE*B,

  where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T',
  where T' denotes the transpose of T.
Specification 
      SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX,
     $                   XNORM, INFO )
C     .. Scalar Arguments ..
      LOGICAL            LTRAN, LUPPER
      INTEGER            INFO, LDB, LDT, LDX
      DOUBLE PRECISION   SCALE, XNORM
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), T( LDT, * ), X( LDX, * )
Arguments

Mode Parameters 

  LTRAN   LOGICAL
          Specifies the form of op(T) to be used, as follows:
          = .FALSE.:  op(T) = T,
          = .TRUE. :  op(T) = T'.

  LUPPER  LOGICAL
          Specifies which triangle of the matrix B is used, and
          which triangle of the matrix X is computed, as follows:
          = .TRUE. :  The upper triangular part;
          = .FALSE.:  The lower triangular part.
Input/Output Parameters 
  T       (input) DOUBLE PRECISION array, dimension (LDT,2)
          The leading 2-by-2 part of this array must contain the
          matrix T.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= 2.

  B       (input) DOUBLE PRECISION array, dimension (LDB,2)
          On entry with LUPPER = .TRUE., the leading 2-by-2 upper
          triangular part of this array must contain the upper
          triangular part of the symmetric matrix B and the strictly
          lower triangular part of B is not referenced.
          On entry with LUPPER = .FALSE., the leading 2-by-2 lower
          triangular part of this array must contain the lower
          triangular part of the symmetric matrix B and the strictly
          upper triangular part of B is not referenced.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= 2.

  SCALE   (output) DOUBLE PRECISION
          The scale factor. SCALE is chosen less than or equal to 1
          to prevent the solution overflowing.

  X       (output) DOUBLE PRECISION array, dimension (LDX,2)
          On exit with LUPPER = .TRUE., the leading 2-by-2 upper
          triangular part of this array contains the upper
          triangular part of the symmetric solution matrix X and the
          strictly lower triangular part of X is not referenced.
          On exit with LUPPER = .FALSE., the leading 2-by-2 lower
          triangular part of this array contains the lower
          triangular part of the symmetric solution matrix X and the
          strictly upper triangular part of X is not referenced.
          Note that X may be identified with B in the calling
          statement.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= 2.

  XNORM   (output) DOUBLE PRECISION
          The infinity-norm of the solution.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if T and -T have too close eigenvalues, so T
                is perturbed to get a nonsingular equation.

          NOTE: In the interests of speed, this routine does not
                check the inputs for errors.
Method 
  The equivalent linear algebraic system of equations is formed and
  solved using Gaussian elimination with complete pivoting.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is stable and reliable, since Gaussian elimination
  with complete pivoting is used.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03MX.html000077500000000000000000000110211201767322700161130ustar00rootroot00000000000000 SB03MX - SLICOT Library Routine Documentation

SB03MX

Solving a discrete-time Lyapunov equation with matrix A quasi-triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the real discrete Lyapunov matrix equation

         op(A)'*X*op(A) - X = scale*C

  where op(A) = A or A' (A**T), A is upper quasi-triangular and C is
  symmetric (C = C'). (A' denotes the transpose of the matrix A.)
  A is N-by-N, the right hand side C and the solution X are N-by-N,
  and scale is an output scale factor, set less than or equal to 1
  to avoid overflow in X. The solution matrix X is overwritten
  onto C.

  A must be in Schur canonical form (as returned by LAPACK routines
  DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and
  2-by-2 diagonal blocks; each 2-by-2 diagonal block has its
  diagonal elements equal and its off-diagonal elements of opposite
  sign.
Specification 
      SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TRANA
      INTEGER            INFO, LDA, LDC, N
      DOUBLE PRECISION   SCALE
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * )
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, and C.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          upper quasi-triangular matrix A, in Schur canonical form.
          The part of A below the first sub-diagonal is not
          referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading N-by-N part of this array must
          contain the symmetric matrix C.
          On exit, if INFO >= 0, the leading N-by-N part of this
          array contains the symmetric solution matrix X.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if A has almost reciprocal eigenvalues; perturbed
                values were used to solve the equation (but the
                matrix A is unchanged).
Method 
  A discrete-time version of the Bartels-Stewart algorithm is used.
  A set of equivalent linear algebraic systems of equations of order
  at most four are formed and solved using Gaussian elimination with
  complete pivoting.
References 
  [1] Barraud, A.Y.                   T
      A numerical algorithm to solve A XA - X = Q.
      IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977.

  [2] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03MY.html000077500000000000000000000103721201767322700161240ustar00rootroot00000000000000 SB03MY - SLICOT Library Routine Documentation

SB03MY

Solving a continuous-time Lyapunov equation with matrix A quasi-triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the real Lyapunov matrix equation

         op(A)'*X + X*op(A) = scale*C

  where op(A) = A or A' (A**T), A is upper quasi-triangular and C is
  symmetric (C = C'). (A' denotes the transpose of the matrix A.)
  A is N-by-N, the right hand side C and the solution X are N-by-N,
  and scale is an output scale factor, set less than or equal to 1
  to avoid overflow in X. The solution matrix X is overwritten
  onto C.

  A must be in Schur canonical form (as returned by LAPACK routines
  DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and
  2-by-2 diagonal blocks; each 2-by-2 diagonal block has its
  diagonal elements equal and its off-diagonal elements of opposite
  sign.
Specification 
      SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TRANA
      INTEGER            INFO, LDA, LDC, N
      DOUBLE PRECISION   SCALE
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * )
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, and C.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          upper quasi-triangular matrix A, in Schur canonical form.
          The part of A below the first sub-diagonal is not
          referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading N-by-N part of this array must
          contain the symmetric matrix C.
          On exit, if INFO >= 0, the leading N-by-N part of this
          array contains the symmetric solution matrix X.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if A and -A have common or very close eigenvalues;
                perturbed values were used to solve the equation
                (but the matrix A is unchanged).
Method 
  Bartels-Stewart algorithm is used. A set of equivalent linear
  algebraic systems of equations of order at most four are formed
  and solved using Gaussian elimination with complete pivoting.
References 
  [1] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03OD.html000077500000000000000000000447771201767322700161210ustar00rootroot00000000000000 SB03OD - SLICOT Library Routine Documentation

SB03OD

Solution of stable continuous- or discrete-time Lyapunov equations (Cholesky factor)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X = op(U)'*op(U) either the stable non-negative
  definite continuous-time Lyapunov equation
                                2
     op(A)'*X + X*op(A) = -scale *op(B)'*op(B)                   (1)

  or the convergent non-negative definite discrete-time Lyapunov
  equation
                                2
     op(A)'*X*op(A) - X = -scale *op(B)'*op(B)                   (2)

  where op(K) = K or K' (i.e., the transpose of the matrix K), A is
  an N-by-N matrix, op(B) is an M-by-N matrix, U is an upper
  triangular matrix containing the Cholesky factor of the solution
  matrix X, X = op(U)'*op(U), and scale is an output scale factor,
  set less than or equal to 1 to avoid overflow in X. If matrix B
  has full rank then the solution matrix X will be positive-definite
  and hence the Cholesky factor U will be nonsingular, but if B is
  rank deficient then X may be only positive semi-definite and U
  will be singular.

  In the case of equation (1) the matrix A must be stable (that
  is, all the eigenvalues of A must have negative real parts),
  and for equation (2) the matrix A must be convergent (that is,
  all the eigenvalues of A must lie inside the unit circle).
Specification 
      SUBROUTINE SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B,
     $                   LDB, SCALE, WR, WI, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of Lyapunov equation to be solved as
          follows:
          = 'C':  Equation (1), continuous-time case;
          = 'D':  Equation (2), discrete-time case.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, A and Q contain the factors from the
                  real Schur factorization of the matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in A and Q.

  TRANS   CHARACTER*1
          Specifies the form of op(K) to be used, as follows:
          = 'N':  op(K) = K    (No transpose);
          = 'T':  op(K) = K**T (Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A and the number of columns in
          matrix op(B).  N >= 0.

  M       (input) INTEGER
          The number of rows in matrix op(B).  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A. If FACT = 'F', then A contains
          an upper quasi-triangular matrix S in Schur canonical
          form; the elements below the upper Hessenberg part of the
          array A are not referenced.
          On exit, the leading N-by-N upper Hessenberg part of this
          array contains the upper quasi-triangular matrix S in
          Schur canonical form from the Shur factorization of A.
          The contents of array A is not modified if FACT = 'F'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  Q       (input or output) DOUBLE PRECISION array, dimension
          (LDQ,N)
          On entry, if FACT = 'F', then the leading N-by-N part of
          this array must contain the orthogonal matrix Q of the
          Schur factorization of A.
          Otherwise, Q need not be set on entry.
          On exit, the leading N-by-N part of this array contains
          the orthogonal matrix Q of the Schur factorization of A.
          The contents of array Q is not modified if FACT = 'F'.

  LDQ     INTEGER
          The leading dimension of array Q.  LDQ >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          if TRANS = 'N', and dimension (LDB,max(M,N)), if
          TRANS = 'T'.
          On entry, if TRANS = 'N', the leading M-by-N part of this
          array must contain the coefficient matrix B of the
          equation.
          On entry, if TRANS = 'T', the leading N-by-M part of this
          array must contain the coefficient matrix B of the
          equation.
          On exit, the leading N-by-N part of this array contains
          the upper triangular Cholesky factor U of the solution
          matrix X of the problem, X = op(U)'*op(U).
          If M = 0 and N > 0, then U is set to zero.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,N,M), if TRANS = 'N';
          LDB >= MAX(1,N),   if TRANS = 'T'.

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          If FACT = 'N', and INFO >= 0 and INFO <= 2, WR and WI
          contain the real and imaginary parts, respectively, of
          the eigenvalues of A.
          If FACT = 'F', WR and WI are not referenced.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          If M > 0, LDWORK >= MAX(1,4*N + MIN(M,N));
          If M = 0, LDWORK >= 1.
          For optimum performance LDWORK should sometimes be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the Lyapunov equation is (nearly) singular
                (warning indicator);
                if DICO = 'C' this means that while the matrix A
                (or the factor S) has computed eigenvalues with
                negative real parts, it is only just stable in the
                sense that small perturbations in A can make one or
                more of the eigenvalues have a non-negative real
                part;
                if DICO = 'D' this means that while the matrix A
                (or the factor S) has computed eigenvalues inside
                the unit circle, it is nevertheless only just
                convergent, in the sense that small perturbations
                in A can make one or more of the eigenvalues lie
                outside the unit circle;
                perturbed values were used to solve the equation;
          = 2:  if FACT = 'N' and DICO = 'C', but the matrix A is
                not stable (that is, one or more of the eigenvalues
                of A has a non-negative real part), or DICO = 'D',
                but the matrix A is not convergent (that is, one or
                more of the eigenvalues of A lies outside the unit
                circle); however, A will still have been factored
                and the eigenvalues of A returned in WR and WI.
          = 3:  if FACT = 'F' and DICO = 'C', but the Schur factor S
                supplied in the array A is not stable (that is, one
                or more of the eigenvalues of S has a non-negative
                real part), or DICO = 'D', but the Schur factor S
                supplied in the array A is not convergent (that is,
                one or more of the eigenvalues of S lies outside the
                unit circle);
          = 4:  if FACT = 'F' and the Schur factor S supplied in
                the array A has two or more consecutive non-zero
                elements on the first sub-diagonal, so that there is
                a block larger than 2-by-2 on the diagonal;
          = 5:  if FACT = 'F' and the Schur factor S supplied in
                the array A has a 2-by-2 diagonal block with real
                eigenvalues instead of a complex conjugate pair;
          = 6:  if FACT = 'N' and the LAPACK Library routine DGEES
                has failed to converge. This failure is not likely
                to occur. The matrix B will be unaltered but A will
                be destroyed.
Method 
  The method used by the routine is based on the Bartels and Stewart
  method [1], except that it finds the upper triangular matrix U
  directly without first finding X and without the need to form the
  normal matrix op(B)'*op(B).

  The Schur factorization of a square matrix A is given by

     A = QSQ',

  where Q is orthogonal and S is an N-by-N block upper triangular
  matrix with 1-by-1 and 2-by-2 blocks on its diagonal (which
  correspond to the eigenvalues of A). If A has already been
  factored prior to calling the routine however, then the factors
  Q and S may be supplied and the initial factorization omitted.

  If TRANS = 'N', the matrix B is factored as (QR factorization)
         _   _                   _   _  _
     B = P ( R ),  M >= N,   B = P ( R  Z ),  M < N,
           ( 0 )
        _                                    _
  where P is an M-by-M orthogonal matrix and R is a square upper
                                      _   _      _     _  _
  triangular matrix. Then, the matrix B = RQ, or B = ( R  Z )Q (if
  M < N) is factored as
     _                       _
     B = P ( R ),  M >= N,   B = P ( R  Z ),  M < N.

  If TRANS = 'T', the matrix B is factored as (RQ factorization)
                                      _
              _   _                 ( Z ) _
     B = ( 0  R ) P,  M >= N,   B = ( _ ) P,  M < N,
                                    ( R )
        _                                    _
  where P is an M-by-M orthogonal matrix and R is a square upper
                                      _     _     _       _   _
  triangular matrix. Then, the matrix B = Q'R, or B = Q'( Z'  R' )'
  (if M < N) is factored as
     _                       _
     B = ( R ) P,  M >= N,   B = ( Z ) P,  M < N.
                                 ( R )

  These factorizations are utilised to either transform the
  continuous-time Lyapunov equation to the canonical form
                                                     2
    op(S)'*op(V)'*op(V) + op(V)'*op(V)*op(S) = -scale *op(F)'*op(F),

  or the discrete-time Lyapunov equation to the canonical form
                                                     2
    op(S)'*op(V)'*op(V)*op(S) - op(V)'*op(V) = -scale *op(F)'*op(F),

  where V and F are upper triangular, and

     F = R,  M >= N,   F = ( R  Z ),  M < N, if TRANS = 'N';
                           ( 0  0 )

     F = R,  M >= N,   F = ( 0  Z ),  M < N, if TRANS = 'T'.
                           ( 0  R )

  The transformed equation is then solved for V, from which U is
  obtained via the QR factorization of V*Q', if TRANS = 'N', or
  via the RQ factorization of Q*V, if TRANS = 'T'.
References 
  [1] Bartels, R.H. and Stewart, G.W.
      Solution of the matrix equation  A'X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-325, 1982.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  The Lyapunov equation may be very ill-conditioned. In particular,
  if A is only just stable (or convergent) then the Lyapunov
  equation will be ill-conditioned.  A symptom of ill-conditioning
  is "large" elements in U relative to those of A and B, or a
  "small" value for scale. A condition estimate can be computed
  using SLICOT Library routine SB03MD.

  SB03OD routine can be also used for solving "unstable" Lyapunov
  equations, i.e., when matrix A has all eigenvalues with positive
  real parts, if DICO = 'C', or with moduli greater than one,
  if DICO = 'D'. Specifically, one may solve for X = op(U)'*op(U)
  either the continuous-time Lyapunov equation
                               2
     op(A)'*X + X*op(A) = scale *op(B)'*op(B),                   (3)

  or the discrete-time Lyapunov equation
                               2
     op(A)'*X*op(A) - X = scale *op(B)'*op(B),                   (4)

  provided, for equation (3), the given matrix A is replaced by -A,
  or, for equation (4), the given matrices A and B are replaced by
  inv(A) and B*inv(A), if TRANS = 'N' (or inv(A)*B, if TRANS = 'T'),
  respectively. Although the inversion generally can rise numerical
  problems, in case of equation (4) it is expected that the matrix A
  is enough well-conditioned, having only eigenvalues with moduli
  greater than 1. However, if A is ill-conditioned, it could be
  preferable to use the more general SLICOT Lyapunov solver SB03MD.
Example

Program Text 

*     SB03OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDQ, LDX, LDWORK
      PARAMETER        ( LDA = NMAX, LDB = MAX( MMAX,NMAX ),
     $                   LDQ = NMAX, LDX = NMAX )
      PARAMETER        ( LDWORK = 4*NMAX+MIN(MMAX,NMAX) )
*     .. Local Scalars ..
      DOUBLE PRECISION SCALE, TEMP
      INTEGER          I, INFO, J, K, M, N
      CHARACTER*1      DICO, FACT, TRANS
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,LDB), DWORK(LDWORK),
     $                 Q(LDQ,NMAX), WR(NMAX), WI(NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB03OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * )
     $                         ( ( Q(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            IF ( LSAME( TRANS, 'N' ) ) THEN
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M )
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            END IF
*           Find the Cholesky factor U.
            CALL SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B,
     $                   LDB, SCALE, WR, WI, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 J = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), I = 1,J )
   20          CONTINUE
*              Form the solution matrix X = op(U)'*op(U).
               IF ( LSAME( TRANS, 'N' ) ) THEN
                  DO 80 I = 1, N
                     DO 60 J = I, N
                        TEMP = ZERO
                        DO 40 K = 1, I
                           TEMP = TEMP + B(K,I)*B(K,J)
   40                   CONTINUE
                        X(I,J) = TEMP
                        X(J,I) = TEMP
   60                CONTINUE
   80             CONTINUE
               ELSE
                  DO 140 I = 1, N
                     DO 120 J = I, N
                        TEMP = ZERO
                        DO 100 K = J, N
                           TEMP = TEMP + B(I,K)*B(J,K)
  100                   CONTINUE
                        X(I,J) = TEMP
                        X(J,I) = TEMP
  120                CONTINUE
  140             CONTINUE
               END IF
               WRITE ( NOUT, FMT = 99995 )
               DO 160 J = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( X(I,J), I = 1,N )
  160          CONTINUE
               WRITE ( NOUT, FMT = 99992 ) SCALE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03OD = ',I2)
99997 FORMAT (' The transpose of the Cholesky factor U is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The solution matrix X = op(U)''*op(U) is ')
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' Scaling factor = ',F8.4)
      END
Program Data 
 SB03OD EXAMPLE PROGRAM DATA
   4     5      C      N      N
  -1.0  37.0 -12.0 -12.0
  -1.0 -10.0   0.0   4.0
   2.0  -4.0   7.0  -6.0
   2.0   2.0   7.0  -9.0
   1.0   2.5   1.0   3.5
   0.0   1.0   0.0   1.0
  -1.0  -2.5  -1.0  -1.5
   1.0   2.5   4.0  -5.5
  -1.0  -2.5  -4.0   3.5
Program Results 
 SB03OD EXAMPLE PROGRAM RESULTS

 The transpose of the Cholesky factor U is 
   1.0000
   3.0000   1.0000
   2.0000  -1.0000   1.0000
  -1.0000   1.0000  -2.0000   1.0000

 The solution matrix X = op(U)'*op(U) is 
   1.0000   3.0000   2.0000  -1.0000
   3.0000  10.0000   5.0000  -2.0000
   2.0000   5.0000   6.0000  -5.0000
  -1.0000  -2.0000  -5.0000   7.0000

 Scaling factor =   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03OR.html000077500000000000000000000116541201767322700161230ustar00rootroot00000000000000 SB03OR - SLICOT Library Routine Documentation

SB03OR

Solving continuous- or discrete-time Sylvester equations, with matrix S quasi-triangular, for an n-by-m matrix X, 1 <= m <= 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the solution of the Sylvester equations

     op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE.  or

     op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE.

  where op(K) = K or K' (i.e., the transpose of the matrix K), S is
  an N-by-N block upper triangular matrix with one-by-one and
  two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or
  M = 2), X and C are each N-by-M matrices, and scale is an output
  scale factor, set less than or equal to 1 to avoid overflow in X.
  The solution X is overwritten on C.

  SB03OR  is a service routine for the Lyapunov solver  SB03OT.
Specification 
      SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC,
     $                   SCALE, INFO )
C     .. Scalar Arguments ..
      LOGICAL            DISCR, LTRANS
      INTEGER            INFO, LDA, LDS, LDC, M, N
      DOUBLE PRECISION   SCALE
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), S( LDS, * )
Arguments

Mode Parameters 

  DISCR   LOGICAL
          Specifies the equation to be solved:
          = .FALSE.:  op(S)'*X + X*op(A) = scale*C;
          = .TRUE. :  op(S)'*X*op(A) - X = scale*C.

  LTRANS  LOGICAL
          Specifies the form of op(K) to be used, as follows:
          = .FALSE.:  op(K) = K    (No transpose);
          = .TRUE. :  op(K) = K**T (Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix  S  and also the number of rows of
          matrices  X and C.  N >= 0.

  M       (input) INTEGER
          The order of the matrix  A  and also the number of columns
          of matrices  X and C.  M = 1 or M = 2.

  S       (input) DOUBLE PRECISION array, dimension (LDS,N)
          The leading  N-by-N  upper Hessenberg part of the array  S
          must contain the block upper triangular matrix. The
          elements below the upper Hessenberg part of the array  S
          are not referenced.  The array  S  must not contain
          diagonal blocks larger than two-by-two and the two-by-two
          blocks must only correspond to complex conjugate pairs of
          eigenvalues, not to real eigenvalues.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,N).

  A       (input) DOUBLE PRECISION array, dimension (LDS,M)
          The leading  M-by-M  part of this array must contain a
          given matrix, where M = 1 or M = 2.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= M.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
          On entry, C must contain an N-by-M matrix, where M = 1 or
          M = 2.
          On exit, C contains the N-by-M matrix X, the solution of
          the Sylvester equation.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if DISCR = .FALSE., and S and -A have common
                eigenvalues, or if DISCR = .TRUE., and S and A have
                eigenvalues whose product is equal to unity;
                a solution has been computed using slightly
                perturbed values.
Method 
  The LAPACK scheme for solving Sylvester equations is adapted.
References 
  [1] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-325, 1982.
Numerical Aspects 
                            2
  The algorithm requires 0(N M) operations and is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03OT.html000077500000000000000000000166021201767322700161230ustar00rootroot00000000000000 SB03OT - SLICOT Library Routine Documentation

SB03OT

Solving (for Cholesky factor) stable continuous- or discrete-time Lyapunov equations, with matrix S quasi-triangular and R triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X = op(U)'*op(U) either the stable non-negative
  definite continuous-time Lyapunov equation
                                2
     op(S)'*X + X*op(S) = -scale *op(R)'*op(R)                   (1)

  or the convergent non-negative definite discrete-time Lyapunov
  equation
                                2
     op(S)'*X*op(S) - X = -scale *op(R)'*op(R)                   (2)

  where op(K) = K or K' (i.e., the transpose of the matrix K), S is
  an N-by-N block upper triangular matrix with one-by-one or
  two-by-two blocks on the diagonal, R is an N-by-N upper triangular
  matrix, and scale is an output scale factor, set less than or
  equal to 1 to avoid overflow in X.

  In the case of equation (1) the matrix S must be stable (that
  is, all the eigenvalues of S must have negative real parts),
  and for equation (2) the matrix S must be convergent (that is,
  all the eigenvalues of S must lie inside the unit circle).
Specification 
      SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      LOGICAL           DISCR, LTRANS
      INTEGER           INFO, LDR, LDS, N
      DOUBLE PRECISION  SCALE
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), R(LDR,*), S(LDS,*)
Arguments

Mode Parameters 

  DISCR   LOGICAL
          Specifies the type of Lyapunov equation to be solved as
          follows:
          = .TRUE. :  Equation (2), discrete-time case;
          = .FALSE.:  Equation (1), continuous-time case.

  LTRANS  LOGICAL
          Specifies the form of op(K) to be used, as follows:
          = .FALSE.:  op(K) = K    (No transpose);
          = .TRUE. :  op(K) = K**T (Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices S and R.  N >= 0.

  S       (input) DOUBLE PRECISION array of dimension (LDS,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the block upper triangular matrix.
          The elements below the upper Hessenberg part of the array
          S are not referenced. The 2-by-2 blocks must only
          correspond to complex conjugate pairs of eigenvalues (not
          to real eigenvalues).

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,N).

  R       (input/output) DOUBLE PRECISION array of dimension (LDR,N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the upper triangular matrix R.
          On exit, the leading N-by-N upper triangular part of this
          array contains the upper triangular matrix U.
          The strict lower triangle of R is not referenced.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (4*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the Lyapunov equation is (nearly) singular
                (warning indicator);
                if DISCR = .FALSE., this means that while the
                matrix S has computed eigenvalues with negative real
                parts, it is only just stable in the sense that
                small perturbations in S can make one or more of the
                eigenvalues have a non-negative real part;
                if DISCR = .TRUE., this means that while the
                matrix S has computed eigenvalues inside the unit
                circle, it is nevertheless only just convergent, in
                the sense that small perturbations in S can make one
                or more of the eigenvalues lie outside the unit
                circle;
                perturbed values were used to solve the equation
                (but the matrix S is unchanged);
          = 2:  if the matrix S is not stable (that is, one or more
                of the eigenvalues of S has a non-negative real
                part), if DISCR = .FALSE., or not convergent (that
                is, one or more of the eigenvalues of S lies outside
                the unit circle), if DISCR = .TRUE.;
          = 3:  if the matrix S has two or more consecutive non-zero
                elements on the first sub-diagonal, so that there is
                a block larger than 2-by-2 on the diagonal;
          = 4:  if the matrix S has a 2-by-2 diagonal block with
                real eigenvalues instead of a complex conjugate
                pair.
Method 
  The method used by the routine is based on a variant of the
  Bartels and Stewart backward substitution method [1], that finds
  the Cholesky factor op(U) directly without first finding X and
  without the need to form the normal matrix op(R)'*op(R) [2].

  The continuous-time Lyapunov equation in the canonical form
                                                     2
    op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(R)'*op(R),

  or the discrete-time Lyapunov equation in the canonical form
                                                     2
    op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(R)'*op(R),

  where U and R are upper triangular, is solved for U.
References 
  [1] Bartels, R.H. and Stewart, G.W.
      Solution of the matrix equation  A'X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-325, 1982.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  The Lyapunov equation may be very ill-conditioned. In particular
  if S is only just stable (or convergent) then the Lyapunov
  equation will be ill-conditioned. "Large" elements in U relative
  to those of S and R, or a "small" value for scale, is a symptom
  of ill-conditioning. A condition estimate can be computed using
  SLICOT Library routine SB03MD.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03OU.html000077500000000000000000000252031201767322700161210ustar00rootroot00000000000000 SB03OU - SLICOT Library Routine Documentation

SB03OU

Solving (for Cholesky factor) stable continuous- or discrete-time Lyapunov equations, with matrix A in real Schur form and B rectangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X = op(U)'*op(U) either the stable non-negative
  definite continuous-time Lyapunov equation
                                2
     op(A)'*X + X*op(A) = -scale *op(B)'*op(B)                   (1)

  or the convergent non-negative definite discrete-time Lyapunov
  equation
                                2
     op(A)'*X*op(A) - X = -scale *op(B)'*op(B)                   (2)

  where op(K) = K or K' (i.e., the transpose of the matrix K), A is
  an N-by-N matrix in real Schur form, op(B) is an M-by-N matrix,
  U is an upper triangular matrix containing the Cholesky factor of
  the solution matrix X, X = op(U)'*op(U), and scale is an output
  scale factor, set less than or equal to 1 to avoid overflow in X.
  If matrix B has full rank then the solution matrix X will be
  positive-definite and hence the Cholesky factor U will be
  nonsingular, but if B is rank deficient then X may only be
  positive semi-definite and U will be singular.

  In the case of equation (1) the matrix A must be stable (that
  is, all the eigenvalues of A must have negative real parts),
  and for equation (2) the matrix A must be convergent (that is,
  all the eigenvalues of A must lie inside the unit circle).
Specification 
      SUBROUTINE SB03OU( DISCR, LTRANS, N, M, A, LDA, B, LDB, TAU, U,
     $                   LDU, SCALE, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  DISCR   LOGICAL
          Specifies the type of Lyapunov equation to be solved as
          follows:
          = .TRUE. :  Equation (2), discrete-time case;
          = .FALSE.:  Equation (1), continuous-time case.

  LTRANS  LOGICAL
          Specifies the form of op(K) to be used, as follows:
          = .FALSE.:  op(K) = K    (No transpose);
          = .TRUE. :  op(K) = K**T (Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A and the number of columns in
          matrix op(B).  N >= 0.

  M       (input) INTEGER
          The number of rows in matrix op(B).  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain a real Schur form matrix S. The elements
          below the upper Hessenberg part of the array A are not
          referenced. The 2-by-2 blocks must only correspond to
          complex conjugate pairs of eigenvalues (not to real
          eigenvalues).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          if LTRANS = .FALSE., and dimension (LDB,M), if
          LTRANS = .TRUE..
          On entry, if LTRANS = .FALSE., the leading M-by-N part of
          this array must contain the coefficient matrix B of the
          equation.
          On entry, if LTRANS = .TRUE., the leading N-by-M part of
          this array must contain the coefficient matrix B of the
          equation.
          On exit, if LTRANS = .FALSE., the leading
          MIN(M,N)-by-MIN(M,N) upper triangular part of this array
          contains the upper triangular matrix R (as defined in
          METHOD), and the M-by-MIN(M,N) strictly lower triangular
          part together with the elements of the array TAU are
          overwritten by details of the matrix P (also defined in
          METHOD). When M < N, columns (M+1),...,N of the array B
          are overwritten by the matrix Z (see METHOD).
          On exit, if LTRANS = .TRUE., the leading
          MIN(M,N)-by-MIN(M,N) upper triangular part of
          B(1:N,M-N+1), if M >= N, or of B(N-M+1:N,1:M), if M < N,
          contains the upper triangular matrix R (as defined in
          METHOD), and the remaining elements (below the diagonal
          of R) together with the elements of the array TAU are
          overwritten by details of the matrix P (also defined in
          METHOD). When M < N, rows 1,...,(N-M) of the array B
          are overwritten by the matrix Z (see METHOD).

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,M), if LTRANS = .FALSE.,
          LDB >= MAX(1,N), if LTRANS = .TRUE..

  TAU     (output) DOUBLE PRECISION array of dimension (MIN(N,M))
          This array contains the scalar factors of the elementary
          reflectors defining the matrix P.

  U       (output) DOUBLE PRECISION array of dimension (LDU,N)
          The leading N-by-N upper triangular part of this array
          contains the Cholesky factor of the solution matrix X of
          the problem, X = op(U)'*op(U).
          The array U may be identified with B in the calling
          statement, if B is properly dimensioned, and the
          intermediate results returned in B are not needed.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK. LDWORK >= MAX(1,4*N).
          For optimum performance LDWORK should sometimes be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the Lyapunov equation is (nearly) singular
                (warning indicator);
                if DISCR = .FALSE., this means that while the matrix
                A has computed eigenvalues with negative real parts,
                it is only just stable in the sense that small
                perturbations in A can make one or more of the
                eigenvalues have a non-negative real part;
                if DISCR = .TRUE., this means that while the matrix
                A has computed eigenvalues inside the unit circle,
                it is nevertheless only just convergent, in the
                sense that small perturbations in A can make one or
                more of the eigenvalues lie outside the unit circle;
                perturbed values were used to solve the equation
                (but the matrix A is unchanged);
          = 2:  if matrix A is not stable (that is, one or more of
                the eigenvalues of A has a non-negative real part),
                if DISCR = .FALSE., or not convergent (that is, one
                or more of the eigenvalues of A lies outside the
                unit circle), if DISCR = .TRUE.;
          = 3:  if matrix A has two or more consecutive non-zero
                elements on the first sub-diagonal, so that there is
                a block larger than 2-by-2 on the diagonal;
          = 4:  if matrix A has a 2-by-2 diagonal block with real
                eigenvalues instead of a complex conjugate pair.
Method 
  The method used by the routine is based on the Bartels and
  Stewart method [1], except that it finds the upper triangular
  matrix U directly without first finding X and without the need
  to form the normal matrix op(B)'*op(B) [2].

  If LTRANS = .FALSE., the matrix B is factored as

     B = P ( R ),  M >= N,   B = P ( R  Z ),  M < N,
           ( 0 )

  (QR factorization), where P is an M-by-M orthogonal matrix and
  R is a square upper triangular matrix.

  If LTRANS = .TRUE., the matrix B is factored as

     B = ( 0  R ) P,  M >= N,  B = ( Z ) P,  M < N,
                                   ( R )

  (RQ factorization), where P is an M-by-M orthogonal matrix and
  R is a square upper triangular matrix.

  These factorizations are used to solve the continuous-time
  Lyapunov equation in the canonical form
                                                     2
    op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F),

  or the discrete-time Lyapunov equation in the canonical form
                                                     2
    op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F),

  where U and F are N-by-N upper triangular matrices, and

     F = R,                                  if M >= N, or

     F = ( R ),    if LTRANS = .FALSE.,  or
         ( 0 )

     F = ( 0  Z ), if LTRANS = .TRUE.,       if M < N.
         ( 0  R )

  The canonical equation is solved for U.
References 
  [1] Bartels, R.H. and Stewart, G.W.
      Solution of the matrix equation  A'X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-325, 1982.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  The Lyapunov equation may be very ill-conditioned. In particular,
  if A is only just stable (or convergent) then the Lyapunov
  equation will be ill-conditioned. "Large" elements in U relative
  to those of A and B, or a "small" value for scale, are symptoms
  of ill-conditioning. A condition estimate can be computed using
  SLICOT Library routine SB03MD.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03OV.html000077500000000000000000000050561201767322700161260ustar00rootroot00000000000000 SB03OV - SLICOT Library Routine Documentation

SB03OV

Construction of a complex plane rotation to annihilate a real number, modifying a complex number

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct a complex plane rotation such that, for a complex
  number  a  and a real number  b,

     ( conjg( c )  s )*( a ) = ( d ),
     (       -s    c ) ( b )   ( 0 )

  where  d  is always real and is overwritten on  a,  so that on
  return the imaginary part of  a  is zero.  b  is unaltered.

  This routine has A and C declared as REAL, because it is intended
  for use within a real Lyapunov solver and the REAL declarations
  mean that a standard Fortran DOUBLE PRECISION version may be
  readily constructed.  However A and C could safely be declared
  COMPLEX in the calling program, although some systems may give a
  type mismatch warning.
Specification 
      SUBROUTINE SB03OV( A, B, C, S )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  B, S
C     .. Array Arguments ..
      DOUBLE PRECISION  A(2), C(2)
Arguments

Input/Output Parameters 

  A       (input/output) DOUBLE PRECISION array, dimension (2)
          On entry, A(1) and A(2) must contain the real and
          imaginary part, respectively, of the complex number a.
          On exit, A(1) contains the real part of d, and A(2) is
          set to zero.

  B       (input) DOUBLE PRECISION
          The real number b.

  C       (output) DOUBLE PRECISION array, dimension (2)
          C(1) and C(2) contain the real and imaginary part,
          respectively, of the complex number c, the cosines of
          the plane rotation.

  S       (output) DOUBLE PRECISION
          The real number s, the sines of the plane rotation.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03OY.html000077500000000000000000000155041201767322700161300ustar00rootroot00000000000000 SB03OY - SLICOT Library Routine Documentation

SB03OY

Solving (for Cholesky factor) stable 2-by-2 continuous- or discrete-time Lyapunov equations, with matrix A having complex conjugate eigenvalues

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for the Cholesky factor  U  of  X,

     op(U)'*op(U) = X,

  where  U  is a two-by-two upper triangular matrix, either the
  continuous-time two-by-two Lyapunov equation
                                      2
      op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R),

  when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov
  equation
                                      2
      op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R),

  when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of
  the matrix K),  S  is a two-by-two matrix with complex conjugate
  eigenvalues,  R  is a two-by-two upper triangular matrix,
  ISGN = -1 or 1,  and  scale  is an output scale factor, set less
  than or equal to 1 to avoid overflow in  X.  The routine also
  computes two matrices, B and A, so that
                                2
     B*U = U*S  and  A*U = scale *R,  if  LTRANS = .FALSE.,  or
                                2
     U*B = S*U  and  U*A = scale *R,  if  LTRANS = .TRUE.,
  which are used by the general Lyapunov solver.
  In the continuous-time case  ISGN*S  must be stable, so that its
  eigenvalues must have strictly negative real parts.
  In the discrete-time case  S  must be convergent if ISGN = 1, that
  is, its eigenvalues must have moduli less than unity, or  S  must
  be completely divergent if ISGN = -1, that is, its eigenvalues
  must have moduli greater than unity.
Specification 
      SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA,
     $                   SCALE, INFO )
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,*)
Arguments

Mode Parameters 

  DISCR   LOGICAL
          Specifies the equation to be solved:       2
          = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R);
                                                     2
          = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R).

  LTRANS  LOGICAL
          Specifies the form of op(K) to be used, as follows:
          = .FALSE.:  op(K) = K    (No transpose);
          = .TRUE. :  op(K) = K**T (Transpose).

  ISGN    INTEGER
          Specifies the sign of the equation as described before.
          ISGN may only be 1 or -1.
Input/Output Parameters 
  S       (input/output) DOUBLE PRECISION array, dimension (LDS,2)
          On entry, S must contain a 2-by-2 matrix.
          On exit, S contains a 2-by-2 matrix B such that B*U = U*S,
          if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE..
          Notice that if U is nonsingular then
            B = U*S*inv( U ),  if LTRANS = .FALSE.
            B = inv( U )*S*U,  if LTRANS = .TRUE..

  LDS     INTEGER
          The leading dimension of array S.  LDS >= 2.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,2)
          On entry, R must contain a 2-by-2 upper triangular matrix.
          The element R( 2, 1 ) is not referenced.
          On exit, R contains U, the 2-by-2 upper triangular
          Cholesky factor of the solution X, X = op(U)'*op(U).

  LDR     INTEGER
          The leading dimension of array R.  LDR >= 2.

  A       (output) DOUBLE PRECISION array, dimension (LDA,2)
          A contains a 2-by-2 upper triangular matrix A satisfying
          A*U/scale = scale*R, if LTRANS = .FALSE., or
          U*A/scale = scale*R, if LTRANS = .TRUE..
          Notice that if U is nonsingular then
            A = scale*scale*R*inv( U ),  if LTRANS = .FALSE.
            A = scale*scale*inv( U )*R,  if LTRANS = .TRUE..

  LDA     INTEGER
          The leading dimension of array A.  LDA >= 2.

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if the Lyapunov equation is (nearly) singular
                (warning indicator);
                if DISCR = .FALSE., this means that while the
                matrix S has computed eigenvalues with negative real
                parts, it is only just stable in the sense that
                small perturbations in S can make one or more of the
                eigenvalues have a non-negative real part;
                if DISCR = .TRUE., this means that while the
                matrix S has computed eigenvalues inside the unit
                circle, it is nevertheless only just convergent, in
                the sense that small perturbations in S can make one
                or more of the eigenvalues lie outside the unit
                circle;
                perturbed values were used to solve the equation
                (but the matrix S is unchanged);
          = 2:  if DISCR = .FALSE., and ISGN*S is not stable or
                if DISCR = .TRUE., ISGN = 1 and S is not convergent
                or if DISCR = .TRUE., ISGN = -1 and S is not
                completely divergent;
          = 4:  if S has real eigenvalues.

  NOTE: In the interests of speed, this routine does not check all
        inputs for errors.
Method 
  The LAPACK scheme for solving 2-by-2 Sylvester equations is
  adapted for 2-by-2 Lyapunov equations, but directly computing the
  Cholesky factor of the solution.
References 
  [1] Hammarling S. J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-325, 1982.
Numerical Aspects 
  The algorithm is backward stable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03PD.html000077500000000000000000000216301201767322700161010ustar00rootroot00000000000000 SB03PD - SLICOT Library Routine Documentation

SB03PD

Solution of discrete-time Lyapunov equations and separation estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the real discrete Lyapunov matrix equation

         op(A)'*X*op(A) - X = scale*C

  and/or estimate the quantity, called separation,

      sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X)

  where op(A) = A or A' (A**T) and C is symmetric (C = C').
  (A' denotes the transpose of the matrix A.) A is N-by-N, the right
  hand side C and the solution X are N-by-N, and scale is an output
  scale factor, set less than or equal to 1 to avoid overflow in X.
Specification 
      SUBROUTINE SB03PD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC,
     $                   SCALE, SEPD, FERR, WR, WI, IWORK, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, TRANA
      INTEGER            INFO, LDA, LDC, LDU, LDWORK, N
      DOUBLE PRECISION   FERR, SCALE, SEPD
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   U( LDU, * ), WI( * ), WR( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'X':  Compute the solution only;
          = 'S':  Compute the separation only;
          = 'B':  Compute both the solution and the separation.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, A and U contain the factors from the
                  real Schur factorization of the matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in A and U.

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, and C.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A. If FACT = 'F', then A contains
          an upper quasi-triangular matrix in Schur canonical form.
          On exit, if INFO = 0 or INFO = N+1, the leading N-by-N
          part of this array contains the upper quasi-triangular
          matrix in Schur canonical form from the Shur factorization
          of A. The contents of array A is not modified if
          FACT = 'F'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If FACT = 'F', then U is an input argument and on entry
          it must contain the orthogonal matrix U from the real
          Schur factorization of A.
          If FACT = 'N', then U is an output argument and on exit,
          if INFO = 0 or INFO = N+1, it contains the orthogonal
          N-by-N matrix from the real Schur factorization of A.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry with JOB = 'X' or 'B', the leading N-by-N part of
          this array must contain the symmetric matrix C.
          On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1,
          the leading N-by-N part of C has been overwritten by the
          symmetric solution matrix X.
          If JOB = 'S', C is not referenced.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= 1,        if JOB = 'S';
          LDC >= MAX(1,N), otherwise.

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.

  SEPD    (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1,
          SEPD contains the estimate in the 1-norm of
          sepd(op(A),op(A)').
          If JOB = 'X' or N = 0, SEPD is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains
          an estimated forward error bound for the solution X.
          If XTRUE is the true solution, FERR bounds the relative
          error in the computed solution, measured in the Frobenius
          norm:  norm(X - XTRUE)/norm(XTRUE).
          If JOB = 'X' or JOB = 'S', FERR is not referenced.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
          contain the real and imaginary parts, respectively, of the
          eigenvalues of A.
          If FACT = 'F', WR and WI are not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)
          This array is not referenced if JOB = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 1 and
          If JOB = 'X' then
             If FACT = 'F', LDWORK >= MAX(N*N,2*N);
             If FACT = 'N', LDWORK >= MAX(N*N,3*N).
          If JOB = 'S' or JOB = 'B' then
             LDWORK >= 2*N*N + 2*N.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, the QR algorithm failed to compute all
                the eigenvalues (see LAPACK Library routine DGEES);
                elements i+1:n of WR and WI contain eigenvalues
                which have converged, and A contains the partially
                converged Schur form;
          = N+1:  if matrix A has almost reciprocal eigenvalues;
                perturbed values were used to solve the equation
                (but the matrix A is unchanged).
Method 
  After reducing matrix A to real Schur canonical form (if needed),
  a discrete-time version of the Bartels-Stewart algorithm is used.
  A set of equivalent linear algebraic systems of equations of order
  at most four are formed and solved using Gaussian elimination with
  complete pivoting.
References 
  [1] Barraud, A.Y.                   T
      A numerical algorithm to solve A XA - X = Q.
      IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977.

  [2] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  SEPD is defined as

         sepd( op(A), op(A)' ) = sigma_min( T )

  where sigma_min(T) is the smallest singular value of the
  N*N-by-N*N matrix

     T = kprod( op(A)', op(A)' ) - I(N**2).

  I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the
  Kronecker product. The program estimates sigma_min(T) by the
  reciprocal of an estimate of the 1-norm of inverse(T). The true
  reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by
  more than a factor of N.

  When SEPD is small, small changes in A, C can cause large changes
  in the solution of the equation. An approximate bound on the
  maximum relative error in the computed solution is

                         EPS * norm(A)**2 / SEPD

  where EPS is the machine precision.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03QD.html000077500000000000000000000372241201767322700161100ustar00rootroot00000000000000 SB03QD - SLICOT Library Routine Documentation

SB03QD

Estimating conditioning and forward error bound for the solution of continuous-time Lyapunov equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the conditioning and compute an error bound on the
  solution of the real continuous-time Lyapunov matrix equation

      op(A)'*X + X*op(A) = scale*C

  where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The
  matrix A is N-by-N, the right hand side C and the solution X are
  N-by-N symmetric matrices, and scale is a given scale factor.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SCALE, SEP
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   T( LDT, * ), U( LDU, * ), X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'C':  Compute the reciprocal condition number only;
          = 'E':  Compute the error bound only;
          = 'B':  Compute both the reciprocal condition number and
                  the error bound.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
                  factors from the real Schur factorization of the
                  matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in T and U (if
                  LYAPUN = 'O').

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrix C is to be
          used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved in the iterative estimation process,
          as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X and C.  N >= 0.

  SCALE   (input) DOUBLE PRECISION
          The scale factor, scale, set by a Lyapunov solver.
          0 <= SCALE <= 1.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of
          this array must contain the original matrix A.
          If FACT = 'F' and LYAPUN = 'R', A is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N), if FACT = 'N' or  LYAPUN = 'O';
          LDA >= 1,        if FACT = 'F' and LYAPUN = 'R'.

  T       (input/output) DOUBLE PRECISION array, dimension
          (LDT,N)
          If FACT = 'F', then on entry the leading N-by-N upper
          Hessenberg part of this array must contain the upper
          quasi-triangular matrix T in Schur canonical form from a
          Schur factorization of A.
          If FACT = 'N', then this array need not be set on input.
          On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the
          leading N-by-N upper Hessenberg part of this array
          contains the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= MAX(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If LYAPUN = 'O' and FACT = 'F', then U is an input
          argument and on entry, the leading N-by-N part of this
          array must contain the orthogonal matrix U from a real
          Schur factorization of A.
          If LYAPUN = 'O' and FACT = 'N', then U is an output
          argument and on exit, if INFO = 0 or INFO = N+1, it
          contains the orthogonal N-by-N matrix from a real Schur
          factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix C of the original Lyapunov equation (with
          matrix A), if LYAPUN = 'O', or of the reduced Lyapunov
          equation (with matrix T), if LYAPUN = 'R'.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix C of the original Lyapunov equation (with
          matrix A), if LYAPUN = 'O', or of the reduced Lyapunov
          equation (with matrix T), if LYAPUN = 'R'.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,N).

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array must contain the
          symmetric solution matrix X of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= MAX(1,N).

  SEP     (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', the estimated quantity
          sep(op(A),-op(A)').
          If N = 0, or X = 0, or JOB = 'E', SEP is not referenced.

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', an estimate of the reciprocal
          condition number of the continuous-time Lyapunov equation.
          If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
          If JOB = 'E', RCOND is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'E' or JOB = 'B', an estimated forward error
          bound for the solution X. If XTRUE is the true solution,
          FERR bounds the magnitude of the largest entry in
          (X - XTRUE) divided by the magnitude of the largest entry
          in X.
          If N = 0 or X = 0, FERR is set to 0.
          If JOB = 'C', FERR is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          If JOB = 'C', then
          LDWORK >= MAX(1,2*N*N),         if FACT = 'F';
          LDWORK >= MAX(1,2*N*N,5*N),     if FACT = 'N'.
          If JOB = 'E', or JOB = 'B', and LYAPUN  = 'O', then
          LDWORK >= MAX(1,3*N*N),         if FACT = 'F';
          LDWORK >= MAX(1,3*N*N,5*N),     if FACT = 'N'.
          If JOB = 'E', or JOB = 'B', and LYAPUN  = 'R', then
          LDWORK >= MAX(1,3*N*N+N-1),     if FACT = 'F';
          LDWORK >= MAX(1,3*N*N+N-1,5*N), if FACT = 'N'.
          For optimum performance LDWORK should sometimes be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, i <= N, the QR algorithm failed to
                complete the reduction to Schur canonical form (see
                LAPACK Library routine DGEES); on exit, the matrix
                T(i+1:N,i+1:N) contains the partially converged
                Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N)
                contain the real and imaginary parts, respectively,
                of the converged eigenvalues; this error is unlikely
                to appear;
          = N+1:  if the matrices T and -T' have common or very
                close eigenvalues; perturbed values were used to
                solve Lyapunov equations, but the matrix T, if given
                (for FACT = 'F'), is unchanged.
Method 
  The condition number of the continuous-time Lyapunov equation is
  estimated as

  cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X),

  where Omega and Theta are linear operators defined by

  Omega(W) = op(A)'*W + W*op(A),
  Theta(W) = inv(Omega(op(W)'*X + X*op(W))).

  The routine estimates the quantities

  sep(op(A),-op(A)') = 1 / norm(inv(Omega))

  and norm(Theta) using 1-norm condition estimators.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [1].
References 
  [1] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
  The accuracy of the estimates obtained depends on the solution
  accuracy and on the properties of the 1-norm estimator.
Further Comments 
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
  When SEP is computed and it is zero, the routine returns
  immediately, with RCOND and FERR (if requested) set to 0 and 1,
  respectively. In this case, the equation is singular.
Example

Program Text 

*     SB03QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, 3*NMAX*NMAX + NMAX - 1,
     $                                    5*NMAX ) )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SCALE, SEP
      INTEGER          I, INFO1, INFO2, J, N
      CHARACTER*1      DICO, FACT, JOB, LYAPUN, TRANA, TRANAT, UPLO
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DLACPY, MA02ED, MB01RU, SB03MD, SB03QD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      DICO = 'C'
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
         CALL DLACPY( 'Full', N, N, C, LDC, X, LDX )
*        Solve the continuous-time Lyapunov matrix equation.
         CALL SB03MD( DICO, 'X', FACT, TRANA, N, T, LDT, U, LDU, X, LDX,
     $                SCALE, SEP, FERR, DWORK(1), DWORK(N+1), IWORK,
     $                DWORK(2*N+1), LDWORK-2*N, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N )
   10       CONTINUE
            IF ( LSAME( LYAPUN, 'R' ) ) THEN
               IF( LSAME( TRANA, 'N' )  ) THEN
                  TRANAT = 'T'
               ELSE
                  TRANAT = 'N'
               END IF
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX,
     $                      U, LDU, X, LDX, DWORK, N*N, INFO2 )
               CALL MA02ED( UPLO, N, X, LDX )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, C, LDC,
     $                      U, LDU, C, LDC, DWORK, N*N, INFO2 )
            END IF
*           Estimate the condition and error bound on the solution.
            CALL SB03QD( JOB, 'F', TRANA, UPLO, LYAPUN, N, SCALE, A,
     $                   LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP,
     $                   RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            ELSE
               WRITE ( NOUT, FMT = 99993 ) SCALE
               WRITE ( NOUT, FMT = 99992 ) SEP
               WRITE ( NOUT, FMT = 99991 ) RCOND
               WRITE ( NOUT, FMT = 99990 ) FERR
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03MD =',I2)
99997 FORMAT (' INFO on exit from SB03QD =',I2)
99996 FORMAT (' The solution matrix X is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' Scaling factor = ',F8.4)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END
Program Data 
 SB03QD EXAMPLE PROGRAM DATA
   3     B     N     N     U     O
   3.0   1.0   1.0
   1.0   3.0   0.0
   0.0   0.0   3.0
  25.0  24.0  15.0
  24.0  32.0   8.0
  15.0   8.0  40.0
Program Results 
 SB03QD EXAMPLE PROGRAM RESULTS

 The solution matrix X is
   3.2604   2.7187   1.8616
   2.7187   4.4271   0.5699
   1.8616   0.5699   6.0461

 Scaling factor =   1.0000

 Estimated separation =   4.9068

 Estimated reciprocal condition number =   0.3611

 Estimated error bound =   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03QX.html000077500000000000000000000151001201767322700161210ustar00rootroot00000000000000 SB03QX - SLICOT Library Routine Documentation

SB03QX

Estimating a forward error bound for the solution of a continuous-time Lyapunov equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate a forward error bound for the solution X of a real
  continuous-time Lyapunov matrix equation,

         op(A)'*X + X*op(A) = C,

  where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The
  matrix A, the right hand side C, and the solution X are N-by-N.
  An absolute residual matrix, which takes into account the rounding
  errors in forming it, is given in the array R.
Specification 
      SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU,
     $                   R, LDR, FERR, IWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDR, LDT, LDU, LDWORK, N
      DOUBLE PRECISION   FERR, XANORM
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   DWORK( * ), R( LDR, * ), T( LDT, * ),
     $                   U( LDU, * )
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrix R is to be
          used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved, as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and R.  N >= 0.

  XANORM  (input) DOUBLE PRECISION
          The absolute (maximal) norm of the symmetric solution
          matrix X of the Lyapunov equation.  XANORM >= 0.

  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  U       (input) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array must contain the
          orthogonal matrix U from a real Schur factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
          On entry, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the absolute residual matrix R, with
          bounds on rounding errors added.
          On entry, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the absolute residual matrix R, with
          bounds on rounding errors added.
          On exit, the leading N-by-N part of this array contains
          the symmetric absolute residual matrix R (with bounds on
          rounding errors added), fully stored.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  FERR    (output) DOUBLE PRECISION
          An estimated forward error bound for the solution X.
          If XTRUE is the true solution, FERR bounds the magnitude
          of the largest entry in (X - XTRUE) divided by the
          magnitude of the largest entry in X.
          If N = 0 or XANORM = 0, FERR is set to 0, without any
          calculations.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 2*N*N.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = N+1:  if the matrices T and -T' have common or very
                close eigenvalues; perturbed values were used to
                solve Lyapunov equations (but the matrix T is
                unchanged).
Method 
  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [1], based on the 1-norm estimator
  in [2].
References 
  [1] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.

  [2] Higham, N.J.
      FORTRAN codes for estimating the one-norm of a real or
      complex matrix, with applications to condition estimation.
      ACM Trans. Math. Softw., 14, pp. 381-396, 1988.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
  The routine can be also used as a final step in estimating a
  forward error bound for the solution of a continuous-time
  algebraic matrix Riccati equation.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03QY.html000077500000000000000000000154001201767322700161250ustar00rootroot00000000000000 SB03QY - SLICOT Library Routine Documentation

SB03QY

Estimating separation between op(A) and -op(A)' and 1-norm of Theta operator for a continuous-time Lyapunov equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the separation between the matrices op(A) and -op(A)',

  sep(op(A),-op(A)') = min norm(op(A)'*X + X*op(A))/norm(X)
                     = 1 / norm(inv(Omega))

  and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and
  Omega and Theta are linear operators associated to the real
  continuous-time Lyapunov matrix equation

         op(A)'*X + X*op(A) = C,

  defined by

  Omega(W) = op(A)'*W + W*op(A),
  Theta(W) = inv(Omega(op(W)'*X + X*op(W))).

  The 1-norm condition estimators are used.
Specification 
      SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX,
     $                   SEP, THNORM, IWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          JOB, LYAPUN, TRANA
      INTEGER            INFO, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   SEP, THNORM
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   DWORK( * ), T( LDT, * ), U( LDU, * ),
     $                   X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'S':  Compute the separation only;
          = 'T':  Compute the norm of Theta only;
          = 'B':  Compute both the separation and the norm of Theta.

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved, as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and X.  N >= 0.

  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  U       (input) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array must contain the
          orthogonal matrix U from a real Schur factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array must contain the
          solution matrix X of the Lyapunov equation (reduced
          Lyapunov equation if LYAPUN = 'R').
          If JOB = 'S', the array X is not referenced.

  LDX     INTEGER
          The leading dimension of array X.
          LDX >= 1,        if JOB = 'S';
          LDX >= MAX(1,N), if JOB = 'T' or 'B'.

  SEP     (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'B', and INFO >= 0, SEP contains the
          estimated separation of the matrices op(A) and -op(A)'.
          If JOB = 'T' or N = 0, SEP is not referenced.

  THNORM  (output) DOUBLE PRECISION
          If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains
          the estimated 1-norm of operator Theta.
          If JOB = 'S' or N = 0, THNORM is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 2*N*N.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = N+1:  if the matrices T and -T' have common or very
                close eigenvalues; perturbed values were used to
                solve Lyapunov equations (but the matrix T is
                unchanged).
Method 
  SEP is defined as the separation of op(A) and -op(A)':

         sep( op(A), -op(A)' ) = sigma_min( K )

  where sigma_min(K) is the smallest singular value of the
  N*N-by-N*N matrix

     K = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ).

  I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker
  product. The routine estimates sigma_min(K) by the reciprocal of
  an estimate of the 1-norm of inverse(K), computed as suggested in
  [1]. This involves the solution of several continuous-time
  Lyapunov equations, either direct or transposed. The true
  reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by
  more than a factor of N.
  The 1-norm of Theta is estimated similarly.
References 
  [1] Higham, N.J.
      FORTRAN codes for estimating the one-norm of a real or
      complex matrix, with applications to condition estimation.
      ACM Trans. Math. Softw., 14, pp. 381-396, 1988.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  When SEP is zero, the routine returns immediately, with THNORM
  (if requested) not set. In this case, the equation is singular.
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03RD.html000077500000000000000000000214461201767322700161100ustar00rootroot00000000000000 SB03RD - SLICOT Library Routine Documentation

SB03RD

Solution of continuous-time Lyapunov equations and separation estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the real Lyapunov matrix equation

         op(A)'*X + X*op(A) = scale*C

  and/or estimate the separation between the matrices op(A) and
  -op(A)', where op(A) = A or A' (A**T) and C is symmetric (C = C').
  (A' denotes the transpose of the matrix A.) A is N-by-N, the right
  hand side C and the solution X are N-by-N, and scale is an output
  scale factor, set less than or equal to 1 to avoid overflow in X.
Specification 
      SUBROUTINE SB03RD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC,
     $                   SCALE, SEP, FERR, WR, WI, IWORK, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          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( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'X':  Compute the solution only;
          = 'S':  Compute the separation only;
          = 'B':  Compute both the solution and the separation.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, A and U contain the factors from the
                  real Schur factorization of the matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in A and U.

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, and C.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix A. If FACT = 'F', then A contains
          an upper quasi-triangular matrix in Schur canonical form.
          On exit, if INFO = 0 or INFO = N+1, the leading N-by-N
          part of this array contains the upper quasi-triangular
          matrix in Schur canonical form from the Shur factorization
          of A. The contents of array A is not modified if
          FACT = 'F'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If FACT = 'F', then U is an input argument and on entry
          it must contain the orthogonal matrix U from the real
          Schur factorization of A.
          If FACT = 'N', then U is an output argument and on exit,
          if INFO = 0 or INFO = N+1, it contains the orthogonal
          N-by-N matrix from the real Schur factorization of A.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry with JOB = 'X' or 'B', the leading N-by-N part of
          this array must contain the symmetric matrix C.
          On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1,
          the leading N-by-N part of C has been overwritten by the
          symmetric solution matrix X.
          If JOB = 'S', C is not referenced.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= 1,        if JOB = 'S';
          LDC >= MAX(1,N), otherwise.

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.

  SEP     (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP
          contains the estimated separation of the matrices op(A)
          and -op(A)'.
          If JOB = 'X' or N = 0, SEP is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains
          an estimated forward error bound for the solution X.
          If XTRUE is the true solution, FERR bounds the relative
          error in the computed solution, measured in the Frobenius
          norm:  norm(X - XTRUE)/norm(XTRUE).
          If JOB = 'X' or JOB = 'S', FERR is not referenced.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
          contain the real and imaginary parts, respectively, of the
          eigenvalues of A.
          If FACT = 'F', WR and WI are not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)
          This array is not referenced if JOB = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 1 and
          If JOB = 'X' then
             If FACT = 'F', LDWORK >= N*N;
             If FACT = 'N', LDWORK >= MAX(N*N,3*N).
          If JOB = 'S' or JOB = 'B' then
             If FACT = 'F', LDWORK >= 2*N*N;
             If FACT = 'N', LDWORK >= MAX(2*N*N,3*N).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, the QR algorithm failed to compute all
                the eigenvalues (see LAPACK Library routine DGEES);
                elements i+1:n of WR and WI contain eigenvalues
                which have converged, and A contains the partially
                converged Schur form;
          = N+1:  if the matrices A and -A' have common or very
                close eigenvalues; perturbed values were used to
                solve the equation (but the matrix A is unchanged).
Method 
  After reducing matrix A to real Schur canonical form (if needed),
  the Bartels-Stewart algorithm is used. A set of equivalent linear
  algebraic systems of equations of order at most four are formed
  and solved using Gaussian elimination with complete pivoting.
References 
  [1] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  SEP is defined as the separation of op(A) and -op(A)':

         sep( op(A), -op(A)' ) = sigma_min( T )

  where sigma_min(T) is the smallest singular value of the
  N*N-by-N*N matrix

     T = kprod( I(N), op(A)' ) + kprod( op(A), I(N) ).

  I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker
  product. The program estimates sigma_min(T) by the reciprocal of
  an estimate of the 1-norm of inverse(T). The true reciprocal
  1-norm of inverse(T) cannot differ from sigma_min(T) by more
  than a factor of N.

  When SEP is small, small changes in A, C can cause large changes
  in the solution of the equation. An approximate bound on the
  maximum relative error in the computed solution is

                         EPS * norm(A) / SEP

  where EPS is the machine precision.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03SD.html000077500000000000000000000372521201767322700161130ustar00rootroot00000000000000 SB03SD - SLICOT Library Routine Documentation

SB03SD

Estimating conditioning and forward error bound for the solution of discrete-time Lyapunov equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the conditioning and compute an error bound on the
  solution of the real discrete-time Lyapunov matrix equation

      op(A)'*X*op(A) - X = scale*C

  where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The
  matrix A is N-by-N, the right hand side C and the solution X are
  N-by-N symmetric matrices, and scale is a given scale factor.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SCALE, SEPD
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   T( LDT, * ), U( LDU, * ), X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'C':  Compute the reciprocal condition number only;
          = 'E':  Compute the error bound only;
          = 'B':  Compute both the reciprocal condition number and
                  the error bound.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
                  factors from the real Schur factorization of the
                  matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in T and U (if
                  LYAPUN = 'O').

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrix C is to be
          used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved in the iterative estimation process,
          as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X and C.  N >= 0.

  SCALE   (input) DOUBLE PRECISION
          The scale factor, scale, set by a Lyapunov solver.
          0 <= SCALE <= 1.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of
          this array must contain the original matrix A.
          If FACT = 'F' and LYAPUN = 'R', A is not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N), if FACT = 'N' or  LYAPUN = 'O';
          LDA >= 1,        if FACT = 'F' and LYAPUN = 'R'.

  T       (input/output) DOUBLE PRECISION array, dimension
          (LDT,N)
          If FACT = 'F', then on entry the leading N-by-N upper
          Hessenberg part of this array must contain the upper
          quasi-triangular matrix T in Schur canonical form from a
          Schur factorization of A.
          If FACT = 'N', then this array need not be set on input.
          On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the
          leading N-by-N upper Hessenberg part of this array
          contains the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= MAX(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If LYAPUN = 'O' and FACT = 'F', then U is an input
          argument and on entry, the leading N-by-N part of this
          array must contain the orthogonal matrix U from a real
          Schur factorization of A.
          If LYAPUN = 'O' and FACT = 'N', then U is an output
          argument and on exit, if INFO = 0 or INFO = N+1, it
          contains the orthogonal N-by-N matrix from a real Schur
          factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          If UPLO = 'U', the leading N-by-N upper triangular part of
          this array must contain the upper triangular part of the
          matrix C of the original Lyapunov equation (with
          matrix A), if LYAPUN = 'O', or of the reduced Lyapunov
          equation (with matrix T), if LYAPUN = 'R'.
          If UPLO = 'L', the leading N-by-N lower triangular part of
          this array must contain the lower triangular part of the
          matrix C of the original Lyapunov equation (with
          matrix A), if LYAPUN = 'O', or of the reduced Lyapunov
          equation (with matrix T), if LYAPUN = 'R'.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,N).

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array must contain the
          symmetric solution matrix X of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.
          The array X is modified internally, but restored on exit.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= MAX(1,N).

  SEPD    (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', the estimated quantity
          sepd(op(A),op(A)').
          If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced.

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'B', an estimate of the reciprocal
          condition number of the discrete-time Lyapunov equation.
          If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
          If JOB = 'E', RCOND is not referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'E' or JOB = 'B', an estimated forward error
          bound for the solution X. If XTRUE is the true solution,
          FERR bounds the magnitude of the largest entry in
          (X - XTRUE) divided by the magnitude of the largest entry
          in X.
          If N = 0 or X = 0, FERR is set to 0.
          If JOB = 'C', FERR is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 1,                            if N = 0; else,
          LDWORK >= MAX(3,2*N*N) + N*N,           if JOB  = 'C',
                                                     FACT = 'F';
          LDWORK >= MAX(MAX(3,2*N*N) + N*N, 5*N), if JOB  = 'C',
                                                     FACT = 'N';
          LDWORK >= MAX(3,2*N*N) + N*N + 2*N,     if JOB  = 'E', or
                                                     JOB  = 'B'.
          For optimum performance LDWORK should sometimes be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, i <= N, the QR algorithm failed to
                complete the reduction to Schur canonical form (see
                LAPACK Library routine DGEES); on exit, the matrix
                T(i+1:N,i+1:N) contains the partially converged
                Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N)
                contain the real and imaginary parts, respectively,
                of the converged eigenvalues; this error is unlikely
                to appear;
          = N+1:  if the matrix T has almost reciprocal eigenvalues;
                perturbed values were used to solve Lyapunov
                equations, but the matrix T, if given (for
                FACT = 'F'), is unchanged.
Method 
  The condition number of the discrete-time Lyapunov equation is
  estimated as

  cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X),

  where Omega and Theta are linear operators defined by

  Omega(W) = op(A)'*W*op(A) - W,
  Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))).

  The routine estimates the quantities

  sepd(op(A),op(A)') = 1 / norm(inv(Omega))

  and norm(Theta) using 1-norm condition estimators.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [1].
References 
  [1] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
  The accuracy of the estimates obtained depends on the solution
  accuracy and on the properties of the 1-norm estimator.
Further Comments 
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
  When SEPD is computed and it is zero, the routine returns
  immediately, with RCOND and FERR (if requested) set to 0 and 1,
  respectively. In this case, the equation is singular.
Example

Program Text 

*     SB03SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 3, 2*NMAX*NMAX ) +
     $                                 NMAX*NMAX + 2*NMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SCALE, SEPD
      INTEGER          I, INFO1, INFO2, J, N
      CHARACTER*1      DICO, FACT, JOB, LYAPUN, TRANA, TRANAT, UPLO
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DLACPY, MA02ED, MB01RU, SB03MD, SB03SD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      DICO = 'D'
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
         CALL DLACPY( 'Full', N, N, C, LDC, X, LDX )
*        Solve the discrete-time Lyapunov matrix equation.
         CALL SB03MD( DICO, 'X', FACT, TRANA, N, T, LDT, U, LDU, X, LDX,
     $                SCALE, SEPD, FERR, DWORK(1), DWORK(N+1), IWORK,
     $                DWORK(2*N+1), LDWORK-2*N, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N )
   10       CONTINUE
            IF ( LSAME( LYAPUN, 'R' ) ) THEN
               IF( LSAME( TRANA, 'N' )  ) THEN
                  TRANAT = 'T'
               ELSE
                  TRANAT = 'N'
               END IF
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX,
     $                      U, LDU, X, LDX, DWORK, N*N, INFO2 )
               CALL MA02ED( UPLO, N, X, LDX )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, C, LDC,
     $                      U, LDU, C, LDC, DWORK, N*N, INFO2 )
            END IF
*           Estimate the condition and error bound on the solution.
            CALL SB03SD( JOB, 'F', TRANA, UPLO, LYAPUN, N, SCALE, A,
     $                   LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD,
     $                   RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            ELSE
               WRITE ( NOUT, FMT = 99993 ) SCALE
               WRITE ( NOUT, FMT = 99992 ) SEPD
               WRITE ( NOUT, FMT = 99991 ) RCOND
               WRITE ( NOUT, FMT = 99990 ) FERR
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03MD =',I2)
99997 FORMAT (' INFO on exit from SB03SD =',I2)
99996 FORMAT (' The solution matrix X is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' Scaling factor = ',F8.4)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END
Program Data 
 SB03SD EXAMPLE PROGRAM DATA
   3     B     N     N     U     O
   3.0   1.0   1.0
   1.0   3.0   0.0
   0.0   0.0   3.0
  25.0  24.0  15.0
  24.0  32.0   8.0
  15.0   8.0  40.0
Program Results 
 SB03SD EXAMPLE PROGRAM RESULTS

 The solution matrix X is
   2.0000   1.0000   1.0000
   1.0000   3.0000   0.0000
   1.0000   0.0000   4.0000

 Scaling factor =   1.0000

 Estimated separation =   5.2302

 Estimated reciprocal condition number =   0.1832

 Estimated error bound =   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03SX.html000077500000000000000000000151351201767322700161330ustar00rootroot00000000000000 SB03SX - SLICOT Library Routine Documentation

SB03SX

Estimating a forward error bound for the solution of a discrete-time Lyapunov equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate a forward error bound for the solution X of a real
  discrete-time Lyapunov matrix equation,

         op(A)'*X*op(A) - X = C,

  where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The
  matrix A, the right hand side C, and the solution X are N-by-N.
  An absolute residual matrix, which takes into account the rounding
  errors in forming it, is given in the array R.
Specification 
      SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU,
     $                   R, LDR, FERR, IWORK, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDR, LDT, LDU, LDWORK, N
      DOUBLE PRECISION   FERR, XANORM
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   DWORK( * ), R( LDR, * ), T( LDT, * ),
     $                   U( LDU, * )
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrix R is to be
          used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved, as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and R.  N >= 0.

  XANORM  (input) DOUBLE PRECISION
          The absolute (maximal) norm of the symmetric solution
          matrix X of the Lyapunov equation.  XANORM >= 0.

  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  U       (input) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array must contain the
          orthogonal matrix U from a real Schur factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
          On entry, if UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the absolute residual matrix R, with
          bounds on rounding errors added.
          On entry, if UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the absolute residual matrix R, with
          bounds on rounding errors added.
          On exit, the leading N-by-N part of this array contains
          the symmetric absolute residual matrix R (with bounds on
          rounding errors added), fully stored.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,N).

  FERR    (output) DOUBLE PRECISION
          An estimated forward error bound for the solution X.
          If XTRUE is the true solution, FERR bounds the magnitude
          of the largest entry in (X - XTRUE) divided by the
          magnitude of the largest entry in X.
          If N = 0 or XANORM = 0, FERR is set to 0, without any
          calculations.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 0,            if N = 0;
          LDWORK >= MAX(3,2*N*N), if N > 0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = N+1:  if T has almost reciprocal eigenvalues; perturbed
                values were used to solve Lyapunov equations (but
                the matrix T is unchanged).
Method 
  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [1], based on the 1-norm estimator
  in [2].
References 
  [1] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.

  [2] Higham, N.J.
      FORTRAN codes for estimating the one-norm of a real or
      complex matrix, with applications to condition estimation.
      ACM Trans. Math. Softw., 14, pp. 381-396, 1988.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
  The routine can be also used as a final step in estimating a
  forward error bound for the solution of a discrete-time algebraic
  matrix Riccati equation.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03SY.html000077500000000000000000000154521201767322700161360ustar00rootroot00000000000000 SB03SY - SLICOT Library Routine Documentation

SB03SY

Estimating separation between op(A) and op(A)' and 1-norm of Theta operator for a discrete-time Lyapunov equation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To estimate the "separation" between the matrices op(A) and
  op(A)',

  sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X)
                     = 1 / norm(inv(Omega))

  and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and
  Omega and Theta are linear operators associated to the real
  discrete-time Lyapunov matrix equation

         op(A)'*X*op(A) - X = C,

  defined by

  Omega(W) = op(A)'*W*op(A) - W,
  Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))).

  The 1-norm condition estimators are used.
Specification 
      SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA,
     $                   LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER          JOB, LYAPUN, TRANA
      INTEGER            INFO, LDT, LDU, LDWORK, LDXA, N
      DOUBLE PRECISION   SEPD, THNORM
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   DWORK( * ), T( LDT, * ), U( LDU, * ),
     $                   XA( LDXA, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'S':  Compute the separation only;
          = 'T':  Compute the norm of Theta only;
          = 'B':  Compute both the separation and the norm of Theta.

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  LYAPUN  CHARACTER*1
          Specifies whether or not the original Lyapunov equations
          should be solved, as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A and X.  N >= 0.

  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,N).

  U       (input) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array must contain the
          orthogonal matrix U from a real Schur factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  XA      (input) DOUBLE PRECISION array, dimension (LDXA,N)
          The leading N-by-N part of this array must contain the
          matrix product X*op(A), if LYAPUN = 'O', or U'*X*U*op(T),
          if LYAPUN = 'R', in the Lyapunov equation.
          If JOB = 'S', the array XA is not referenced.

  LDXA    INTEGER
          The leading dimension of array XA.
          LDXA >= 1,        if JOB = 'S';
          LDXA >= MAX(1,N), if JOB = 'T' or 'B'.

  SEPD    (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'B', and INFO >= 0, SEPD contains
          the estimated quantity sepd(op(A),op(A)').
          If JOB = 'T' or N = 0, SEPD is not referenced.

  THNORM  (output) DOUBLE PRECISION
          If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains
          the estimated 1-norm of operator Theta.
          If JOB = 'S' or N = 0, THNORM is not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 0,            if N = 0;
          LDWORK >= MAX(3,2*N*N), if N > 0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = N+1:  if T has (almost) reciprocal eigenvalues;
                perturbed values were used to solve Lyapunov
                equations (but the matrix T is unchanged).
Method 
  SEPD is defined as

         sepd( op(A), op(A)' ) = sigma_min( K )

  where sigma_min(K) is the smallest singular value of the
  N*N-by-N*N matrix

     K = kprod( op(A)', op(A)' ) - I(N**2).

  I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the
  Kronecker product. The routine estimates sigma_min(K) by the
  reciprocal of an estimate of the 1-norm of inverse(K), computed as
  suggested in [1]. This involves the solution of several discrete-
  time Lyapunov equations, either direct or transposed. The true
  reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by
  more than a factor of N.
  The 1-norm of Theta is estimated similarly.
References 
  [1] Higham, N.J.
      FORTRAN codes for estimating the one-norm of a real or
      complex matrix, with applications to condition estimation.
      ACM Trans. Math. Softw., 14, pp. 381-396, 1988.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  When SEPD is zero, the routine returns immediately, with THNORM
  (if requested) not set. In this case, the equation is singular.
  The option LYAPUN = 'R' may occasionally produce slightly worse
  or better estimates, and it is much faster than the option 'O'.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB03TD.html000077500000000000000000000444551201767322700161170ustar00rootroot00000000000000 SB03TD - SLICOT Library Routine Documentation

SB03TD

Solution of continuous-time Lyapunov equations and condition and error bounds estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the real continuous-time Lyapunov matrix equation

         op(A)'*X + X*op(A) = scale*C,

  estimate the conditioning, and compute an error bound on the
  solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N,
  the right hand side C and the solution X are N-by-N symmetric
  matrices (C = C', X = X'), and scale is an output scale factor,
  set less than or equal to 1 to avoid overflow in X.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SCALE, SEP
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   T( LDT, * ), U( LDU, * ), WI( * ), WR( * ),
     $                   X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'X':  Compute the solution only;
          = 'S':  Compute the separation only;
          = 'C':  Compute the reciprocal condition number only;
          = 'E':  Compute the error bound only;
          = 'A':  Compute all: the solution, separation, reciprocal
                  condition number, and the error bound.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
                  factors from the real Schur factorization of the
                  matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in T and U (if
                  LYAPUN = 'O').

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrix C is to be
          used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original or "reduced"
          Lyapunov equations should be solved, as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
                  This means that a real Schur form T of A appears
                  in the equation, instead of A.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, and C.  N >= 0.

  SCALE   (input or output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'E', SCALE is an input argument:
          the scale factor, set by a Lyapunov solver.
          0 <= SCALE <= 1.
          If JOB = 'X' or JOB = 'A', SCALE is an output argument:
          the scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
          If JOB = 'S', this argument is not used.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the
          leading N-by-N part of this array must contain the
          original matrix A.
          If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is
          not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and
                                            JOB <> 'X';
          LDA >= 1,        otherwise.

  T       (input/output) DOUBLE PRECISION array, dimension
          (LDT,N)
          If FACT = 'F', then on entry the leading N-by-N upper
          Hessenberg part of this array must contain the upper
          quasi-triangular matrix T in Schur canonical form from a
          Schur factorization of A.
          If FACT = 'N', then this array need not be set on input.
          On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the
          leading N-by-N upper Hessenberg part of this array
          contains the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.
          The contents of array T is not modified if FACT = 'F'.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= MAX(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If LYAPUN = 'O' and FACT = 'F', then U is an input
          argument and on entry, the leading N-by-N part of this
          array must contain the orthogonal matrix U from a real
          Schur factorization of A.
          If LYAPUN = 'O' and FACT = 'N', then U is an output
          argument and on exit, if INFO = 0 or INFO = N+1, it
          contains the orthogonal N-by-N matrix from a real Schur
          factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the matrix C of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.
          If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the matrix C of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.
          The remaining strictly triangular part of this array is
          used as workspace.
          If JOB = 'X', then this array may be identified with X
          in the call of this routine.
          If JOB = 'S', the array C is not referenced.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= 1,        if JOB = 'S';
          LDC >= MAX(1,N), otherwise.

  X       (input or output) DOUBLE PRECISION array, dimension
          (LDX,N)
          If JOB = 'C' or 'E', then X is an input argument and on
          entry, the leading N-by-N part of this array must contain
          the symmetric solution matrix X of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.
          If JOB = 'X' or 'A', then X is an output argument and on
          exit, if INFO = 0 or INFO = N+1, the leading N-by-N part
          of this array contains the symmetric solution matrix X of
          of the original Lyapunov equation (with matrix A), if
          LYAPUN = 'O', or of the reduced Lyapunov equation (with
          matrix T), if LYAPUN = 'R'.
          If JOB = 'S', the array X is not referenced.

  LDX     INTEGER
          The leading dimension of the array X.
          LDX >= 1,        if JOB = 'S';
          LDX >= MAX(1,N), otherwise.

  SEP     (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or
          INFO = N+1, SEP contains the estimated separation of the
          matrices op(A) and -op(A)', sep(op(A),-op(A)').
          If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEP is not
          referenced.

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'A', an estimate of the reciprocal
          condition number of the continuous-time Lyapunov equation.
          If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
          If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not
          referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1,
          FERR contains an estimated forward error bound for the
          solution X. If XTRUE is the true solution, FERR bounds the
          relative error in the computed solution, measured in the
          Frobenius norm:  norm(X - XTRUE)/norm(XTRUE).
          If N = 0 or X = 0, FERR is set to 0.
          If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not
          referenced.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
          contain the real and imaginary parts, respectively, of the
          eigenvalues of A.
          If FACT = 'F', WR and WI are not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)
          This array is not referenced if JOB = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          If JOB = 'X', then
          LDWORK >= MAX(1,N*N),           if FACT = 'F';
          LDWORK >= MAX(1,MAX(N*N,3*N)),  if FACT = 'N'.
          If JOB = 'S' or JOB = 'C', then
          LDWORK >= MAX(1,2*N*N),         if FACT = 'F';
          LDWORK >= MAX(1,2*N*N,3*N),     if FACT = 'N'.
          If JOB = 'E', or JOB = 'A', and LYAPUN  = 'O', then
          LDWORK >= MAX(1,3*N*N);
          If JOB = 'E', or JOB = 'A', and LYAPUN  = 'R', then
          LDWORK >= MAX(1,3*N*N+N-1).
          For optimum performance LDWORK should sometimes be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, i <= N, the QR algorithm failed to
                complete the reduction to Schur canonical form (see
                LAPACK Library routine DGEES); on exit, the matrix
                T(i+1:N,i+1:N) contains the partially converged
                Schur form, and the elements i+1:n of WR and WI
                contain the real and imaginary parts, respectively,
                of the converged eigenvalues; this error is unlikely
                to appear;
          = N+1:  if the matrices T and -T' have common or very
                close eigenvalues; perturbed values were used to
                solve Lyapunov equations, but the matrix T, if given
                (for FACT = 'F'), is unchanged.
Method 
  After reducing matrix A to real Schur canonical form (if needed),
  the Bartels-Stewart algorithm is used. A set of equivalent linear
  algebraic systems of equations of order at most four are formed
  and solved using Gaussian elimination with complete pivoting.

  The condition number of the continuous-time Lyapunov equation is
  estimated as

  cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X),

  where Omega and Theta are linear operators defined by

  Omega(W) = op(A)'*W + W*op(A),
  Theta(W) = inv(Omega(op(W)'*X + X*op(W))).

  The routine estimates the quantities

  sep(op(A),-op(A)') = 1 / norm(inv(Omega))

  and norm(Theta) using 1-norm condition estimators.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [2].
References 
  [1] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
  The accuracy of the estimates obtained depends on the solution
  accuracy and on the properties of the 1-norm estimator.
Further Comments 
  The separation of op(A) and -op(A)' can also be defined as

         sep( op(A), -op(A)' ) = sigma_min( T ),

  where sigma_min(T) is the smallest singular value of the
  N*N-by-N*N matrix

     T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ).

  I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker
  product. The routine estimates sigma_min(T) by the reciprocal of
  an estimate of the 1-norm of inverse(T). The true reciprocal
  1-norm of inverse(T) cannot differ from sigma_min(T) by more
  than a factor of N.
Example

Program Text 

*     SB03TD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, 3*NMAX*NMAX + NMAX - 1 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SCALE, SEP
      INTEGER          I, INFO, J, N
      CHARACTER*1      DICO, FACT, JOB, LYAPUN, TRANA, UPLO
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB03TD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      DICO = 'C'
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $                               READ ( NIN, FMT = * ) SCALE
         IF ( LSAME( FACT, 'N' ) .OR. ( LSAME( LYAPUN, 'O' ) .AND.
     $                             .NOT.LSAME( JOB, 'X') ) )
     $      READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N )
            IF ( LSAME( LYAPUN, 'O' ) )
     $         READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N )
         END IF
         IF ( .NOT.LSAME( JOB, 'S' ) )
     $      READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $      READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N )
*        Solve the continuous-time Lyapunov matrix equation and/or
*        estimate the condition and error bound on the solution.
         CALL SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, LDA,
     $                T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, FERR,
     $                DWORK(1), DWORK(N+1), IWORK, DWORK(2*N+1),
     $                LDWORK-2*N, INFO )
*
         IF ( INFO.EQ.0 ) THEN
            IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99996 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99993 ) SCALE
            END IF
            IF ( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'C' )
     $                             .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99992 ) SEP
            IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99991 ) RCOND
            IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99990 ) FERR
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03TD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03TD =',I2)
99996 FORMAT (' The solution matrix X is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' Scaling factor = ',F8.4)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END
Program Data 
 SB03TD EXAMPLE PROGRAM DATA
   3     A     N     N     U     O
   3.0   1.0   1.0
   1.0   3.0   0.0
   0.0   0.0   3.0
  25.0  24.0  15.0
  24.0  32.0   8.0
  15.0   8.0  40.0
Program Results 
 SB03TD EXAMPLE PROGRAM RESULTS

 The solution matrix X is
   3.2604   2.7187   1.8616
   2.7187   4.4271   0.5699
   1.8616   0.5699   6.0461

 Scaling factor =   1.0000

 Estimated separation =   4.9068

 Estimated reciprocal condition number =   0.3611

 Estimated error bound =   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB03UD.html000077500000000000000000000446111201767322700161120ustar00rootroot00000000000000 SB03UD - SLICOT Library Routine Documentation

SB03UD

Solution of discrete-time Lyapunov equations and condition and error bounds estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve the real discrete-time Lyapunov matrix equation

         op(A)'*X*op(A) - X = scale*C,

  estimate the conditioning, and compute an error bound on the
  solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N,
  the right hand side C and the solution X are N-by-N symmetric
  matrices (C = C', X = X'), and scale is an output scale factor,
  set less than or equal to 1 to avoid overflow in X.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SCALE, SEPD
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   T( LDT, * ), U( LDU, * ), WI( * ), WR( * ),
     $                   X( LDX, * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Specifies the computation to be performed, as follows:
          = 'X':  Compute the solution only;
          = 'S':  Compute the separation only;
          = 'C':  Compute the reciprocal condition number only;
          = 'E':  Compute the error bound only;
          = 'A':  Compute all: the solution, separation, reciprocal
                  condition number, and the error bound.

  FACT    CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
                  factors from the real Schur factorization of the
                  matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in T and U (if
                  LYAPUN = 'O').

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  UPLO    CHARACTER*1
          Specifies which part of the symmetric matrix C is to be
          used, as follows:
          = 'U':  Upper triangular part;
          = 'L':  Lower triangular part.

  LYAPUN  CHARACTER*1
          Specifies whether or not the original or "reduced"
          Lyapunov equations should be solved, as follows:
          = 'O':  Solve the original Lyapunov equations, updating
                  the right-hand sides and solutions with the
                  matrix U, e.g., X <-- U'*X*U;
          = 'R':  Solve reduced Lyapunov equations only, without
                  updating the right-hand sides and solutions.
                  This means that a real Schur form T of A appears
                  in the equation, instead of A.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, X, and C.  N >= 0.

  SCALE   (input or output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'E', SCALE is an input argument:
          the scale factor, set by a Lyapunov solver.
          0 <= SCALE <= 1.
          If JOB = 'X' or JOB = 'A', SCALE is an output argument:
          the scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
          If JOB = 'S', this argument is not used.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the
          leading N-by-N part of this array must contain the
          original matrix A.
          If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is
          not referenced.

  LDA     INTEGER
          The leading dimension of the array A.
          LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and
                                            JOB <> 'X';
          LDA >= 1,        otherwise.

  T       (input/output) DOUBLE PRECISION array, dimension
          (LDT,N)
          If FACT = 'F', then on entry the leading N-by-N upper
          Hessenberg part of this array must contain the upper
          quasi-triangular matrix T in Schur canonical form from a
          Schur factorization of A.
          If FACT = 'N', then this array need not be set on input.
          On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the
          leading N-by-N upper Hessenberg part of this array
          contains the upper quasi-triangular matrix T in Schur
          canonical form from a Schur factorization of A.
          The contents of array T is not modified if FACT = 'F'.

  LDT     INTEGER
          The leading dimension of the array T.  LDT >= MAX(1,N).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,N)
          If LYAPUN = 'O' and FACT = 'F', then U is an input
          argument and on entry, the leading N-by-N part of this
          array must contain the orthogonal matrix U from a real
          Schur factorization of A.
          If LYAPUN = 'O' and FACT = 'N', then U is an output
          argument and on exit, if INFO = 0 or INFO = N+1, it
          contains the orthogonal N-by-N matrix from a real Schur
          factorization of A.
          If LYAPUN = 'R', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of the array U.
          LDU >= 1,        if LYAPUN = 'R';
          LDU >= MAX(1,N), if LYAPUN = 'O'.

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper
          triangular part of this array must contain the upper
          triangular part of the matrix C of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.
          If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower
          triangular part of this array must contain the lower
          triangular part of the matrix C of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.
          The remaining strictly triangular part of this array is
          used as workspace.
          If JOB = 'X', then this array may be identified with X
          in the call of this routine.
          If JOB = 'S', the array C is not referenced.

  LDC     INTEGER
          The leading dimension of the array C.
          LDC >= 1,        if JOB = 'S';
          LDC >= MAX(1,N), otherwise.

  X       (input or output) DOUBLE PRECISION array, dimension
          (LDX,N)
          If JOB = 'C' or 'E', then X is an input argument and on
          entry, the leading N-by-N part of this array must contain
          the symmetric solution matrix X of the original Lyapunov
          equation (with matrix A), if LYAPUN = 'O', or of the
          reduced Lyapunov equation (with matrix T), if
          LYAPUN = 'R'.
          If JOB = 'X' or 'A', then X is an output argument and on
          exit, if INFO = 0 or INFO = N+1, the leading N-by-N part
          of this array contains the symmetric solution matrix X of
          of the original Lyapunov equation (with matrix A), if
          LYAPUN = 'O', or of the reduced Lyapunov equation (with
          matrix T), if LYAPUN = 'R'.
          If JOB = 'S', the array X is not referenced.

  LDX     INTEGER
          The leading dimension of the array X.
          LDX >= 1,        if JOB = 'S';
          LDX >= MAX(1,N), otherwise.

  SEPD    (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or
          INFO = N+1, SEPD contains the estimated separation of the
          matrices op(A) and op(A)', sepd(op(A),op(A)').
          If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEPD is not
          referenced.

  RCOND   (output) DOUBLE PRECISION
          If JOB = 'C' or JOB = 'A', an estimate of the reciprocal
          condition number of the continuous-time Lyapunov equation.
          If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
          If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not
          referenced.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1,
          FERR contains an estimated forward error bound for the
          solution X. If XTRUE is the true solution, FERR bounds the
          relative error in the computed solution, measured in the
          Frobenius norm:  norm(X - XTRUE)/norm(XTRUE).
          If N = 0 or X = 0, FERR is set to 0.
          If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not
          referenced.

  WR      (output) DOUBLE PRECISION array, dimension (N)
  WI      (output) DOUBLE PRECISION array, dimension (N)
          If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
          contain the real and imaginary parts, respectively, of the
          eigenvalues of A.
          If FACT = 'F', WR and WI are not referenced.
Workspace 
  IWORK   INTEGER array, dimension (N*N)
          This array is not referenced if JOB = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
          optimal value of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          If JOB = 'X', then
          LDWORK >= MAX(1,N*N,2*N),       if FACT = 'F';
          LDWORK >= MAX(1,N*N,3*N),       if FACT = 'N'.
          If JOB = 'S', then
          LDWORK >= MAX(3,2*N*N).
          If JOB = 'C', then
          LDWORK >= MAX(3,2*N*N) + N*N.
          If JOB = 'E', or JOB = 'A', then
          LDWORK >= MAX(3,2*N*N) + N*N + 2*N.
          For optimum performance LDWORK should sometimes be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, i <= N, the QR algorithm failed to
                complete the reduction to Schur canonical form (see
                LAPACK Library routine DGEES); on exit, the matrix
                T(i+1:N,i+1:N) contains the partially converged
                Schur form, and the elements i+1:n of WR and WI
                contain the real and imaginary parts, respectively,
                of the converged eigenvalues; this error is unlikely
                to appear;
          = N+1:  if the matrix T has almost reciprocal eigenvalues;
                perturbed values were used to solve Lyapunov
                equations, but the matrix T, if given (for
                FACT = 'F'), is unchanged.
Method 
  After reducing matrix A to real Schur canonical form (if needed),
  a discrete-time version of the Bartels-Stewart algorithm is used.
  A set of equivalent linear algebraic systems of equations of order
  at most four are formed and solved using Gaussian elimination with
  complete pivoting.

  The condition number of the discrete-time Lyapunov equation is
  estimated as

  cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X),

  where Omega and Theta are linear operators defined by

  Omega(W) = op(A)'*W*op(A) - W,
  Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))).

  The routine estimates the quantities

  sepd(op(A),op(A)') = 1 / norm(inv(Omega))

  and norm(Theta) using 1-norm condition estimators.

  The forward error bound is estimated using a practical error bound
  similar to the one proposed in [3].
References 
  [1] Barraud, A.Y.                   T
      A numerical algorithm to solve A XA - X = Q.
      IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977.

  [2] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [3] Higham, N.J.
      Perturbation theory and backward error for AX-XB=C.
      BIT, vol. 33, pp. 124-136, 1993.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
  The accuracy of the estimates obtained depends on the solution
  accuracy and on the properties of the 1-norm estimator.
Further Comments 
  The "separation" sepd of op(A) and op(A)' can also be defined as

         sepd( op(A), op(A)' ) = sigma_min( T ),

  where sigma_min(T) is the smallest singular value of the
  N*N-by-N*N matrix

     T = kprod( op(A)', op(A)' ) - I(N**2).

  I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the
  Kronecker product. The routine estimates sigma_min(T) by the
  reciprocal of an estimate of the 1-norm of inverse(T). The true
  reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by
  more than a factor of N.
Example

Program Text 

*     SB03UD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 3, 2*NMAX*NMAX ) +
     $                                 NMAX*NMAX + 2*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SCALE, SEPD
      INTEGER          I, INFO, J, N
      CHARACTER*1      DICO, FACT, JOB, LYAPUN, TRANA, UPLO
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB03UD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      DICO = 'D'
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $                               READ ( NIN, FMT = * ) SCALE
         IF ( LSAME( FACT, 'N' ) .OR. ( LSAME( LYAPUN, 'O' ) .AND.
     $                             .NOT.LSAME( JOB, 'X') ) )
     $      READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N )
            IF ( LSAME( LYAPUN, 'O' ) )
     $         READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N )
         END IF
         IF ( .NOT.LSAME( JOB, 'S' ) )
     $      READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $      READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N )
*        Solve the discrete-time Lyapunov matrix equation and/or
*        estimate the condition and error bound on the solution.
         CALL SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, LDA,
     $                T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, FERR,
     $                DWORK(1), DWORK(N+1), IWORK, DWORK(2*N+1),
     $                LDWORK-2*N, INFO )
*
         IF ( INFO.EQ.0 ) THEN
            IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99996 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99993 ) SCALE
            END IF
            IF ( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'C' )
     $                             .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99992 ) SEPD
            IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99991 ) RCOND
            IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99990 ) FERR
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03UD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03UD =',I2)
99996 FORMAT (' The solution matrix X is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' Scaling factor = ',F8.4)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END
Program Data 
 SB03UD EXAMPLE PROGRAM DATA
   3     A     N     N     U     O
   3.0   1.0   1.0
   1.0   3.0   0.0
   0.0   0.0   3.0
  25.0  24.0  15.0
  24.0  32.0   8.0
  15.0   8.0  40.0
Program Results 
 SB03UD EXAMPLE PROGRAM RESULTS

 The solution matrix X is
   2.0000   1.0000   1.0000
   1.0000   3.0000   0.0000
   1.0000   0.0000   4.0000

 Scaling factor =   1.0000

 Estimated separation =   5.2302

 Estimated reciprocal condition number =   0.1832

 Estimated error bound =   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB04MD.html000077500000000000000000000210241201767322700160740ustar00rootroot00000000000000 SB04MD - SLICOT Library Routine Documentation

SB04MD

Solution of continuous-time Sylvester equations (Hessenberg-Schur method)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X the continuous-time Sylvester equation

     AX + XB = C

  where A, B, C and X are general N-by-N, M-by-M, N-by-M and
  N-by-M matrices respectively.
Specification 
      SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the coefficient matrix A of the equation.
          On exit, the leading N-by-N upper Hessenberg part of this
          array contains the matrix H, and the remainder of the
          leading N-by-N part, together with the elements 2,3,...,N
          of array DWORK, contain the orthogonal transformation
          matrix U (stored in factored form).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading M-by-M part of this array must
          contain the coefficient matrix B of the equation.
          On exit, the leading M-by-M part of this array contains
          the quasi-triangular Schur factor S of the matrix B'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
          On entry, the leading N-by-M part of this array must
          contain the coefficient matrix C of the equation.
          On exit, the leading N-by-M part of this array contains
          the solution matrix X of the problem.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,M)
          The leading M-by-M part of this array contains the
          orthogonal matrix Z used to transform B' to real upper
          Schur form.

  LDZ     INTEGER
          The leading dimension of array Z.  LDZ >= MAX(1,M).
Workspace 
  IWORK   INTEGER array, dimension (4*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain
          the scalar factors of the elementary reflectors used to
          reduce A to upper Hessenberg form, as returned by LAPACK
          Library routine DGEHRD.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, 1 <= i <= M, the QR algorithm failed to
                compute all the eigenvalues (see LAPACK Library
                routine DGEES);
          > M:  if a singular matrix was encountered whilst solving
                for the (INFO-M)-th column of matrix X.
Method 
  The matrix A is transformed to upper Hessenberg form H = U'AU by
  the orthogonal transformation matrix U; matrix B' is transformed
  to real upper Schur form S = Z'B'Z using the orthogonal
  transformation matrix Z. The matrix C is also multiplied by the
  transformations, F = U'CZ, and the solution matrix Y of the
  transformed system

     HY + YS' = F

  is computed by back substitution. Finally, the matrix Y is then
  multiplied by the orthogonal transformation matrices, X = UYZ', in
  order to obtain the solution matrix X to the original problem.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
Numerical Aspects 
                                      3       3      2         2
  The algorithm requires about (5/3) N  + 10 M  + 5 N M + 2.5 M N
  operations and is backward stable.
Further Comments 
  None
Example

Program Text 

*     SB04MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDZ
      PARAMETER        ( LDA = NMAX, LDB = MMAX, LDC = NMAX,
     $                   LDZ = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 4*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, 2*NMAX*NMAX+8*NMAX, 5*MMAX,
     $                   NMAX+MMAX ) )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX),
     $                 DWORK(LDWORK), Z(LDZ,MMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB04MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N )
*           Find the solution matrix X.
            CALL SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK,
     $                   DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 40 I = 1, M
                  WRITE ( NOUT, FMT = 99996 ) ( Z(I,J), J = 1,M )
   40          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB04MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB04MD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The orthogonal matrix Z is ')
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 SB04MD EXAMPLE PROGRAM DATA
   3     2
   2.0   1.0   3.0
   0.0   2.0   1.0
   6.0   1.0   2.0
   2.0   1.0
   1.0   6.0
   2.0   1.0
   1.0   4.0
   0.0   5.0
Program Results 
 SB04MD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
  -2.7685   0.5498
  -1.0531   0.6865
   4.5257  -0.4389

 The orthogonal matrix Z is 
  -0.9732  -0.2298
   0.2298  -0.9732

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB04MR.html000077500000000000000000000062471201767322700161240ustar00rootroot00000000000000 SB04MR - SLICOT Library Routine Documentation

SB04MR

Solving a linear algebraic system whose coefficient matrix (stored compactly) has zeros below the second subdiagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a linear algebraic system of order M whose coefficient
  matrix has zeros below the second subdiagonal. The matrix is
  stored compactly, row-wise.
Specification 
      SUBROUTINE SB04MR( M, D, IPR, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, M
C     .. Array Arguments ..
      INTEGER           IPR(*)
      DOUBLE PRECISION  D(*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The order of the system.  M >= 0.
          Note that parameter M should have twice the value in the
          original problem (see SLICOT Library routine SB04MU).

  D       (input/output) DOUBLE PRECISION array, dimension
          (M*(M+1)/2+3*M)
          On entry, the first M*(M+1)/2 + 2*M elements of this array
          must contain the coefficient matrix, stored compactly,
          row-wise, and the next M elements must contain the right
          hand side of the linear system, as set by SLICOT Library
          routine SB04MU.
          On exit, the content of this array is updated, the last M
          elements containing the solution with components
          interchanged (see IPR).

  IPR     (output) INTEGER array, dimension (2*M)
          The leading M elements contain information about the
          row interchanges performed for solving the system.
          Specifically, the i-th component of the solution is
          specified by IPR(i).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if a singular matrix was encountered.
Method 
  Gaussian elimination with partial pivoting is used. The rows of
  the matrix are not actually permuted, only their indices are
  interchanged in array IPR.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04MU.html000077500000000000000000000073161201767322700161250ustar00rootroot00000000000000 SB04MU - SLICOT Library Routine Documentation

SB04MU

Constructing and solving a linear algebraic system whose coefficient matrix (stored compactly) has zeros below the second subdiagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct and solve a linear algebraic system of order 2*M
  whose coefficient matrix has zeros below the second subdiagonal.
  Such systems appear when solving continuous-time Sylvester
  equations using the Hessenberg-Schur method.
Specification 
      SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR,
     $                   INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix B.  N >= 0.

  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  IND     (input) INTEGER
          IND and IND - 1 specify the indices of the columns in C
          to be computed.  IND > 1.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain an
          upper Hessenberg matrix.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
          The leading N-by-N part of this array must contain a
          matrix in real Schur form.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the coefficient matrix C of the equation.
          On exit, the leading M-by-N part of this array contains
          the matrix C with columns IND-1 and IND updated.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).
Workspace 
  D       DOUBLE PRECISION array, dimension (2*M*M+7*M)

  IPR     INTEGER array, dimension (4*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          > 0:  if INFO = IND, a singular matrix was encountered.
Method 
  A special linear algebraic system of order 2*M, whose coefficient
  matrix has zeros below the second subdiagonal is constructed and
  solved. The coefficient matrix is stored compactly, row-wise.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04MW.html000077500000000000000000000060121201767322700161170ustar00rootroot00000000000000 SB04MW - SLICOT Library Routine Documentation

SB04MW

Solving a linear algebraic system whose coefficient matrix (stored compactly) has zeros below the first subdiagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a linear algebraic system of order M whose coefficient
  matrix is in upper Hessenberg form, stored compactly, row-wise.
Specification 
      SUBROUTINE SB04MW( M, D, IPR, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, M
C     .. Array Arguments ..
      INTEGER           IPR(*)
      DOUBLE PRECISION  D(*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The order of the system.  M >= 0.

  D       (input/output) DOUBLE PRECISION array, dimension
          (M*(M+1)/2+2*M)
          On entry, the first M*(M+1)/2 + M elements of this array
          must contain an upper Hessenberg matrix, stored compactly,
          row-wise, and the next M elements must contain the right
          hand side of the linear system, as set by SLICOT Library
          routine SB04MY.
          On exit, the content of this array is updated, the last M
          elements containing the solution with components
          interchanged (see IPR).

  IPR     (output) INTEGER array, dimension (2*M)
          The leading M elements contain information about the
          row interchanges performed for solving the system.
          Specifically, the i-th component of the solution is
          specified by IPR(i).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if a singular matrix was encountered.
Method 
  Gaussian elimination with partial pivoting is used. The rows of
  the matrix are not actually permuted, only their indices are
  interchanged in array IPR.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04MY.html000077500000000000000000000071641201767322700161320ustar00rootroot00000000000000 SB04MY - SLICOT Library Routine Documentation

SB04MY

Constructing and solving a linear algebraic system whose coefficient matrix (stored compactly) has zeros below the first subdiagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct and solve a linear algebraic system of order M whose
  coefficient matrix is in upper Hessenberg form. Such systems
  appear when solving Sylvester equations using the Hessenberg-Schur
  method.
Specification 
      SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR,
     $                   INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix B.  N >= 0.

  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  IND     (input) INTEGER
          The index of the column in C to be computed.  IND >= 1.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain an
          upper Hessenberg matrix.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
          The leading N-by-N part of this array must contain a
          matrix in real Schur form.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the coefficient matrix C of the equation.
          On exit, the leading M-by-N part of this array contains
          the matrix C with column IND updated.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).
Workspace 
  D       DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M)

  IPR     INTEGER array, dimension (2*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          > 0:  if INFO = IND, a singular matrix was encountered.
Method 
  A special linear algebraic system of order M, with coefficient
  matrix in upper Hessenberg form is constructed and solved. The
  coefficient matrix is stored compactly, row-wise.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04ND.html000077500000000000000000000236251201767322700161060ustar00rootroot00000000000000 SB04ND - SLICOT Library Routine Documentation

SB04ND

Solution of continuous-time Sylvester equations with one matrix in real Schur form and the other matrix in Hessenberg form (Hessenberg-Schur method)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X the continuous-time Sylvester equation

     AX + XB = C,

  with at least one of the matrices A or B in Schur form and the
  other in Hessenberg or Schur form (both either upper or lower);
  A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices,
  respectively.
Specification 
      SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
     $                   LDC, TOL, IWORK, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  ABSCHU  CHARACTER*1
          Indicates whether A and/or B is/are in Schur or
          Hessenberg form as follows:
          = 'A':  A is in Schur form, B is in Hessenberg form;
          = 'B':  B is in Schur form, A is in Hessenberg form;
          = 'S':  Both A and B are in Schur form.

  ULA     CHARACTER*1
          Indicates whether A is in upper or lower Schur form or
          upper or lower Hessenberg form as follows:
          = 'U':  A is in upper Hessenberg form if ABSCHU = 'B' and
                  upper Schur form otherwise;
          = 'L':  A is in lower Hessenberg form if ABSCHU = 'B' and
                  lower Schur form otherwise.

  ULB     CHARACTER*1
          Indicates whether B is in upper or lower Schur form or
          upper or lower Hessenberg form as follows:
          = 'U':  B is in upper Hessenberg form if ABSCHU = 'A' and
                  upper Schur form otherwise;
          = 'L':  B is in lower Hessenberg form if ABSCHU = 'A' and
                  lower Schur form otherwise.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          coefficient matrix A of the equation.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading M-by-M part of this array must contain the
          coefficient matrix B of the equation.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
          On entry, the leading N-by-M part of this array must
          contain the coefficient matrix C of the equation.
          On exit, if INFO = 0, the leading N-by-M part of this
          array contains the solution matrix X of the problem.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity in
          the Sylvester equation. If the user sets TOL > 0, then the
          given value of TOL is used as a lower bound for the
          reciprocal condition number; a matrix whose estimated
          condition number is less than 1/TOL is considered to be
          nonsingular. If the user sets TOL <= 0, then a default
          tolerance, defined by TOLDEF = EPS, is used instead, where
          EPS is the machine precision (see LAPACK Library routine
          DLAMCH).
          This parameter is not referenced if ABSCHU = 'S',
          ULA = 'U', and ULB = 'U'.
Workspace 
  IWORK   INTEGER array, dimension (2*MAX(M,N))
          This parameter is not referenced if ABSCHU = 'S',
          ULA = 'U', and ULB = 'U'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          This parameter is not referenced if ABSCHU = 'S',
          ULA = 'U', and ULB = 'U'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U';
          LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if a (numerically) singular matrix T was encountered
                during the computation of the solution matrix X.
                That is, the estimated reciprocal condition number
                of T is less than or equal to TOL.
Method 
  Matrices A and B are assumed to be in (upper or lower) Hessenberg
  or Schur form (with at least one of them in Schur form). The
  solution matrix X is then computed by rows or columns via the back
  substitution scheme proposed by Golub, Nash and Van Loan (see
  [1]), which involves the solution of triangular systems of
  equations that are constructed recursively and which may be nearly
  singular if A and -B have close eigenvalues. If near singularity
  is detected, then the routine returns with the Error Indicator
  (INFO) set to 1.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
Numerical Aspects 
                                         2         2
  The algorithm requires approximately 5M N + 0.5MN  operations in
                         2         2
  the worst case and 2.5M N + 0.5MN  operations in the best case
  (where M is the order of the matrix in Hessenberg form and N is
  the order of the matrix in Schur form) and is mixed stable (see
  [1]).
Further Comments 
  None
Example

Program Text 

*     SB04ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = MMAX, LDC = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*( MAX( NMAX,MMAX ) )*
     $                        ( 4+2*( MAX( NMAX,MMAX ) ) ) )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAX( NMAX,MMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N
      CHARACTER*1      ABSCHU, ULA, ULB
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX),
     $                 DWORK(LDWORK)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB04ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, ULA, ULB, ABSCHU
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N )
*           Find the solution matrix X.
            CALL SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
     $                   LDC, TOL, IWORK, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M )
   20          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB04ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB04ND = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 SB04ND EXAMPLE PROGRAM DATA
   5     3     0.0     U     U     B
  17.0  24.0   1.0   8.0  15.0
  23.0   5.0   7.0  14.0  16.0
   0.0   6.0  13.0  20.0  22.0
   0.0   0.0  19.0  21.0   3.0
   0.0   0.0   0.0   2.0   9.0
   8.0   1.0   6.0
   0.0   5.0   7.0
   0.0   9.0   2.0
  62.0 -12.0  26.0
  59.0 -10.0  31.0
  70.0  -6.0   9.0
  35.0  31.0  -7.0
  36.0 -15.0   7.0
Program Results 
 SB04ND EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   0.0000   0.0000   1.0000
   1.0000   0.0000   0.0000
   0.0000   1.0000   0.0000
   1.0000   1.0000  -1.0000
   2.0000  -2.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB04NV.html000077500000000000000000000065001201767322700161210ustar00rootroot00000000000000 SB04NV - SLICOT Library Routine Documentation

SB04NV

Constructing the right-hand sides for a system of equations in Hessenberg form solved via SB04NX (case with 2 right-hand sides)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the right-hand sides D for a system of equations in
  Hessenberg form solved via SB04NX (case with 2 right-hand sides).
Specification 
      SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D )
C     .. Scalar Arguments ..
      CHARACTER         ABSCHR, UL
      INTEGER           INDX, LDAB, LDC, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  AB(LDAB,*), C(LDC,*), D(*)
Arguments

Mode Parameters 

  ABSCHR  CHARACTER*1
          Indicates whether AB contains A or B, as follows:
          = 'A':  AB contains A;
          = 'B':  AB contains B.

  UL      CHARACTER*1
          Indicates whether AB is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  AB is upper Hessenberg;
          = 'L':  AB is lower Hessenberg.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  C       (input) DOUBLE PRECISION array, dimension (LDC,M)
          The leading N-by-M part of this array must contain both
          the not yet modified part of the coefficient matrix C of
          the Sylvester equation AX + XB = C, and both the currently
          computed part of the solution of the Sylvester equation.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  INDX    (input) INTEGER
          The position of the first column/row of C to be used in
          the construction of the right-hand side D.

  AB      (input) DOUBLE PRECISION array, dimension (LDAB,*)
          The leading N-by-N or M-by-M part of this array must
          contain either A or B of the Sylvester equation
          AX + XB = C.

  LDAB    INTEGER
          The leading dimension of array AB.
          LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on
          ABSCHR = 'A' or ABSCHR = 'B', respectively).

  D       (output) DOUBLE PRECISION array, dimension (*)
          The leading 2*N or 2*M part of this array (depending on
          ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the
          right-hand side stored as a matrix with two rows.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04NW.html000077500000000000000000000063631201767322700161310ustar00rootroot00000000000000 SB04NW - SLICOT Library Routine Documentation

SB04NW

Constructing the right-hand side for a system of equations in Hessenberg form solved via SB04NY

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the right-hand side D for a system of equations in
  Hessenberg form solved via SB04NY (case with 1 right-hand side).
Specification 
      SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D )
C     .. Scalar Arguments ..
      CHARACTER         ABSCHR, UL
      INTEGER           INDX, LDAB, LDC, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  AB(LDAB,*), C(LDC,*), D(*)
Arguments

Mode Parameters 

  ABSCHR  CHARACTER*1
          Indicates whether AB contains A or B, as follows:
          = 'A':  AB contains A;
          = 'B':  AB contains B.

  UL      CHARACTER*1
          Indicates whether AB is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  AB is upper Hessenberg;
          = 'L':  AB is lower Hessenberg.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  C       (input) DOUBLE PRECISION array, dimension (LDC,M)
          The leading N-by-M part of this array must contain both
          the not yet modified part of the coefficient matrix C of
          the Sylvester equation AX + XB = C, and both the currently
          computed part of the solution of the Sylvester equation.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  INDX    (input) INTEGER
          The position of the column/row of C to be used in the
          construction of the right-hand side D.

  AB      (input) DOUBLE PRECISION array, dimension (LDAB,*)
          The leading N-by-N or M-by-M part of this array must
          contain either A or B of the Sylvester equation
          AX + XB = C.

  LDAB    INTEGER
          The leading dimension of array AB.
          LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on
          ABSCHR = 'A' or ABSCHR = 'B', respectively).

  D       (output) DOUBLE PRECISION array, dimension (*)
          The leading N or M part of this array (depending on
          ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the
          right-hand side.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04NX.html000077500000000000000000000077761201767322700161430ustar00rootroot00000000000000 SB04NX - SLICOT Library Routine Documentation

SB04NX

Solving a system of equations in Hessenberg form with two consecutive offdiagonals and two right-hand sides

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of equations in Hessenberg form with two
  consecutive offdiagonals and two right-hand sides.
Specification 
      SUBROUTINE SB04NX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3,
     $                   LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO )
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,*)
Arguments

Mode Parameters 

  RC      CHARACTER*1
          Indicates processing by columns or rows, as follows:
          = 'R':  Row transformations are applied;
          = 'C':  Column transformations are applied.

  UL      CHARACTER*1
          Indicates whether AB is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  AB is upper Hessenberg;
          = 'L':  AB is lower Hessenberg.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain a
          matrix A in Hessenberg form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  LAMBD1, (input) DOUBLE PRECISION
  LAMBD2, These variables must contain the 2-by-2 block to be added
  LAMBD3, to the diagonal blocks of A.
  LAMBD4

  D       (input/output) DOUBLE PRECISION array, dimension (2*M)
          On entry, this array must contain the two right-hand
          side vectors of the Hessenberg system, stored row-wise.
          On exit, if INFO = 0, this array contains the two solution
          vectors of the Hessenberg system, stored row-wise.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the triangular factor R of the Hessenberg matrix. A matrix
          whose estimated condition number is less than 1/TOL is
          considered to be nonsingular.
Workspace 
  IWORK   INTEGER array, dimension (2*M)

  DWORK   DOUBLE PRECISION array, dimension (LDDWOR,2*M+3)
          The leading 2*M-by-2*M part of this array is used for
          computing the triangular factor of the QR decomposition
          of the Hessenberg matrix. The remaining 6*M elements are
          used as workspace for the computation of the reciprocal
          condition estimate.

  LDDWOR  INTEGER
          The leading dimension of array DWORK.
          LDDWOR >= MAX(1,2*M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if the Hessenberg matrix is (numerically) singular.
                That is, its estimated reciprocal condition number
                is less than or equal to TOL.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04NY.html000077500000000000000000000075411201767322700161320ustar00rootroot00000000000000 SB04NY - SLICOT Library Routine Documentation

SB04NY

Solving a system of equations in Hessenberg form with one offdiagonal and one right-hand side

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of equations in Hessenberg form with one
  offdiagonal and one right-hand side.
Specification 
      SUBROUTINE SB04NY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK,
     $                   DWORK, LDDWOR, INFO )
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,*)
Arguments

Mode Parameters 

  RC      CHARACTER*1
          Indicates processing by columns or rows, as follows:
          = 'R':  Row transformations are applied;
          = 'C':  Column transformations are applied.

  UL      CHARACTER*1
          Indicates whether AB is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  AB is upper Hessenberg;
          = 'L':  AB is lower Hessenberg.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain a
          matrix A in Hessenberg form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  LAMBDA  (input) DOUBLE PRECISION
          This variable must contain the value to be added to the
          diagonal elements of A.

  D       (input/output) DOUBLE PRECISION array, dimension (M)
          On entry, this array must contain the right-hand side
          vector of the Hessenberg system.
          On exit, if INFO = 0, this array contains the solution
          vector of the Hessenberg system.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the triangular factor R of the Hessenberg matrix. A matrix
          whose estimated condition number is less than 1/TOL is
          considered to be nonsingular.
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (LDDWOR,M+3)
          The leading M-by-M part of this array is used for
          computing the triangular factor of the QR decomposition
          of the Hessenberg matrix. The remaining 3*M elements are
          used as workspace for the computation of the reciprocal
          condition estimate.

  LDDWOR  INTEGER
          The leading dimension of array DWORK.  LDDWOR >= MAX(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if the Hessenberg matrix is (numerically) singular.
                That is, its estimated reciprocal condition number
                is less than or equal to TOL.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04OD.html000077500000000000000000000547541201767322700161160ustar00rootroot00000000000000 SB04OD - SLICOT Library Routine Documentation

SB04OD

Solution of generalized Sylvester equations with separation estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for R and L one of the generalized Sylvester equations

     A * R - L * B = scale * C )
                               )                                 (1)
     D * R - L * E = scale * F )

  or

     A' * R + D' * L = scale * C    )
                                    )                            (2)
     R * B' + L * E' = scale * (-F) )

  where A and D are M-by-M matrices, B and E are N-by-N matrices and
  C, F, R and L are M-by-N matrices.

  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an
  output scaling factor chosen to avoid overflow.

  The routine also optionally computes a Dif estimate, which
  measures the separation of the spectrum of the matrix pair (A,D)
  from the spectrum of the matrix pair (B,E), Dif[(A,D),(B,E)].
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  REDUCE  CHARACTER*1
          Indicates whether the matrix pairs (A,D) and/or (B,E) are
          to be reduced to generalized Schur form as follows:
          = 'R':  The matrix pairs (A,D) and (B,E) are to be reduced
                  to generalized (real) Schur canonical form;
          = 'A':  The matrix pair (A,D) only is to be reduced
                  to generalized (real) Schur canonical form,
                  and the matrix pair (B,E) already is in this form;
          = 'B':  The matrix pair (B,E) only is to be reduced
                  to generalized (real) Schur canonical form,
                  and the matrix pair (A,D) already is in this form;
          = 'N':  The matrix pairs (A,D) and (B,E) are already in
                  generalized (real) Schur canonical form, as
                  produced by LAPACK routine DGEES.

  TRANS   CHARACTER*1
          Indicates which of the equations, (1) or (2), is to be
          solved as follows:
          = 'N':  The generalized Sylvester equation (1) is to be
                  solved;
          = 'T':  The "transposed" generalized Sylvester equation
                  (2) is to be solved.

  JOBD    CHARACTER*1
          Indicates whether the Dif estimator is to be computed as
          follows:
          = '1':  Only the one-norm-based Dif estimate is computed
                  and stored in DIF;
          = '2':  Only the Frobenius norm-based Dif estimate is
                  computed and stored in DIF;
          = 'D':  The equation (1) is solved and the one-norm-based
                  Dif estimate is computed and stored in DIF;
          = 'F':  The equation (1) is solved and the Frobenius norm-
                  based Dif estimate is computed and stored in DIF;
          = 'N':  The Dif estimator is not required and hence DIF is
                  not referenced. (Solve either (1) or (2) only.)
          JOBD is not referenced if TRANS = 'T'.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrices A and D and the number of rows
          of the matrices C, F, R and L.  M >= 0.

  N       (input) INTEGER
          The order of the matrices B and E and the number of
          columns of the matrices C, F, R and L.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
          On entry, the leading M-by-M part of this array must
          contain the coefficient matrix A of the equation; A must
          be in upper quasi-triangular form if REDUCE = 'B' or 'N'.
          On exit, the leading M-by-M part of this array contains
          the upper quasi-triangular form of A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the coefficient matrix B of the equation; B must
          be in upper quasi-triangular form if REDUCE = 'A' or 'N'.
          On exit, the leading N-by-N part of this array contains
          the upper quasi-triangular form of B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the right-hand side matrix C of the first equation
          in (1) or (2).
          On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N
          part of this array contains the solution matrix R of the
          problem; if JOBD = '1' or '2' and TRANS = 'N', the leading
          M-by-N part of this array contains the solution matrix R
          achieved during the computation of the Dif estimate.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading M-by-M part of this array must
          contain the coefficient matrix D of the equation; D must
          be in upper triangular form if REDUCE = 'B' or 'N'.
          On exit, the leading M-by-M part of this array contains
          the upper triangular form of D.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,M).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the coefficient matrix E of the equation; E must
          be in upper triangular form if REDUCE = 'A' or 'N'.
          On exit, the leading N-by-N part of this array contains
          the upper triangular form of E.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
          On entry, the leading M-by-N part of this array must
          contain the right-hand side matrix F of the second
          equation in (1) or (2).
          On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N
          part of this array contains the solution matrix L of the
          problem; if JOBD = '1' or '2' and TRANS = 'N', the leading
          M-by-N part of this array contains the solution matrix L
          achieved during the computation of the Dif estimate.

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).

  SCALE   (output) DOUBLE PRECISION
          The scaling factor in (1) or (2). If 0 < SCALE < 1, C and
          F hold the solutions R and L, respectively, to a slightly
          perturbed system (but the input or computed generalized
          (real) Schur canonical form matrices A, B, D, and E
          have not been changed). If SCALE = 0, C and F hold the
          solutions R and L, respectively, to the homogeneous system
          with C = F = 0. Normally, SCALE = 1.

  DIF     (output) DOUBLE PRECISION
          If TRANS = 'N' and JOBD <> 'N', then DIF contains the
          value of the Dif estimator, which is an upper bound of
                                                 -1
          Dif[(A,D),(B,E)] = sigma_min(Z) = 1/||Z  ||, in either the
          one-norm, or Frobenius norm, respectively (see METHOD).
          Otherwise, DIF is not referenced.

  P       (output) DOUBLE PRECISION array, dimension (LDP,*)
          If REDUCE = 'R' or 'A', then the leading M-by-M part of
          this array contains the (left) transformation matrix used
          to reduce (A,D) to generalized Schur form.
          Otherwise, P is not referenced and can be supplied as a
          dummy array (i.e. set parameter LDP = 1 and declare this
          array to be P(1,1) in the calling program).

  LDP     INTEGER
          The leading dimension of array P.
          LDP >= MAX(1,M) if REDUCE = 'R' or 'A',
          LDP >= 1        if REDUCE = 'B' or 'N'.

  Q       (output) DOUBLE PRECISION array, dimension (LDQ,*)
          If REDUCE = 'R' or 'A', then the leading M-by-M part of
          this array contains the (right) transformation matrix used
          to reduce (A,D) to generalized Schur form.
          Otherwise, Q is not referenced and can be supplied as a
          dummy array (i.e. set parameter LDQ = 1 and declare this
          array to be Q(1,1) in the calling program).

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= MAX(1,M) if REDUCE = 'R' or 'A',
          LDQ >= 1        if REDUCE = 'B' or 'N'.

  U       (output) DOUBLE PRECISION array, dimension (LDU,*)
          If REDUCE = 'R' or 'B', then the leading N-by-N part of
          this array contains the (left) transformation matrix used
          to reduce (B,E) to generalized Schur form.
          Otherwise, U is not referenced and can be supplied as a
          dummy array (i.e. set parameter LDU = 1 and declare this
          array to be U(1,1) in the calling program).

  LDU     INTEGER
          The leading dimension of array U.
          LDU >= MAX(1,N) if REDUCE = 'R' or 'B',
          LDU >= 1        if REDUCE = 'A' or 'N'.

  V       (output) DOUBLE PRECISION array, dimension (LDV,*)
          If REDUCE = 'R' or 'B', then the leading N-by-N part of
          this array contains the (right) transformation matrix used
          to reduce (B,E) to generalized Schur form.
          Otherwise, V is not referenced and can be supplied as a
          dummy array (i.e. set parameter LDV = 1 and declare this
          array to be V(1,1) in the calling program).

  LDV     INTEGER
          The leading dimension of array V.
          LDV >= MAX(1,N) if REDUCE = 'R' or 'B',
          LDV >= 1        if REDUCE = 'A' or 'N'.
Workspace 
  IWORK   INTEGER array, dimension (M+N+6)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          If TRANS = 'N' and JOBD = 'D' or 'F', then
             LDWORK = MAX(1,7*M,7*N,2*M*N) if REDUCE = 'R';
             LDWORK = MAX(1,7*M,2*M*N)     if REDUCE = 'A';
             LDWORK = MAX(1,7*N,2*M*N)     if REDUCE = 'B';
             LDWORK = MAX(1,2*M*N)         if REDUCE = 'N'.
          Otherwise, the term 2*M*N above should be omitted.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if REDUCE <> 'N' and either (A,D) and/or (B,E)
                cannot be reduced to generalized Schur form;
          = 2:  if REDUCE = 'N' and either A or B is not in
                upper quasi-triangular form;
          = 3:  if a singular matrix was encountered during the
                computation of the solution matrices R and L, that
                is (A,D) and (B,E) have common or close eigenvalues.
Method 
  For the case TRANS = 'N', and REDUCE = 'R' or 'N', the algorithm
  used by the routine consists of four steps (see [1] and [2]) as
  follows:

     (a) if REDUCE = 'R', then the matrix pairs (A,D) and (B,E) are
         transformed to generalized Schur form, i.e. orthogonal
         matrices P, Q, U and V are computed such that P' * A * Q
         and U' * B * V are in upper quasi-triangular form and
         P' * D * Q and U' * E * V are in upper triangular form;
     (b) if REDUCE = 'R', then the matrices C and F are transformed
         to give P' * C * V and P' * F * V respectively;
     (c) if REDUCE = 'R', then the transformed system

         P' * A * Q * R1 - L1 * U' * B * V = scale * P' * C * V
         P' * D * Q * R1 - L1 * U' * E * V = scale * P' * F * V

         is solved to give R1 and L1; otherwise, equation (1) is
         solved to give R and L directly. The Dif estimator
         is also computed if JOBD <> 'N'.
     (d) if REDUCE = 'R', then the solution is transformed back
         to give R = Q * R1 * V' and L = P * L1 * U'.

  By using Kronecker products, equation (1) can also be written as
  the system of linear equations Z * x = scale*y (see [1]), where

         | I*A    I*D  |
     Z = |             |.
         |-B'*I  -E'*I |

                                           -1
  If JOBD <> 'N', then a lower bound on ||Z  ||, in either the one-
  norm or Frobenius norm, is computed, which in most cases is
  a reliable estimate of the true value. Notice that since Z is a
  matrix of order 2 * M * N, the exact value of Dif (i.e., in the
  Frobenius norm case, the smallest singular value of Z) may be very
  expensive to compute.

  The case TRANS = 'N', and REDUCE = 'A' or 'B', is similar, but
  only one of the matrix pairs should be reduced and the
  calculations simplify.

  For the case TRANS = 'T', and REDUCE = 'R' or 'N', the algorithm
  is similar, but the steps (b), (c), and (d) are as follows:

     (b) if REDUCE = 'R', then the matrices C and F are transformed
         to give Q' * C * V and P' * F * U respectively;
     (c) if REDUCE = 'R', then the transformed system

         Q' * A' * P * R1 + Q' * D' * P * L1 =  scale * Q' * C * V
         R1 * V' * B' * U + L1 * V' * E' * U = -scale * P' * F * U

         is solved to give R1 and L1; otherwise, equation (2) is
         solved to give R and L directly.
     (d) if REDUCE = 'R', then the solution is transformed back
         to give R = P * R1 * V' and L = P * L1 * V'.
References 
  [1] Kagstrom, B. and Westin, L.
      Generalized Schur Methods with Condition Estimators for
      Solving the Generalized Sylvester Equation.
      IEEE Trans. Auto. Contr., 34, pp. 745-751, 1989.
  [2] Kagstrom, B. and Westin, L.
      GSYLV - Fortran Routines for the Generalized Schur Method with
      Dif Estimators for Solving the Generalized Sylvester
      Equation.
      Report UMINF-132.86, Institute of Information Processing,
      Univ. of Umea, Sweden, July 1987.
  [3] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur Method for the Problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
  [4] Kagstrom, B. and Van Dooren, P.
      Additive Decomposition of a Transfer Function with respect to
      a Specified Region.
      In: "Signal Processing, Scattering and Operator Theory, and
      Numerical Methods" (Eds. M.A. Kaashoek et al.).
      Proceedings of MTNS-89, Vol. 3, pp. 469-477, Birkhauser Boston
      Inc., 1990.
  [5] Kagstrom, B. and Van Dooren, P.
      A Generalized State-space Approach for the Additive
      Decomposition of a Transfer Matrix.
      Report UMINF-91.12, Institute of Information Processing, Univ.
      of Umea, Sweden, April 1991.
Numerical Aspects 
  The algorithm is backward stable. A reliable estimate for the
  condition number of Z in the Frobenius norm, is (see [1])

     K(Z) = SQRT(  ||A||**2 + ||B||**2 + ||C||**2 + ||D||**2 )/DIF.

  If mu is an upper bound on the relative error of the elements of
  the matrices A, B, C, D, E and F, then the relative error in the
  actual solution is approximately mu * K(Z).

  The relative error in the computed solution (due to rounding
  errors) is approximately EPS * K(Z), where EPS is the machine
  precision (see LAPACK Library routine DLAMCH).
Further Comments 
  For applications of the generalized Sylvester equation in control
  theory, see [4] and [5].
Example

Program Text 

*     SB04OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ONE
      PARAMETER        ( ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 10, NMAX = 10 )
      INTEGER          LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, LDU, LDV
      PARAMETER        ( LDA = MMAX, LDB = NMAX, LDC = MMAX, LDD = MMAX,
     $                   LDE = NMAX, LDF = MMAX, LDP = MMAX, LDQ = MMAX,
     $                   LDU = NMAX, LDV = NMAX )
      INTEGER          LDWORK, LIWORK
      PARAMETER        ( LDWORK = MAX(7*MAX(MMAX,NMAX),2*MMAX*NMAX),
     $                   LIWORK = MMAX+NMAX+6 )
*     .. Local Scalars ..
      DOUBLE PRECISION DIF, SCALE
      INTEGER          I, INFO, J, M, N
      CHARACTER*1      JOBD, REDUCE, TRANS
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,MMAX), B(LDB,NMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), E(LDE,NMAX),
     $                 F(LDF,NMAX), P(LDP,MMAX), Q(LDQ,MMAX),
     $                 U(LDU,NMAX), V(LDV,NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB04OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, REDUCE, TRANS, JOBD
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,M ), I = 1,M )
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M )
            READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,M )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M )
*           Find the solution matrices L and R.
            CALL 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 )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, M
                  WRITE ( NOUT, FMT = 99991 ) ( F(I,J), J = 1,N )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99996 )
               DO 40 I = 1, M
                  WRITE ( NOUT, FMT = 99991 ) ( C(I,J), J = 1,N )
   40          CONTINUE
               IF ( LSAME( REDUCE, 'R' ).OR.LSAME( REDUCE, 'A' ) ) THEN
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99991 ) ( P(I,J), J = 1,M )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 80 I = 1, M
                     WRITE ( NOUT, FMT = 99991 ) ( Q(I,J), J = 1,M )
   80             CONTINUE
               END IF
               IF ( LSAME( REDUCE, 'R' ).OR.LSAME( REDUCE, 'B' ) ) THEN
                  WRITE ( NOUT, FMT = 99993 )
                  DO 100 I = 1, N
                     WRITE ( NOUT, FMT = 99991 ) ( U(I,J), J = 1,N )
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 120 I = 1, N
                     WRITE ( NOUT, FMT = 99991 ) ( V(I,J), J = 1,N )
  120             CONTINUE
               END IF
               IF ( SCALE.NE.ONE ) WRITE ( NOUT, FMT = 99987 ) SCALE
               IF ( .NOT.LSAME( JOBD, 'N' ) )
     $            WRITE ( NOUT, FMT = 99990 ) DIF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' SB04OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB04OD = ',I2)
99997 FORMAT (' The solution matrix L is ')
99996 FORMAT (/' The solution matrix R is ')
99995 FORMAT (/' The left transformation matrix P is ')
99994 FORMAT (/' The right transformation matrix Q is ')
99993 FORMAT (/' The left transformation matrix U is ')
99992 FORMAT (/' The right transformation matrix V is ')
99991 FORMAT (20(1X,F8.4))
99990 FORMAT (/' DIF = ',F8.4)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' SCALE = ',F8.4)
      END
Program Data 
 SB04OD EXAMPLE PROGRAM DATA
   3     2     R     N     D
    1.6   -3.1    1.9
   -3.8    4.2    2.4
    0.5    2.2   -4.5
    1.1    0.1
   -1.3   -3.1
   -2.0   28.9
   -5.7  -11.8
   12.9  -31.7
    2.5    0.1    1.7
   -2.5    0.0    0.9
    0.1    5.1   -7.3
    6.0    2.4
   -3.6    2.5
    0.5   23.8
  -11.0  -10.4
   39.5  -74.8
Program Results 
 SB04OD EXAMPLE PROGRAM RESULTS

 The solution matrix L is 
  -0.7538  -1.6210
   2.1778   1.7005
  -3.5029   2.7961

 The solution matrix R is 
   1.3064   2.7989
   0.3698  -5.3376
  -0.8767   6.7500

 The left transformation matrix P is 
  -0.3093  -0.9502   0.0383
   0.9366  -0.2974   0.1851
  -0.1645   0.0932   0.9820

 The right transformation matrix Q is 
  -0.6097  -0.7920  -0.0314
   0.6310  -0.5090   0.5854
   0.4796  -0.3371  -0.8102

 The left transformation matrix U is 
  -0.8121   0.5835
   0.5835   0.8121

 The right transformation matrix V is 
  -0.9861   0.1660
   0.1660   0.9861

 DIF =   0.1147

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB04OW.html000077500000000000000000000141151201767322700161240ustar00rootroot00000000000000 SB04OW - SLICOT Library Routine Documentation

SB04OW

Solving a periodic Sylvester equation with matrices in periodic Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a periodic Sylvester equation

           A * R - L * B = scale * C                           (1)
           D * L - R * 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 periodic Schur 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.

  This routine is largely based on the LAPACK routine DTGSY2
  developed by Bo Kagstrom and Peter Poromaa.
Specification 
      SUBROUTINE SB04OW( M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE,
     $                   F, LDF, SCALE, IWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The order of A and D, and the row dimension of C, F, R
          and L.  M >= 0.

  N       (input) INTEGER
          The order of B and E, and the column dimension of C, F, R
          and L.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          On entry, the leading M-by-M part of this array must
          contain the upper quasi triangular matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the upper quasi triangular matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the right-hand-side of the first matrix equation
          in (1).
          On exit, the leading M-by-N part of this array contains
          the solution R.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,M).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading M-by-M part of this array must
          contain the upper triangular matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,M).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the upper triangular matrix E.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,N).

  F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
          On entry, the leading M-by-N part of this array must
          contain the right-hand-side of the second matrix equation
          in (1).
          On exit, the leading M-by-N part of this array contains
          the solution L.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= MAX(1,M).

  SCALE   (output) DOUBLE PRECISION
          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the arrays
          C and F will hold the solutions R and L, respectively, to
          a slightly perturbed system but the input matrices A, B, D
          and E have not been changed. If SCALE = 0, C and F will
          hold solutions to the homogeneous system with C = F = 0.
          Normally, SCALE = 1.
Workspace 
  IWORK   INTEGER array, dimension (M+N+2)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  the matrix products A*D and B*E have common or very
                close eigenvalues.
Method 
  In matrix notation solving equation (1) corresponds to solving
  Z*x = scale*b, where Z is defined as

      Z = [  kron(In, A)  -kron(B', Im) ]            (2)
          [ -kron(E', Im)  kron(In, D)  ],

  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(Im), Dim(In) = 1 or 2.
References 
  [1] Kagstrom, B.
      A Direct Method for Reordering Eigenvalues in the Generalized
      Real Schur Form of a Regular Matrix Pair (A,B). M.S. Moonen
      et al (eds.), Linear Algebra for Large Scale and Real-Time
      Applications, Kluwer Academic Publ., pp. 195-218, 1993.

  [2] Sreedhar, J. and Van Dooren, P.
      A Schur approach for solving some periodic matrix equations.
      U. Helmke et al (eds.), Systems and Networks: Mathematical
      Theory and Applications, Akademie Verlag, Berlin, vol. 77,
      pp. 339-362, 1994.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04PD.html000077500000000000000000000421361201767322700161060ustar00rootroot00000000000000 SB04PD - SLICOT Library Routine Documentation

SB04PD

Solution of continuous-time or discrete-time Sylvester equations (Bartels-Stewart method)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the real continuous-time Sylvester equation

     op(A)*X + ISGN*X*op(B) = scale*C,                           (1)

  or the real discrete-time Sylvester equation

     op(A)*X*op(B) + ISGN*X = scale*C,                           (2)

  where op(M) = M or M**T, and ISGN = 1 or -1. A is M-by-M and
  B is N-by-N; the right hand side C and the solution X are M-by-N;
  and scale is an output scale factor, set less than or equal to 1
  to avoid overflow in X. The solution matrix X is overwritten
  onto C.

  If A and/or B are not (upper) quasi-triangular, that is, block
  upper triangular with 1-by-1 and 2-by-2 diagonal blocks, they are
  reduced to Schur canonical form, that is, quasi-triangular with
  each 2-by-2 diagonal block having its diagonal elements equal and
  its off-diagonal elements of opposite sign.
Specification 
      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     .. Scalar Arguments ..
      CHARACTER          DICO, FACTA, FACTB, TRANA, TRANB
      INTEGER            INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M,
     $                   N
      DOUBLE PRECISION   SCALE
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  U( LDU, * ), V( LDV, * )
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the equation from which X is to be determined
          as follows:
          = 'C':  Equation (1), continuous-time case;
          = 'D':  Equation (2), discrete-time case.

  FACTA   CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix A is supplied on entry, as follows:
          = 'F':  On entry, A and U contain the factors from the
                  real Schur factorization of the matrix A;
          = 'N':  The Schur factorization of A will be computed
                  and the factors will be stored in A and U;
          = 'S':  The matrix A is quasi-triangular (or Schur).

  FACTB   CHARACTER*1
          Specifies whether or not the real Schur factorization
          of the matrix B is supplied on entry, as follows:
          = 'F':  On entry, B and V contain the factors from the
                  real Schur factorization of the matrix B;
          = 'N':  The Schur factorization of B will be computed
                  and the factors will be stored in B and V;
          = 'S':  The matrix B is quasi-triangular (or Schur).

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  TRANB   CHARACTER*1
          Specifies the form of op(B) to be used, as follows:
          = 'N':  op(B) = B    (No transpose);
          = 'T':  op(B) = B**T (Transpose);
          = 'C':  op(B) = B**T (Conjugate transpose = Transpose).

  ISGN    INTEGER
          Specifies the sign of the equation as described before.
          ISGN may only be 1 or -1.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrix A, and the number of rows in the
          matrices X and C.  M >= 0.

  N       (input) INTEGER
          The order of the matrix B, and the number of columns in
          the matrices X and C.  N >= 0.

  A       (input or input/output) DOUBLE PRECISION array,
          dimension (LDA,M)
          On entry, the leading M-by-M part of this array must
          contain the matrix A. If FACTA = 'S', then A contains
          a quasi-triangular matrix, and if FACTA = 'F', then A
          is in Schur canonical form; the elements below the upper
          Hessenberg part of the array A are not referenced.
          On exit, if FACTA = 'N', and INFO = 0 or INFO >= M+1, the
          leading M-by-M upper Hessenberg part of this array
          contains the upper quasi-triangular matrix in Schur
          canonical form from the Schur factorization of A. The
          contents of array A is not modified if FACTA = 'F' or 'S'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  U       (input or output) DOUBLE PRECISION array, dimension
          (LDU,M)
          If FACTA = 'F', then U is an input argument and on entry
          the leading M-by-M part of this array must contain the
          orthogonal matrix U of the real Schur factorization of A.
          If FACTA = 'N', then U is an output argument and on exit,
          if INFO = 0 or INFO >= M+1, it contains the orthogonal
          M-by-M matrix from the real Schur factorization of A.
          If FACTA = 'S', the array U is not referenced.

  LDU     INTEGER
          The leading dimension of array U.
          LDU >= MAX(1,M), if FACTA = 'F' or 'N';
          LDU >= 1,        if FACTA = 'S'.

  B       (input or input/output) DOUBLE PRECISION array,
          dimension (LDB,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix B. If FACTB = 'S', then B contains
          a quasi-triangular matrix, and if FACTB = 'F', then B
          is in Schur canonical form; the elements below the upper
          Hessenberg part of the array B are not referenced.
          On exit, if FACTB = 'N', and INFO = 0 or INFO = M+N+1,
          the leading N-by-N upper Hessenberg part of this array
          contains the upper quasi-triangular matrix in Schur
          canonical form from the Schur factorization of B. The
          contents of array B is not modified if FACTB = 'F' or 'S'.

  LDB     (input) INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  V       (input or output) DOUBLE PRECISION array, dimension
          (LDV,N)
          If FACTB = 'F', then V is an input argument and on entry
          the leading N-by-N part of this array must contain the
          orthogonal matrix V of the real Schur factorization of B.
          If FACTB = 'N', then V is an output argument and on exit,
          if INFO = 0 or INFO = M+N+1, it contains the orthogonal
          N-by-N matrix from the real Schur factorization of B.
          If FACTB = 'S', the array V is not referenced.

  LDV     INTEGER
          The leading dimension of array V.
          LDV >= MAX(1,N), if FACTB = 'F' or 'N';
          LDV >= 1,        if FACTB = 'S'.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the right hand side matrix C.
          On exit, if INFO = 0 or INFO = M+N+1, the leading M-by-N
          part of this array contains the solution matrix X.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0 or M+N+1, then: DWORK(1) returns the
          optimal value of LDWORK; if FACTA = 'N', DWORK(1+i) and
          DWORK(1+M+i), i = 1,...,M, contain the real and imaginary
          parts, respectively, of the eigenvalues of A; and, if
          FACTB = 'N', DWORK(1+f+j) and DWORK(1+f+N+j), j = 1,...,N,
          with f = 2*M if FACTA = 'N', and f = 0, otherwise, contain
          the real and imaginary parts, respectively, of the
          eigenvalues of B.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, a+MAX( c, b+d, b+e ) ),
          where a = 1+2*M, if FACTA =  'N',
                a = 0,     if FACTA <> 'N',
                b = 2*N,   if FACTB =  'N', FACTA =  'N',
                b = 1+2*N, if FACTB =  'N', FACTA <> 'N',
                b = 0,     if FACTB <> 'N',
                c = 3*M,   if FACTA =  'N',
                c = M,     if FACTA =  'F',
                c = 0,     if FACTA =  'S',
                d = 3*N,   if FACTB =  'N',
                d = N,     if FACTB =  'F',
                d = 0,     if FACTB =  'S',
                e = M,     if DICO  =  'C', FACTA <> 'S',
                e = 0,     if DICO  =  'C', FACTA =  'S',
                e = 2*M,   if DICO  =  'D'.
          An upper bound is
          LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M ).
          For good performance, LDWORK should be larger, e.g.,
          LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M, 2*N+M*N ).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = i:  if INFO = i, i = 1,...,M, the QR algorithm failed
                to compute all the eigenvalues of the matrix A
                (see LAPACK Library routine DGEES); the elements
                2+i:1+M and 2+i+M:1+2*M of DWORK contain the real
                and imaginary parts, respectively, of the
                eigenvalues of A which have converged, and the
                array A contains the partially converged Schur form;
          = M+j:  if INFO = M+j, j = 1,...,N, the QR algorithm
                failed to compute all the eigenvalues of the matrix
                B (see LAPACK Library routine DGEES); the elements
                2+f+j:1+f+N and 2+f+j+N:1+f+2*N of DWORK contain the
                real and imaginary parts, respectively, of the
                eigenvalues of B which have converged, and the
                array B contains the partially converged Schur form;
                as defined for the parameter DWORK,
                f = 2*M, if FACTA =  'N',
                f = 0,   if FACTA <> 'N';
          = M+N+1:  if DICO = 'C', and the matrices A and -ISGN*B
                have common or very close eigenvalues, or
                if DICO = 'D', and the matrices A and -ISGN*B have
                almost reciprocal eigenvalues (that is, if lambda(i)
                and mu(j) are eigenvalues of A and -ISGN*B, then
                lambda(i) = 1/mu(j) for some i and j);
                perturbed values were used to solve the equation
                (but the matrices A and B are unchanged).
Method 
  An extension and refinement of the algorithms in [1,2] is used.
  If the matrices A and/or B are not quasi-triangular (see PURPOSE),
  they are reduced to Schur canonical form

     A = U*S*U',  B = V*T*V',

  where U, V are orthogonal, and S, T are block upper triangular
  with 1-by-1 and 2-by-2 blocks on their diagonal. The right hand
  side matrix C is updated accordingly,

     C = U'*C*V;

  then, the solution matrix X of the "reduced" Sylvester equation
  (with A and B in (1) or (2) replaced by S and T, respectively),
  is computed column-wise via a back substitution scheme. A set of
  equivalent linear algebraic systems of equations of order at most
  four are formed and solved using Gaussian elimination with
  complete pivoting. Finally, the solution X of the original
  equation is obtained from the updating formula

     X = U*X*V'.

  If A and/or B are already quasi-triangular (or in Schur form), the
  initial factorizations and the corresponding updating steps are
  omitted.
References 
  [1] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is stable and reliable, since orthogonal
  transformations and Gaussian elimination with complete pivoting
  are used. If INFO = M+N+1, the Sylvester equation is numerically
  singular.
Further Comments 
  None
Example

Program Text 

*     SB04PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDU, LDV
      PARAMETER        ( LDA = MMAX, LDB = NMAX, LDC = MMAX,
     $                   LDU = MMAX, LDV = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 1 + 2*MMAX + MAX( 3*MMAX, 5*NMAX,
     $                                            2*( NMAX + MMAX ) ) )
*     .. Local Scalars ..
      CHARACTER        DICO, FACTA, FACTB, TRANA, TRANB
      INTEGER          I, INFO, ISGN, J, M, N
      DOUBLE PRECISION SCALE
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,MMAX), B(LDB,NMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), U(LDU,MMAX), V(LDV,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB04PD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, ISGN, DICO, FACTA, FACTB, TRANA, TRANB
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) M
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,M ), I = 1,M )
         IF ( LSAME( FACTA, 'F' ) )
     $      READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,M )
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
            IF ( LSAME( FACTB, 'F' ) )
     $         READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M )
*           Find the solution matrix X.
            CALL SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N,
     $                   A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE,
     $                   DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 )
     $         WRITE ( NOUT, FMT = 99998 ) INFO
            IF ( INFO.EQ.0 .OR. INFO.EQ.M+N+1 ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, M
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99995 ) SCALE
               IF ( LSAME( FACTA, 'N' ) ) THEN
                  WRITE ( NOUT, FMT = 99994 )
                  DO 40 I = 1, M
                     WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,M )
   40             CONTINUE
               END IF
               IF ( LSAME( FACTB, 'N' ) ) THEN
                  WRITE ( NOUT, FMT = 99993 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( V(I,J), J = 1,N )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB04PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB04PD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' Scaling factor = ',F8.4)
99994 FORMAT (/' The orthogonal matrix U is ')
99993 FORMAT (/' The orthogonal matrix V is ')
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 SB04PD EXAMPLE PROGRAM DATA
   3     2     1     D     N     N     N     N
   2.0   1.0   3.0
   0.0   2.0   1.0
   6.0   1.0   2.0
   2.0   1.0
   1.0   6.0
   2.0   1.0
   1.0   4.0
   0.0   5.0
Program Results 
 SB04PD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
  -0.3430   0.1995
  -0.1856   0.4192
   0.6922  -0.2952

 Scaling factor =   1.0000

 The orthogonal matrix U is 
   0.5396  -0.7797   0.3178
   0.1954  -0.2512  -0.9480
  -0.8190  -0.5736  -0.0168

 The orthogonal matrix V is 
  -0.9732  -0.2298
   0.2298  -0.9732

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB04PX.html000077500000000000000000000113141201767322700161240ustar00rootroot00000000000000 SB04PX - SLICOT Library Routine Documentation

SB04PX

Solving a discrete-time Sylvester equation for an m-by-n matrix X, 1 <= m,n <= 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in

         op(TL)*X*op(TR) + ISGN*X = SCALE*B,

  where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1
  or -1.  op(T) = T or T', where T' denotes the transpose of T.
Specification 
      SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
     $                   LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
C     .. Scalar Arguments ..
      LOGICAL            LTRANL, LTRANR
      INTEGER            INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
      DOUBLE PRECISION   SCALE, XNORM
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
     $                   X( LDX, * )
Arguments

Mode Parameters 

  LTRANL  LOGICAL
          Specifies the form of op(TL) to be used, as follows:
          = .FALSE.:  op(TL) = TL,
          = .TRUE. :  op(TL) = TL'.

  LTRANR  LOGICAL
          Specifies the form of op(TR) to be used, as follows:
          = .FALSE.:  op(TR) = TR,
          = .TRUE. :  op(TR) = TR'.

  ISGN    INTEGER
          Specifies the sign of the equation as described before.
          ISGN may only be 1 or -1.
Input/Output Parameters 
  N1      (input) INTEGER
          The order of matrix TL.  N1 may only be 0, 1 or 2.

  N2      (input) INTEGER
          The order of matrix TR.  N2 may only be 0, 1 or 2.

  TL      (input) DOUBLE PRECISION array, dimension (LDTL,N1)
          The leading N1-by-N1 part of this array must contain the
          matrix TL.

  LDTL    INTEGER
          The leading dimension of array TL.  LDTL >= MAX(1,N1).

  TR      (input) DOUBLE PRECISION array, dimension (LDTR,N2)
          The leading N2-by-N2 part of this array must contain the
          matrix TR.

  LDTR    INTEGER
          The leading dimension of array TR.  LDTR >= MAX(1,N2).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N2)
          The leading N1-by-N2 part of this array must contain the
          right-hand side of the equation.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N1).

  SCALE   (output) DOUBLE PRECISION
          The scale factor. SCALE is chosen less than or equal to 1
          to prevent the solution overflowing.

  X       (output) DOUBLE PRECISION array, dimension (LDX,N2)
          The leading N1-by-N2 part of this array contains the
          solution of the equation.
          Note that X may be identified with B in the calling
          statement.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= MAX(1,N1).

  XNORM   (output) DOUBLE PRECISION
          The infinity-norm of the solution.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if TL and -ISGN*TR have almost reciprocal
                eigenvalues, so TL or TR is perturbed to get a
                nonsingular equation.

          NOTE: In the interests of speed, this routine does not
                check the inputs for errors.
Method 
  The equivalent linear algebraic system of equations is formed and
  solved using Gaussian elimination with complete pivoting.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is stable and reliable, since Gaussian elimination
  with complete pivoting is used.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04PY.html000077500000000000000000000134221201767322700161270ustar00rootroot00000000000000 SB04PY - SLICOT Library Routine Documentation

SB04PY

Solving discrete-time Sylvester equations with matrices in real Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X the discrete-time Sylvester equation

     op(A)*X*op(B) + ISGN*X = scale*C,

  where op(A) = A or A**T, A and B are both upper quasi-triangular,
  and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand
  side C and the solution X are M-by-N; and scale is an output scale
  factor, set less than or equal to 1 to avoid overflow in X. The
  solution matrix X is overwritten onto C.

  A and B must be in Schur canonical form (as returned by LAPACK
  Library routine DHSEQR), that is, block upper triangular with
  1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
  its diagonal elements equal and its off-diagonal elements of
  opposite sign.
Specification 
      SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
     $                   LDC, SCALE, DWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER          TRANA, TRANB
      INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
      DOUBLE PRECISION   SCALE
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * )
Arguments

Mode Parameters 

  TRANA   CHARACTER*1
          Specifies the form of op(A) to be used, as follows:
          = 'N':  op(A) = A    (No transpose);
          = 'T':  op(A) = A**T (Transpose);
          = 'C':  op(A) = A**T (Conjugate transpose = Transpose).

  TRANB   CHARACTER*1
          Specifies the form of op(B) to be used, as follows:
          = 'N':  op(B) = B    (No transpose);
          = 'T':  op(B) = B**T (Transpose);
          = 'C':  op(B) = B**T (Conjugate transpose = Transpose).

  ISGN    INTEGER
          Specifies the sign of the equation as described before.
          ISGN may only be 1 or -1.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrix A, and the number of rows in the
          matrices X and C.  M >= 0.

  N       (input) INTEGER
          The order of the matrix B, and the number of columns in
          the matrices X and C.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain the
          upper quasi-triangular matrix A, in Schur canonical form.
          The part of A below the first sub-diagonal is not
          referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
          The leading N-by-N part of this array must contain the
          upper quasi-triangular matrix B, in Schur canonical form.
          The part of B below the first sub-diagonal is not
          referenced.

  LDB     (input) INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the right hand side matrix C.
          On exit, if INFO >= 0, the leading M-by-N part of this
          array contains the solution matrix X.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).

  SCALE   (output) DOUBLE PRECISION
          The scale factor, scale, set less than or equal to 1 to
          prevent the solution overflowing.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (2*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  A and -ISGN*B have almost reciprocal eigenvalues;
                perturbed values were used to solve the equation
                (but the matrices A and B are unchanged).
Method 
  The solution matrix X is computed column-wise via a back
  substitution scheme, an extension and refinement of the algorithm
  in [1], similar to that used in [2] for continuous-time Sylvester
  equations. A set of equivalent linear algebraic systems of
  equations of order at most four are formed and solved using
  Gaussian elimination with complete pivoting.
References 
  [1] Bartels, R.H. and Stewart, G.W.  T
      Solution of the matrix equation A X + XB = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  The algorithm is stable and reliable, since Gaussian elimination
  with complete pivoting is used.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04QD.html000077500000000000000000000216711201767322700161100ustar00rootroot00000000000000 SB04QD - SLICOT Library Routine Documentation

SB04QD

Solution of discrete-time Sylvester equations (Hessenberg-Schur method)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X the discrete-time Sylvester equation

     X + AXB = C,

  where A, B, C and X are general N-by-N, M-by-M, N-by-M and
  N-by-M matrices respectively. A Hessenberg-Schur method, which
  reduces A to upper Hessenberg form, H = U'AU, and B' to real
  Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used.
Specification 
      SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the coefficient matrix A of the equation.
          On exit, the leading N-by-N upper Hessenberg part of this
          array contains the matrix H, and the remainder of the
          leading N-by-N part, together with the elements 2,3,...,N
          of array DWORK, contain the orthogonal transformation
          matrix U (stored in factored form).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading M-by-M part of this array must
          contain the coefficient matrix B of the equation.
          On exit, the leading M-by-M part of this array contains
          the quasi-triangular Schur factor S of the matrix B'.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
          On entry, the leading N-by-M part of this array must
          contain the coefficient matrix C of the equation.
          On exit, the leading N-by-M part of this array contains
          the solution matrix X of the problem.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,M)
          The leading M-by-M part of this array contains the
          orthogonal matrix Z used to transform B' to real upper
          Schur form.

  LDZ     INTEGER
          The leading dimension of array Z.  LDZ >= MAX(1,M).
Workspace 
  IWORK   INTEGER array, dimension (4*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain
          the scalar factors of the elementary reflectors used to
          reduce A to upper Hessenberg form, as returned by LAPACK
          Library routine DGEHRD.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = MAX(1, 2*N*N + 9*N, 5*M, N + M).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, 1 <= i <= M, the QR algorithm failed to
                compute all the eigenvalues of B (see LAPACK Library
                routine DGEES);
          > M:  if a singular matrix was encountered whilst solving
                for the (INFO-M)-th column of matrix X.
Method 
  The matrix A is transformed to upper Hessenberg form H = U'AU by
  the orthogonal transformation matrix U; matrix B' is transformed
  to real upper Schur form S = Z'B'Z using the orthogonal
  transformation matrix Z. The matrix C is also multiplied by the
  transformations, F = U'CZ, and the solution matrix Y of the
  transformed system

     Y + HYS' = F

  is computed by back substitution. Finally, the matrix Y is then
  multiplied by the orthogonal transformation matrices, X = UYZ', in
  order to obtain the solution matrix X to the original problem.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.

  [2] Sima, V.
      Algorithms for Linear-quadratic Optimization.
      Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
                                      3       3      2         2
  The algorithm requires about (5/3) N  + 10 M  + 5 N M + 2.5 M N
  operations and is backward stable.
Further Comments 
  None
Example

Program Text 

*     SB04QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDZ
      PARAMETER        ( LDA = NMAX, LDB = MMAX, LDC = NMAX,
     $                   LDZ = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 4*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, 2*NMAX*NMAX+9*NMAX, 5*MMAX,
     $                   NMAX+MMAX ) )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX),
     $                 DWORK(LDWORK), Z(LDZ,MMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB04QD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N )
*           Find the solution matrix X.
            CALL SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK,
     $                   DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 40 I = 1, M
                  WRITE ( NOUT, FMT = 99996 ) ( Z(I,J), J = 1,M )
   40          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB04QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB04QD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The orthogonal matrix Z is ')
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 SB04QD EXAMPLE PROGRAM DATA
   3     3
   1.0   2.0   3.0 
   6.0   7.0   8.0 
   9.0   2.0   3.0 
   7.0   2.0   3.0 
   2.0   1.0   2.0 
   3.0   4.0   1.0 
   271.0   135.0   147.0
   923.0   494.0   482.0
   578.0   383.0   287.0
Program Results 
 SB04QD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   2.0000   3.0000   6.0000
   4.0000   7.0000   1.0000
   5.0000   3.0000   2.0000

 The orthogonal matrix Z is 
   0.8337   0.5204  -0.1845
   0.3881  -0.7900  -0.4746
   0.3928  -0.3241   0.8606

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB04QR.html000077500000000000000000000065321201767322700161250ustar00rootroot00000000000000 SB04QR - SLICOT Library Routine Documentation

SB04QR

Solving a linear algebraic system whose coefficient matrix (stored compactly) has zeros below the third subdiagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a linear algebraic system of order M whose coefficient
  matrix has zeros below the third subdiagonal and zero elements on
  the third subdiagonal with even column indices. The matrix is
  stored compactly, row-wise.
Specification 
      SUBROUTINE SB04QR( M, D, IPR, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, M
C     .. Array Arguments ..
      INTEGER           IPR(*)
      DOUBLE PRECISION  D(*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The order of the system.  M >= 0, M even.
          Note that parameter M should have twice the value in the
          original problem (see SLICOT Library routine SB04QU).

  D       (input/output) DOUBLE PRECISION array, dimension
          (M*M/2+4*M)
          On entry, the first M*M/2 + 3*M elements of this array
          must contain the coefficient matrix, stored compactly,
          row-wise, and the next M elements must contain the right
          hand side of the linear system, as set by SLICOT Library
          routine SB04QU.
          On exit, the content of this array is updated, the last M
          elements containing the solution with components
          interchanged (see IPR).

  IPR     (output) INTEGER array, dimension (2*M)
          The leading M elements contain information about the
          row interchanges performed for solving the system.
          Specifically, the i-th component of the solution is
          specified by IPR(i).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if a singular matrix was encountered.
Method 
  Gaussian elimination with partial pivoting is used. The rows of
  the matrix are not actually permuted, only their indices are
  interchanged in array IPR.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.

  [2] Sima, V.
      Algorithms for Linear-quadratic Optimization.
      Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04QU.html000077500000000000000000000077061201767322700161340ustar00rootroot00000000000000 SB04QU - SLICOT Library Routine Documentation

SB04QU

Constructing and solving a linear algebraic system whose coefficient matrix (stored compactly) has zeros below the third subdiagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct and solve a linear algebraic system of order 2*M
  whose coefficient matrix has zeros below the third subdiagonal,
  and zero elements on the third subdiagonal with even column
  indices. Such systems appear when solving discrete-time Sylvester
  equations using the Hessenberg-Schur method.
Specification 
      SUBROUTINE SB04QU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR,
     $                   INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix B.  N >= 0.

  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  IND     (input) INTEGER
          IND and IND - 1 specify the indices of the columns in C
          to be computed.  IND > 1.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain an
          upper Hessenberg matrix.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
          The leading N-by-N part of this array must contain a
          matrix in real Schur form.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the coefficient matrix C of the equation.
          On exit, the leading M-by-N part of this array contains
          the matrix C with columns IND-1 and IND updated.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).
Workspace 
  D       DOUBLE PRECISION array, dimension (2*M*M+8*M)

  IPR     INTEGER array, dimension (4*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          > 0:  if INFO = IND, a singular matrix was encountered.
Method 
  A special linear algebraic system of order 2*M, whose coefficient
  matrix has zeros below the third subdiagonal and zero elements on
  the third subdiagonal with even column indices, is constructed and
  solved. The coefficient matrix is stored compactly, row-wise.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.

  [2] Sima, V.
      Algorithms for Linear-quadratic Optimization.
      Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04QY.html000077500000000000000000000073611201767322700161350ustar00rootroot00000000000000 SB04QY - SLICOT Library Routine Documentation

SB04QY

Constructing and solving a linear algebraic system whose coefficient matrix (stored compactly) has zeros below the first subdiagonal

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct and solve a linear algebraic system of order M whose
  coefficient matrix is in upper Hessenberg form. Such systems
  appear when solving discrete-time Sylvester equations using the
  Hessenberg-Schur method.
Specification 
      SUBROUTINE SB04QY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR,
     $                   INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix B.  N >= 0.

  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  IND     (input) INTEGER
          The index of the column in C to be computed.  IND >= 1.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain an
          upper Hessenberg matrix.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
          The leading N-by-N part of this array must contain a
          matrix in real Schur form.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading M-by-N part of this array must
          contain the coefficient matrix C of the equation.
          On exit, the leading M-by-N part of this array contains
          the matrix C with column IND updated.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M).
Workspace 
  D       DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M)

  IPR     INTEGER array, dimension (2*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          > 0:  if INFO = IND, a singular matrix was encountered.
Method 
  A special linear algebraic system of order M, with coefficient
  matrix in upper Hessenberg form is constructed and solved. The
  coefficient matrix is stored compactly, row-wise.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.

  [2] Sima, V.
      Algorithms for Linear-quadratic Optimization.
      Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04RD.html000077500000000000000000000242461201767322700161120ustar00rootroot00000000000000 SB04RD - SLICOT Library Routine Documentation

SB04RD

Solution of discrete-time Sylvester equations with one matrix in real Schur form and the other matrix in Hessenberg form (Hessenberg-Schur method)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X the discrete-time Sylvester equation

     X + AXB = C,

  with at least one of the matrices A or B in Schur form and the
  other in Hessenberg or Schur form (both either upper or lower);
  A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices,
  respectively.
Specification 
      SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
     $                   LDC, TOL, IWORK, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  ABSCHU  CHARACTER*1
          Indicates whether A and/or B is/are in Schur or
          Hessenberg form as follows:
          = 'A':  A is in Schur form, B is in Hessenberg form;
          = 'B':  B is in Schur form, A is in Hessenberg form;
          = 'S':  Both A and B are in Schur form.

  ULA     CHARACTER*1
          Indicates whether A is in upper or lower Schur form or
          upper or lower Hessenberg form as follows:
          = 'U':  A is in upper Hessenberg form if ABSCHU = 'B' and
                  upper Schur form otherwise;
          = 'L':  A is in lower Hessenberg form if ABSCHU = 'B' and
                  lower Schur form otherwise.

  ULB     CHARACTER*1
          Indicates whether B is in upper or lower Schur form or
          upper or lower Hessenberg form as follows:
          = 'U':  B is in upper Hessenberg form if ABSCHU = 'A' and
                  upper Schur form otherwise;
          = 'L':  B is in lower Hessenberg form if ABSCHU = 'A' and
                  lower Schur form otherwise.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          coefficient matrix A of the equation.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading M-by-M part of this array must contain the
          coefficient matrix B of the equation.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,M).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
          On entry, the leading N-by-M part of this array must
          contain the coefficient matrix C of the equation.
          On exit, if INFO = 0, the leading N-by-M part of this
          array contains the solution matrix X of the problem.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity in
          the Sylvester equation. If the user sets TOL > 0, then the
          given value of TOL is used as a lower bound for the
          reciprocal condition number; a matrix whose estimated
          condition number is less than 1/TOL is considered to be
          nonsingular. If the user sets TOL <= 0, then a default
          tolerance, defined by TOLDEF = EPS, is used instead, where
          EPS is the machine precision (see LAPACK Library routine
          DLAMCH).
          This parameter is not referenced if ABSCHU = 'S',
          ULA = 'U', and ULB = 'U'.
Workspace 
  IWORK   INTEGER array, dimension (2*MAX(M,N))
          This parameter is not referenced if ABSCHU = 'S',
          ULA = 'U', and ULB = 'U'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U';
          LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if a (numerically) singular matrix T was encountered
                during the computation of the solution matrix X.
                That is, the estimated reciprocal condition number
                of T is less than or equal to TOL.
Method 
  Matrices A and B are assumed to be in (upper or lower) Hessenberg
  or Schur form (with at least one of them in Schur form). The
  solution matrix X is then computed by rows or columns via the back
  substitution scheme proposed by Golub, Nash and Van Loan (see
  [1]), which involves the solution of triangular systems of
  equations that are constructed recursively and which may be nearly
  singular if A and -B have almost reciprocal eigenvalues. If near
  singularity is detected, then the routine returns with the Error
  Indicator (INFO) set to 1.
References 
  [1] Golub, G.H., Nash, S. and Van Loan, C.F.
      A Hessenberg-Schur method for the problem AX + XB = C.
      IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.

  [2] Sima, V.
      Algorithms for Linear-quadratic Optimization.
      Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
                                         2         2
  The algorithm requires approximately 5M N + 0.5MN  operations in
                         2         2
  the worst case and 2.5M N + 0.5MN  operations in the best case
  (where M is the order of the matrix in Hessenberg form and N is
  the order of the matrix in Schur form) and is mixed stable (see
  [1]).
Further Comments 
  None
Example

Program Text 

*     SB04RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = MMAX, LDC = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*( MAX( NMAX,MMAX ) )*
     $                        ( 4+2*( MAX( NMAX,MMAX ) ) ) )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAX( NMAX,MMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N
      CHARACTER*1      ABSCHU, ULA, ULB
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX),
     $                 DWORK(LDWORK)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB04RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, ULA, ULB, ABSCHU
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N )
*           Find the solution matrix X.
            CALL SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
     $                   LDC, TOL, IWORK, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M )
   20          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB04RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB04RD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 SB04RD EXAMPLE PROGRAM DATA
   5     5     0.0     U     U     B
   1.0   2.0   3.0   4.0   5.0
   6.0   7.0   8.0   9.0   1.0
   0.0   2.0   3.0   4.0   5.0
   0.0   0.0   6.0   7.0   8.0
   0.0   0.0   0.0   9.0   1.0
   1.0   2.0   3.0   4.0   5.0
   0.0   1.0   2.0   3.0   4.0
   0.0   0.0   1.0   2.0   3.0
   0.0   0.0   0.0   1.0  -5.0
   0.0   0.0   0.0   4.0   1.0
   2.0   4.0  10.0  40.0   7.0
   6.0  20.0  40.0  74.0  38.0
   0.0   2.0   8.0  36.0   2.0
   0.0   0.0   6.0  52.0  -9.0
   0.0   0.0   0.0  13.0 -43.0
Program Results 
 SB04RD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   1.0000   0.0000   0.0000   0.0000   0.0000
   0.0000   1.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   1.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   1.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB04RV.html000077500000000000000000000100031201767322700161160ustar00rootroot00000000000000 SB04RV - SLICOT Library Routine Documentation

SB04RV

Constructing the right-hand sides for a system of equations in quasi-Hessenberg form solved via SB04RX (case with 2 right-hand sides)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the right-hand sides D for a system of equations in
  quasi-Hessenberg form solved via SB04RX (case with 2 right-hand
  sides).
Specification 
      SUBROUTINE SB04RV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA,
     $                   LDBA, D, DWORK )
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(*)
Arguments

Mode Parameters 

  ABSCHR  CHARACTER*1
          Indicates whether AB contains A or B, as follows:
          = 'A':  AB contains A;
          = 'B':  AB contains B.

  UL      CHARACTER*1
          Indicates whether AB is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  AB is upper Hessenberg;
          = 'L':  AB is lower Hessenberg.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  C       (input) DOUBLE PRECISION array, dimension (LDC,M)
          The leading N-by-M part of this array must contain both
          the not yet modified part of the coefficient matrix C of
          the Sylvester equation X + AXB = C, and both the currently
          computed part of the solution of the Sylvester equation.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  INDX    (input) INTEGER
          The position of the first column/row of C to be used in
          the construction of the right-hand side D.

  AB      (input) DOUBLE PRECISION array, dimension (LDAB,*)
          The leading N-by-N or M-by-M part of this array must
          contain either A or B of the Sylvester equation
          X + AXB = C.

  LDAB    INTEGER
          The leading dimension of array AB.
          LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on
          ABSCHR = 'A' or ABSCHR = 'B', respectively).

  BA      (input) DOUBLE PRECISION array, dimension (LDBA,*)
          The leading N-by-N or M-by-M part of this array must
          contain either A or B of the Sylvester equation
          X + AXB = C, the matrix not contained in AB.

  LDBA    INTEGER
          The leading dimension of array BA.
          LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on
          ABSCHR = 'B' or ABSCHR = 'A', respectively).

  D       (output) DOUBLE PRECISION array, dimension (*)
          The leading 2*N or 2*M part of this array (depending on
          ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the
          right-hand side stored as a matrix with two rows.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          where LDWORK is equal to 2*N or 2*M (depending on
          ABSCHR = 'B' or ABSCHR = 'A', respectively).
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04RW.html000077500000000000000000000076441201767322700161400ustar00rootroot00000000000000 SB04RW - SLICOT Library Routine Documentation

SB04RW

Constructing the right-hand side for a system of equations in Hessenberg form solved via SB04RY

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the right-hand side D for a system of equations in
  Hessenberg form solved via SB04RY (case with 1 right-hand side).
Specification 
      SUBROUTINE SB04RW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA,
     $                   LDBA, D, DWORK )
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(*)
Arguments

Mode Parameters 

  ABSCHR  CHARACTER*1
          Indicates whether AB contains A or B, as follows:
          = 'A':  AB contains A;
          = 'B':  AB contains B.

  UL      CHARACTER*1
          Indicates whether AB is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  AB is upper Hessenberg;
          = 'L':  AB is lower Hessenberg.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The order of the matrix B.  M >= 0.

  C       (input) DOUBLE PRECISION array, dimension (LDC,M)
          The leading N-by-M part of this array must contain both
          the not yet modified part of the coefficient matrix C of
          the Sylvester equation X + AXB = C, and both the currently
          computed part of the solution of the Sylvester equation.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,N).

  INDX    (input) INTEGER
          The position of the column/row of C to be used in the
          construction of the right-hand side D.

  AB      (input) DOUBLE PRECISION array, dimension (LDAB,*)
          The leading N-by-N or M-by-M part of this array must
          contain either A or B of the Sylvester equation
          X + AXB = C.

  LDAB    INTEGER
          The leading dimension of array AB.
          LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on
          ABSCHR = 'A' or ABSCHR = 'B', respectively).

  BA      (input) DOUBLE PRECISION array, dimension (LDBA,*)
          The leading N-by-N or M-by-M part of this array must
          contain either A or B of the Sylvester equation
          X + AXB = C, the matrix not contained in AB.

  LDBA    INTEGER
          The leading dimension of array BA.
          LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on
          ABSCHR = 'B' or ABSCHR = 'A', respectively).

  D       (output) DOUBLE PRECISION array, dimension (*)
          The leading N or M part of this array (depending on
          ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the
          right-hand side.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          where LDWORK is equal to N or M (depending on ABSCHR = 'B'
          or ABSCHR = 'A', respectively).
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04RX.html000077500000000000000000000100411201767322700161220ustar00rootroot00000000000000 SB04RX - SLICOT Library Routine Documentation

SB04RX

Solving a system of equations in quasi-Hessenberg form with two right-hand sides

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of equations in quasi-Hessenberg form
  (Hessenberg form plus two consecutive offdiagonals) with two
  right-hand sides.
Specification 
      SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3,
     $                   LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO )
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,*)
Arguments

Mode Parameters 

  RC      CHARACTER*1
          Indicates processing by columns or rows, as follows:
          = 'R':  Row transformations are applied;
          = 'C':  Column transformations are applied.

  UL      CHARACTER*1
          Indicates whether A is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  A is upper Hessenberg;
          = 'L':  A is lower Hessenberg.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain a
          matrix A in Hessenberg form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  LAMBD1, (input) DOUBLE PRECISION
  LAMBD2, These variables must contain the 2-by-2 block to be
  LAMBD3, multiplied to the elements of A.
  LAMBD4

  D       (input/output) DOUBLE PRECISION array, dimension (2*M)
          On entry, this array must contain the two right-hand
          side vectors of the quasi-Hessenberg system, stored
          row-wise.
          On exit, if INFO = 0, this array contains the two solution
          vectors of the quasi-Hessenberg system, stored row-wise.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the triangular factor R of the quasi-Hessenberg matrix.
          A matrix whose estimated condition number is less
          than 1/TOL is considered to be nonsingular.
Workspace 
  IWORK   INTEGER array, dimension (2*M)

  DWORK   DOUBLE PRECISION array, dimension (LDDWOR,2*M+3)
          The leading 2*M-by-2*M part of this array is used for
          computing the triangular factor of the QR decomposition
          of the quasi-Hessenberg matrix. The remaining 6*M elements
          are used as workspace for the computation of the
          reciprocal condition estimate.

  LDDWOR  INTEGER
          The leading dimension of array DWORK.
          LDDWOR >= MAX(1,2*M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if the quasi-Hessenberg matrix is (numerically)
                singular. That is, its estimated reciprocal
                condition number is less than or equal to TOL.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB04RY.html000077500000000000000000000074641201767322700161420ustar00rootroot00000000000000 SB04RY - SLICOT Library Routine Documentation

SB04RY

Solving a system of equations in Hessenberg form with one right-hand side

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve a system of equations in Hessenberg form with one
  right-hand side.
Specification 
      SUBROUTINE SB04RY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK,
     $                   DWORK, LDDWOR, INFO )
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,*)
Arguments

Mode Parameters 

  RC      CHARACTER*1
          Indicates processing by columns or rows, as follows:
          = 'R':  Row transformations are applied;
          = 'C':  Column transformations are applied.

  UL      CHARACTER*1
          Indicates whether A is upper or lower Hessenberg matrix,
          as follows:
          = 'U':  A is upper Hessenberg;
          = 'L':  A is lower Hessenberg.
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrix A.  M >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain a
          matrix A in Hessenberg form.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).

  LAMBDA  (input) DOUBLE PRECISION
          This variable must contain the value to be multiplied with
          the elements of A.

  D       (input/output) DOUBLE PRECISION array, dimension (M)
          On entry, this array must contain the right-hand side
          vector of the Hessenberg system.
          On exit, if INFO = 0, this array contains the solution
          vector of the Hessenberg system.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the triangular factor R of the Hessenberg matrix. A matrix
          whose estimated condition number is less than 1/TOL is
          considered to be nonsingular.
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (LDDWOR,M+3)
          The leading M-by-M part of this array is used for
          computing the triangular factor of the QR decomposition
          of the Hessenberg matrix. The remaining 3*M elements are
          used as workspace for the computation of the reciprocal
          condition estimate.

  LDDWOR  INTEGER
          The leading dimension of array DWORK.  LDDWOR >= MAX(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 1:  if the Hessenberg matrix is (numerically) singular.
                That is, its estimated reciprocal condition number
                is less than or equal to TOL.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB06ND.html000077500000000000000000000245021201767322700161030ustar00rootroot00000000000000 SB06ND - SLICOT Library Routine Documentation

SB06ND

Minimum norm feedback matrix for "deadbeat control" of a state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the minimum norm feedback matrix F to perform
  "deadbeat control" on a (A,B)-pair of a state-space model (which
  must be preliminarily reduced to upper "staircase" form using
  SLICOT Library routine AB01OD) such that the matrix R = A + BFU'
  is nilpotent.
  (The transformation matrix U reduces R to upper Schur form with
  zero blocks on its diagonal (of dimension KSTAIR(i)) and
  therefore contains bases for the i-th controllable subspaces,
  where i = 1,...,KMAX).
Specification 
      SUBROUTINE SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, F,
     $                   LDF, DWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The actual state dimension, i.e. the order of the
          matrix A.  N >= 0.

  M       (input) INTEGER
          The actual input dimension.  M >= 0.

  KMAX    (input) INTEGER
          The number of "stairs" in the staircase form as produced
          by SLICOT Library routine AB01OD.  0 <= KMAX <= N.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the transformed state-space matrix of the
          (A,B)-pair with triangular stairs, as produced by SLICOT
          Library routine AB01OD (with option STAGES = 'A').
          On exit, the leading N-by-N part of this array contains
          the matrix U'AU + U'BF.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the transformed triangular input matrix of the
          (A,B)-pair as produced by SLICOT Library routine AB01OD
          (with option STAGES = 'A').
          On exit, the leading N-by-M part of this array contains
          the matrix U'B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  KSTAIR  (input) INTEGER array, dimension (KMAX)
          The leading KMAX elements of this array must contain the
          dimensions of each "stair" as produced by SLICOT Library
          routine AB01OD.

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
          On entry, the leading N-by-N part of this array must
          contain either a transformation matrix (e.g. from a
          previous call to other SLICOT routine) or be initialised
          as the identity matrix.
          On exit, the leading N-by-N part of this array contains
          the product of the input matrix U and the state-space
          transformation matrix which reduces A + BFU' to real
          Schur form.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,N).

  F       (output) DOUBLE PRECISION array, dimension (LDF,N)
          The leading M-by-N part of this array contains the
          deadbeat feedback matrix F.

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Starting from the (A,B)-pair in "staircase form" with "triangular"
  stairs, dimensions KSTAIR(i+1) x KSTAIR(i), (described by the
  vector KSTAIR):

                 | B | A      *  . . .  *  |
                 |  1|  11       .      .  |
                 |   | A     A     .    .  |
                 |   |  21    22     .  .  |
                 |   |    .      .     .   |
   [ B | A ]  =  |   |      .      .    *  |
                 |   |        .      .     |
                 | 0 |   0                 |
                 |   |          A      A   |
                 |   |           r,r-1  rr |

  where the i-th diagonal block of A has dimension KSTAIR(i), for
  i = 1,2,...,r, the feedback matrix F is constructed recursively in
  r steps (where the number of "stairs" r is given by KMAX). In each
  step a unitary state-space transformation U and a part of F are
  updated in order to achieve the final form:

                    | 0   A      *   . . .  *   |
                    |      12      .        .   |
                    |                .      .   |
                    |     0    A       .    .   |
                    |           23       .  .   |
                    |         .      .          |
  [ U'AU + U'BF ] = |           .      .    *   | .
                    |             .      .      |
                    |                           |
                    |                     A     |
                    |                      r-1,r|
                    |                           |
                    |                       0   |
References 
  [1] Van Dooren, P.
      Deadbeat control: a special inverse eigenvalue problem.
      BIT, 24, pp. 681-699, 1984.
Numerical Aspects 
  The algorithm requires O((N + M) * N**2) operations and is mixed
  numerical stable (see [1]).
Further Comments 
  None
Example

Program Text 

*     SB06ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDU, LDV, LDF
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDU = NMAX,
     $                   LDV = MMAX, LDF = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX + MAX(NMAX,3*MMAX) )
*     PARAMETER        ( LDWORK = 4*NMAX)
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, KMAX, M, N, NCONT
      CHARACTER*1      JOBU, JOBV
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK),
     $                 F(LDF,NMAX), U(LDU,NMAX), V(LDV,MMAX)
      INTEGER          IWORK(LIWORK), KSTAIR(NMAX)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB01OD, DLASET, SB06ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, JOBU, JOBV
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
*           First put (A,B) into staircase form with triangular pivots
*           and determine the stairsizes.
            CALL AB01OD( 'A', JOBU, JOBV, N, M, A, LDA, B, LDB, U,
     $                   LDU, V, LDV, NCONT, KMAX, KSTAIR, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
*
            IF ( INFO.EQ.0 ) THEN
               IF( LSAME( JOBU, 'N' ) ) THEN
*                 Initialize U as the identity matrix.
                  CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
               END IF
*              Perform "deadbeat control" to give F.
               CALL SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU,
     $                      F, LDF, DWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,N )
   60             CONTINUE
               END IF
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB06ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01OD = ',I2)
99997 FORMAT (' INFO on exit from SB06ND = ',I2)
99996 FORMAT (' The deadbeat feedback matrix F is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 SB06ND EXAMPLE PROGRAM DATA
   5     2     0.0     N     N
  -17.0   24.0   41.0   68.0   15.0
   23.0  -35.0   27.0   14.0   16.0
   34.0   26.0  -13.0   20.0   22.0
   10.0   12.0   19.0  -21.0   63.0
   11.0   18.0   25.0   52.0  -29.0
  -31.0   14.0
   74.0  -69.0
  -59.0   16.0
   16.0  -25.0
  -25.0   36.0
Program Results 
 SB06ND EXAMPLE PROGRAM RESULTS

 The deadbeat feedback matrix F is 
  -0.4819  -0.5782  -2.7595  -3.1093   0.0000
   0.2121  -0.4462   0.7698  -1.5421  -0.5773

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08CD.html000077500000000000000000000411701201767322700160720ustar00rootroot00000000000000 SB08CD - SLICOT Library Routine Documentation

SB08CD

Left coprime factorization with inner denominator

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct, for a given system G = (A,B,C,D), an output
  injection matrix H, an orthogonal transformation matrix Z, and a
  gain matrix V, such that the systems

       Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), V*C*Z, V*D)
  and
       R = (Z'*(A+H*C)*Z, Z'*H, V*C*Z, V)

  provide a stable left coprime factorization of G in the form
                -1
           G = R  * Q,

  where G, Q and R are the corresponding transfer-function matrices
  and the denominator R is co-inner, that is, R(s)*R'(-s) = I in
  the continuous-time case, or R(z)*R'(1/z) = I in the discrete-time
  case. The Z matrix is not explicitly computed.

  Note: G must have no observable poles on the imaginary axis
  for a continuous-time system, or on the unit circle for a
  discrete-time system. If the given state-space representation
  is not detectable, the undetectable part of the original
  system is automatically deflated and the order of the systems
  Q and R is accordingly reduced.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector, i.e. the order of the
          matrix A, and also the number of rows of the matrices B
          and BR, and the number of columns of the matrix C.
          N >= 0.

  M       (input) INTEGER
          The dimension of input vector, i.e. the number of columns
          of the matrices B and D.  M >= 0.

  P       (input) INTEGER
          The dimension of output vector, i.e. the number of rows
          of the matrices C, D and DR, and the number of columns
          of the matrices BR and DR.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A. The matrix A must not
          have observable eigenvalues on the imaginary axis, if
          DICO = 'C', or on the unit circle, if DICO = 'D'.
          On exit, the leading NQ-by-NQ part of this array contains
          the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the
          state dynamics matrix of the numerator factor Q, in a
          real Schur form. The leading NR-by-NR part of this matrix
          represents the state dynamics matrix of a minimal
          realization of the denominator factor R.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,MAX(M,P))
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix.
          On exit, the leading NQ-by-M part of this array contains
          the leading NQ-by-M part of the matrix Z'*(B+H*D), the
          input/state matrix of the numerator factor Q.
          The remaining part of this array is needed as workspace.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-NQ part of this array contains
          the leading P-by-NQ part of the matrix V*C*Z, the
          state/output matrix of the numerator factor Q.
          The first NR columns of this array represent the
          state/output matrix of a minimal realization of the
          denominator factor R.
          The remaining part of this array is needed as workspace.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,M,P), if N > 0.
          LDC >= 1,          if N = 0.

  D       (input/output) DOUBLE PRECISION array, dimension
          (LDD,MAX(M,P))
          On entry, the leading P-by-M part of this array must
          contain the input/output matrix.
          On exit, the leading P-by-M part of this array contains
          the matrix V*D representing the input/output matrix
          of the numerator factor Q.
          The remaining part of this array is needed as workspace.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,M,P).

  NQ      (output) INTEGER
          The order of the resulting factors Q and R.
          Generally, NQ = N - NS, where NS is the number of
          unobservable eigenvalues outside the stability region.

  NR      (output) INTEGER
          The order of the minimal realization of the factor R.
          Generally, NR is the number of observable eigenvalues
          of A outside the stability region (the number of modified
          eigenvalues).

  BR      (output) DOUBLE PRECISION array, dimension (LDBR,P)
          The leading NQ-by-P part of this array contains the
          leading NQ-by-P part of the output injection matrix
          Z'*H, which reflects the eigenvalues of A lying outside
          the stable region to values which are symmetric with
          respect to the imaginary axis (if DICO = 'C') or the unit
          circle (if DICO = 'D'). The first NR rows of this matrix
          form the input/state matrix of a minimal realization of
          the denominator factor R.

  LDBR    INTEGER
          The leading dimension of array BR.  LDBR >= MAX(1,N).

  DR      (output) DOUBLE PRECISION array, dimension (LDDR,P)
          The leading P-by-P part of this array contains the lower
          triangular matrix V representing the input/output matrix
          of the denominator factor R.

  LDDR    INTEGER
          The leading dimension of array DR.  LDDR >= MAX(1,P).
Tolerances 
  TOL     DOUBLE PRECISION
          The absolute tolerance level below which the elements of
          C are considered zero (used for observability tests).
          If the user sets TOL <= 0, then an implicitly computed,
          default tolerance, defined by  TOLDEF = N*EPS*NORM(C),
          is used instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH) and NORM(C) denotes
          the infinity-norm of C.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LDWORK >= MAX( 1, P*N + MAX( N*(N+5),P*(P+2),4*P,4*M ) ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = K:  K violations of the numerical stability condition
                NORM(H) <= 10*NORM(A)/NORM(C) occured during the
                assignment of eigenvalues.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the ordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + H*C)*Z
                along the diagonal;
          = 3:  if DICO = 'C' and the matrix A has an observable
                eigenvalue on the imaginary axis, or DICO = 'D' and
                A has an observable eigenvalue on the unit circle.
Method 
  The subroutine uses the right coprime factorization algorithm with
  inner denominator of [1] applied to G'.
References 
  [1] Varga A.
      A Schur method for computing coprime factorizations with
      inner denominators and applications in model reduction.
      Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
Numerical Aspects 
                                         3
  The algorithm requires no more than 14N  floating point
  operations.
Further Comments 
  None
Example

Program Text 

*     SB08CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MPMAX
      PARAMETER        ( MPMAX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDBR, LDC, LDD, LDDR
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDBR = NMAX,
     $                   LDC = MPMAX, LDD = MPMAX, LDDR = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*PMAX + MAX( NMAX*( NMAX + 5 ),
     $                            PMAX*( PMAX + 2 ), 4*PMAX, 4*MMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, IWARN, J, M, N, NQ, NR, P
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MPMAX), BR(LDBR,PMAX),
     $                 C(LDC,NMAX), D(LDD,MPMAX), DR(LDDR,PMAX),
     $                 DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         SB08CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P )
*              Find a RCFID for (A,B,C,D).
               CALL SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC,
     $                      D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL,
     $                      DWORK, LDWORK, IWARN, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ )
   20             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   40             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M )
   70             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 )
                  DO 80 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( A(I,J), J = 1, NR )
   80             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 )
                  DO 90 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( BR(I,J), J = 1, P )
   90             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 )
                  DO 100 I = 1, P
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( C(I,J), J = 1, NR )
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99983 )
                  DO 110 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, P )
  110             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB08CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08CD = ',I2)
99996 FORMAT (/' The numerator state dynamics matrix AQ is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The numerator input/state matrix BQ is ')
99992 FORMAT (/' The numerator state/output matrix CQ is ')
99991 FORMAT (/' The numerator input/output matrix DQ is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99986 FORMAT (/' The denominator state dynamics matrix AR is ')
99985 FORMAT (/' The denominator input/state matrix BR is ')
99984 FORMAT (/' The denominator state/output matrix CR is ')
99983 FORMAT (/' The denominator input/output matrix DR is ')
      END
Program Data 
 SB08CD EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3   1.E-10 C
 -0.04165  0.0000  4.9200   0.4920  0.0000   0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000   0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000   0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000  0.0545   0.0000  0.0000
  0.0000   0.0000  0.0000  -0.49200 0.004165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000  0.5210  -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000   3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 SB08CD EXAMPLE PROGRAM RESULTS


 The numerator state dynamics matrix AQ is 
  -0.1605   0.0523   0.9423   2.0193   0.4166   0.2518   1.6140
  -0.4489  -0.1605   1.7955   3.8719  -0.2394   0.0491  -0.8740
   0.0000   0.0000 -12.4245   3.5463  -0.0057   0.0254  -0.0053
   0.0000   0.0000   0.0000  -3.5957  -0.0153  -0.0290  -0.0616
   0.0000   0.0000   0.0000   0.0000 -13.1627  -1.9835  -3.6182
   0.0000   0.0000   0.0000   0.0000   0.0000  -1.4178   5.6218
   0.0000   0.0000   0.0000   0.0000   0.0000  -0.8374  -1.4178

 The numerator input/state matrix BQ is 
  -1.0157   0.2554
   0.5523   0.4443
   0.0056 -11.6989
   0.0490   4.3728
  11.7198  -0.0038
  -2.8173   0.0308
   3.1018  -0.0009

 The numerator state/output matrix CQ is 
   0.1975  -0.1063  -0.0006  -0.0083   0.1279   0.8797   0.3994
   0.8541  -0.4513  -0.0007  -0.0041   0.0305  -0.2562   0.0122
   0.4668   0.8826   0.0248  -0.0506   0.0000   0.0022  -0.0017

 The numerator input/output matrix DQ is 
   0.0000   0.0000
   0.0000   0.0000
   0.0000   0.0000

 The denominator state dynamics matrix AR is 
  -0.1605   0.0523
  -0.4489  -0.1605

 The denominator input/state matrix BR is 
  -0.0158  -0.0692  -0.1688
   0.0306   0.1281  -0.4984

 The denominator state/output matrix CR is 
   0.1975  -0.1063
   0.8541  -0.4513
   0.4668   0.8826

 The denominator input/output matrix DR is 
   1.0000   0.0000   0.0000
   0.0000   1.0000   0.0000
   0.0000   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08DD.html000077500000000000000000000402321201767322700160710ustar00rootroot00000000000000 SB08DD - SLICOT Library Routine Documentation

SB08DD

Right coprime factorization with inner denominator

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct, for a given system G = (A,B,C,D), a feedback matrix
  F, an orthogonal transformation matrix Z, and a gain matrix V,
  such that the systems

       Q = (Z'*(A+B*F)*Z, Z'*B*V, (C+D*F)*Z, D*V)
  and
       R = (Z'*(A+B*F)*Z, Z'*B*V, F*Z, V)

  provide a stable right coprime factorization of G in the form
                    -1
           G = Q * R  ,

  where G, Q and R are the corresponding transfer-function matrices
  and the denominator R is inner, that is, R'(-s)*R(s) = I in the
  continuous-time case, or R'(1/z)*R(z) = I in the discrete-time
  case. The Z matrix is not explicitly computed.

  Note: G must have no controllable poles on the imaginary axis
  for a continuous-time system, or on the unit circle for a
  discrete-time system. If the given state-space representation
  is not stabilizable, the unstabilizable part of the original
  system is automatically deflated and the order of the systems
  Q and R is accordingly reduced.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector, i.e. the order of the
          matrix A, and also the number of rows of the matrix B and
          the number of columns of the matrices C and CR.  N >= 0.

  M       (input) INTEGER
          The dimension of input vector, i.e. the number of columns
          of the matrices B, D and DR and the number of rows of the
          matrices CR and DR.  M >= 0.

  P       (input) INTEGER
          The dimension of output vector, i.e. the number of rows
          of the matrices C and D.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A. The matrix A must not
          have controllable eigenvalues on the imaginary axis, if
          DICO = 'C', or on the unit circle, if DICO = 'D'.
          On exit, the leading NQ-by-NQ part of this array contains
          the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the
          state dynamics matrix of the numerator factor Q, in a
          real Schur form. The trailing NR-by-NR part of this matrix
          represents the state dynamics matrix of a minimal
          realization of the denominator factor R.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix.
          On exit, the leading NQ-by-M part of this array contains
          the leading NQ-by-M part of the matrix Z'*B*V, the
          input/state matrix of the numerator factor Q. The last
          NR rows of this matrix form the input/state matrix of
          a minimal realization of the denominator factor R.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-NQ part of this array contains
          the leading P-by-NQ part of the matrix (C+D*F)*Z,
          the state/output matrix of the numerator factor Q.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the input/output matrix.
          On exit, the leading P-by-M part of this array contains
          the matrix D*V representing the input/output matrix
          of the numerator factor Q.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NQ      (output) INTEGER
          The order of the resulting factors Q and R.
          Generally, NQ = N - NS, where NS is the number of
          uncontrollable eigenvalues outside the stability region.

  NR      (output) INTEGER
          The order of the minimal realization of the factor R.
          Generally, NR is the number of controllable eigenvalues
          of A outside the stability region (the number of modified
          eigenvalues).

  CR      (output) DOUBLE PRECISION array, dimension (LDCR,N)
          The leading M-by-NQ part of this array contains the
          leading M-by-NQ part of the feedback matrix F*Z, which
          reflects the eigenvalues of A lying outside the stable
          region to values which are symmetric with respect to the
          imaginary axis (if DICO = 'C') or the unit circle (if
          DICO = 'D').  The last NR columns of this matrix form the
          state/output matrix of a minimal realization of the
          denominator factor R.

  LDCR    INTEGER
          The leading dimension of array CR.  LDCR >= MAX(1,M).

  DR      (output) DOUBLE PRECISION array, dimension (LDDR,M)
          The leading M-by-M part of this array contains the upper
          triangular matrix V of order M representing the
          input/output matrix of the denominator factor R.

  LDDR    INTEGER
          The leading dimension of array DR.  LDDR >= MAX(1,M).
Tolerances 
  TOL     DOUBLE PRECISION
          The absolute tolerance level below which the elements of
          B are considered zero (used for controllability tests).
          If the user sets TOL <= 0, then an implicitly computed,
          default tolerance, defined by  TOLDEF = N*EPS*NORM(B),
          is used instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH) and NORM(B) denotes
          the 1-norm of B.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LDWORK >= MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = K:  K violations of the numerical stability condition
                NORM(F) <= 10*NORM(A)/NORM(B) occured during the
                assignment of eigenvalues.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the ordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + B*F)*Z
                along the diagonal;
          = 3:  if DICO = 'C' and the matrix A has a controllable
                eigenvalue on the imaginary axis, or DICO = 'D'
                and A has a controllable eigenvalue on the unit
                circle.
Method 
  The subroutine is based on the factorization algorithm of [1].
References 
  [1] Varga A.
      A Schur method for computing coprime factorizations with inner
      denominators and applications in model reduction.
      Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
Numerical Aspects 
                                         3
  The algorithm requires no more than 14N  floating point
  operations.
Further Comments 
  None
Example

Program Text 

*     SB08DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDCR, LDD, LDDR
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDCR = MMAX, LDD = PMAX, LDDR = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*( NMAX + 5 ),
     $                                 MMAX*( MMAX + 2 ),
     $                                 4*NMAX, 4*PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, IWARN, J, M, N, NQ, NR, P
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 CR(LDCR,NMAX), D(LDD,MMAX), DR(LDDR,MMAX),
     $                 DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         SB08DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P )
*              Find a RCFID for (A,B,C,D).
               CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC,
     $                      D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL,
     $                      DWORK, LDWORK, IWARN, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ )
   20             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   40             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M )
   70             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 )
                  DO 80 I = NQ-NR+1, NQ
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( A(I,J), J = NQ-NR+1, NQ )
   80             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 )
                  DO 90 I = NQ-NR+1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   90             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 )
                  DO 100 I = 1, M
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( CR(I,J), J = NQ-NR+1, NQ )
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99983 )
                  DO 110 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, M )
  110             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB08DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08DD = ',I2)
99996 FORMAT (/' The numerator state dynamics matrix AQ is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The numerator input/state matrix BQ is ')
99992 FORMAT (/' The numerator state/output matrix CQ is ')
99991 FORMAT (/' The numerator input/output matrix DQ is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99986 FORMAT (/' The denominator state dynamics matrix AR is ')
99985 FORMAT (/' The denominator input/state matrix BR is ')
99984 FORMAT (/' The denominator state/output matrix CR is ')
99983 FORMAT (/' The denominator input/output matrix DR is ')
      END
Program Data 
 SB08DD EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3   1.E-10 C
 -0.04165  0.0000  4.9200   0.4920  0.0000   0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000   0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000   0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000  0.0545   0.0000  0.0000
  0.0000   0.0000  0.0000  -0.49200 0.004165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000  0.5210  -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000   3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 SB08DD EXAMPLE PROGRAM RESULTS


 The numerator state dynamics matrix AQ is 
  -1.4178  -5.1682   3.2450  -0.2173   0.0564  -4.1066  -0.2336
   0.9109  -1.4178  -2.1262   0.1231   0.0805  -0.4816   0.2196
   0.0000   0.0000 -13.1627   0.0608  -0.0218   3.8320   0.3429
   0.0000   0.0000   0.0000  -3.5957  -3.3373   0.0816  -4.1237
   0.0000   0.0000   0.0000   0.0000 -12.4245  -0.3133   4.4255
   0.0000   0.0000   0.0000   0.0000   0.0000  -0.1605  -0.0772
   0.0000   0.0000   0.0000   0.0000   0.0000   0.3040  -0.1605

 The numerator input/state matrix BQ is 
   5.0302  -0.0063
   0.7078  -0.0409
 -11.3663   0.0051
   0.1760   0.5879
  -0.0265  12.2119
   1.1050   0.3215
   0.0066  -2.5822

 The numerator state/output matrix CQ is 
  -0.8659   0.2787  -0.3432   0.0020   0.0000   0.2325   0.0265
   0.0797  -0.3951   0.0976  -0.0292   0.0062   0.8985   0.1406
  -0.0165  -0.0645   0.0097   0.8032  -0.1602   0.0874  -0.5630

 The numerator input/output matrix DQ is 
   0.0000   0.0000
   0.0000   0.0000
   0.0000   0.0000

 The denominator state dynamics matrix AR is 
  -0.1605  -0.0772
   0.3040  -0.1605

 The denominator input/state matrix BR is 
   1.1050   0.3215
   0.0066  -2.5822

 The denominator state/output matrix CR is 
  -0.2288  -0.0259
  -0.0070   0.1497

 The denominator input/output matrix DR is 
   1.0000   0.0000
   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08ED.html000077500000000000000000000411031201767322700160700ustar00rootroot00000000000000 SB08ED - SLICOT Library Routine Documentation

SB08ED

Left coprime factorization with prescribed stability degree

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct, for a given system G = (A,B,C,D), an output
  injection matrix H and an orthogonal transformation matrix Z, such
  that the systems

       Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), C*Z, D)
  and
       R = (Z'*(A+H*C)*Z, Z'*H, C*Z, I)

  provide a stable left coprime factorization of G in the form
                -1
           G = R  * Q,

  where G, Q and R are the corresponding transfer-function matrices.
  The resulting state dynamics matrix of the systems Q and R has
  eigenvalues lying inside a given stability domain.
  The Z matrix is not explicitly computed.

  Note: If the given state-space representation is not detectable,
  the undetectable part of the original system is automatically
  deflated and the order of the systems Q and R is accordingly
  reduced.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector, i.e. the order of the
          matrix A, and also the number of rows of the matrices B
          and BR, and the number of columns of the matrix C.
          N >= 0.

  M       (input) INTEGER
          The dimension of input vector, i.e. the number of columns
          of the matrices B and D.  M >= 0.

  P       (input) INTEGER
          The dimension of output vector, i.e. the number of rows
          of the matrices C, D and DR, and the number of columns of
          the matrices BR and DR.  P >= 0.

  ALPHA   (input) DOUBLE PRECISION array, dimension (2)
          ALPHA(1) contains the desired stability degree to be
          assigned for the eigenvalues of A+H*C, and ALPHA(2)
          the stability margin. The eigenvalues outside the
          ALPHA(2)-stability region will be assigned to have the
          real parts equal to ALPHA(1) < 0 and unmodified
          imaginary parts for a continuous-time system
          (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1
          for a discrete-time system (DICO = 'D').

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading NQ-by-NQ part of this array contains
          the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the
          state dynamics matrix of the numerator factor Q, in a
          real Schur form. The leading NR-by-NR part of this matrix
          represents the state dynamics matrix of a minimal
          realization of the denominator factor R.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,MAX(M,P))
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix of the system.
          On exit, the leading NQ-by-M part of this array contains
          the leading NQ-by-M part of the matrix Z'*(B+H*D), the
          input/state matrix of the numerator factor Q.
          The remaining part of this array is needed as workspace.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix of the system.
          On exit, the leading P-by-NQ part of this array contains
          the leading P-by-NQ part of the matrix C*Z, the
          state/output matrix of the numerator factor Q.
          The first NR columns of this array represent the
          state/output matrix of a minimal realization of the
          denominator factor R.
          The remaining part of this array is needed as workspace.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,M,P), if N > 0.
          LDC >= 1,          if N = 0.

  D       (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
          The leading P-by-M part of this array must contain the
          input/output matrix. D represents also the input/output
          matrix of the numerator factor Q.
          This array is modified internally, but restored on exit.
          The remaining part of this array is needed as workspace.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,M,P).

  NQ      (output) INTEGER
          The order of the resulting factors Q and R.
          Generally, NQ = N - NS, where NS is the number of
          unobservable eigenvalues outside the stability region.

  NR      (output) INTEGER
          The order of the minimal realization of the factor R.
          Generally, NR is the number of observable eigenvalues
          of A outside the stability region (the number of modified
          eigenvalues).

  BR      (output) DOUBLE PRECISION array, dimension (LDBR,P)
          The leading NQ-by-P part of this array contains the
          leading NQ-by-P part of the output injection matrix
          Z'*H, which moves the eigenvalues of A lying outside
          the ALPHA-stable region to values on the ALPHA-stability
          boundary. The first NR rows of this matrix form the
          input/state matrix of a minimal realization of the
          denominator factor R.

  LDBR    INTEGER
          The leading dimension of array BR.  LDBR >= MAX(1,N).

  DR      (output) DOUBLE PRECISION array, dimension (LDDR,P)
          The leading P-by-P part of this array contains an
          identity matrix representing the input/output matrix
          of the denominator factor R.

  LDDR    INTEGER
          The leading dimension of array DR.  LDDR >= MAX(1,P).
Tolerances 
  TOL     DOUBLE PRECISION
          The absolute tolerance level below which the elements of
          C are considered zero (used for observability tests).
          If the user sets TOL <= 0, then an implicitly computed,
          default tolerance, defined by  TOLDEF = N*EPS*NORM(C),
          is used instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH) and NORM(C) denotes
          the infinity-norm of C.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LDWORK >= MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = K:  K violations of the numerical stability condition
                NORM(H) <= 10*NORM(A)/NORM(C) occured during the
                assignment of eigenvalues.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the ordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + H*C)*Z
                along the diagonal.
Method 
  The subroutine uses the right coprime factorization algorithm
  of [1] applied to G'.
References 
  [1] Varga A.
      Coprime factors model reduction method based on
      square-root balancing-free techniques.
      System Analysis, Modelling and Simulation,
      vol. 11, pp. 303-311, 1993.
Numerical Aspects 
                                         3
  The algorithm requires no more than 14N  floating point
  operations.
Further Comments 
  None
Example

Program Text 

*     SB08ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MPMAX
      PARAMETER        ( MPMAX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDBR, LDC, LDD, LDDR
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MPMAX,
     $                   LDD = MPMAX, LDBR = NMAX, LDDR = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*PMAX + MAX( NMAX*( NMAX + 5 ),
     $                                             5*PMAX, 4*MMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, IWARN, J, M, N, NQ, NR, P
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALPHA(2), B(LDB,MPMAX),
     $                 BR(LDBR,PMAX), C(LDC,NMAX), D(LDD,MPMAX),
     $                 DR(LDDR,PMAX), DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         SB08ED
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, ALPHA(1), TOL, DICO
      ALPHA(2) = ALPHA(1)
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P )
*              Find a LCF for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ )
   20             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   40             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M )
   70             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 )
                  DO 80 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( A(I,J), J = 1, NR )
   80             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 )
                  DO 90 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( BR(I,J), J = 1, P )
   90             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 )
                  DO 100 I = 1, P
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( C(I,J), J = 1, NR )
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99983 )
                  DO 110 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, P )
  110             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB08ED EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08ED = ',I2)
99996 FORMAT (/' The numerator state dynamics matrix AQ is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The numerator input/state matrix BQ is ')
99992 FORMAT (/' The numerator state/output matrix CQ is ')
99991 FORMAT (/' The numerator input/output matrix DQ is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99986 FORMAT (/' The denominator state dynamics matrix AR is ')
99985 FORMAT (/' The denominator input/state matrix BR is ')
99984 FORMAT (/' The denominator state/output matrix CR is ')
99983 FORMAT (/' The denominator input/output matrix DR is ')
      END
Program Data 
 SB08ED EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3 -1.0   1.E-10 C
 -0.04165  0.0000  4.9200   0.4920  0.0000   0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000   0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000   0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000  0.0545   0.0000  0.0000
  0.0000   0.0000  0.0000  -0.49200 0.004165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000  0.5210  -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000   3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 SB08ED EXAMPLE PROGRAM RESULTS


 The numerator state dynamics matrix AQ is 
  -1.0000   0.0526  -0.1408  -0.3060   0.4199   0.2408   1.7274
  -0.4463  -1.0000   2.0067   4.3895   0.0062   0.1813   0.0895
   0.0000   0.0000 -12.4245   3.5463  -0.0057   0.0254  -0.0053
   0.0000   0.0000   0.0000  -3.5957  -0.0153  -0.0290  -0.0616
   0.0000   0.0000   0.0000   0.0000 -13.1627  -1.9835  -3.6182
   0.0000   0.0000   0.0000   0.0000   0.0000  -1.4178   5.6218
   0.0000   0.0000   0.0000   0.0000   0.0000  -0.8374  -1.4178

 The numerator input/state matrix BQ is 
  -1.1544  -0.0159
  -0.0631   0.5122
   0.0056 -11.6989
   0.0490   4.3728
  11.7198  -0.0038
  -2.8173   0.0308
   3.1018  -0.0009

 The numerator state/output matrix CQ is 
   0.2238   0.0132  -0.0006  -0.0083   0.1279   0.8797   0.3994
   0.9639   0.0643  -0.0007  -0.0041   0.0305  -0.2562   0.0122
  -0.0660   0.9962   0.0248  -0.0506   0.0000   0.0022  -0.0017

 The numerator input/output matrix DQ is 
   0.0000   0.0000
   0.0000   0.0000
   0.0000   0.0000

 The denominator state dynamics matrix AR is 
  -1.0000   0.0526
  -0.4463  -1.0000

 The denominator input/state matrix BR is 
  -0.2623  -1.1297   0.0764
  -0.0155  -0.0752  -1.1676

 The denominator state/output matrix CR is 
   0.2238   0.0132
   0.9639   0.0643
  -0.0660   0.9962

 The denominator input/output matrix DR is 
   1.0000   0.0000   0.0000
   0.0000   1.0000   0.0000
   0.0000   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08FD.html000077500000000000000000000377311201767322700161050ustar00rootroot00000000000000 SB08FD - SLICOT Library Routine Documentation

SB08FD

Right coprime factorization with prescribed stability degree

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct, for a given system G = (A,B,C,D), a feedback
  matrix F and an orthogonal transformation matrix Z, such that
  the systems

       Q = (Z'*(A+B*F)*Z, Z'*B, (C+D*F)*Z, D)
  and
       R = (Z'*(A+B*F)*Z, Z'*B, F*Z, I)

  provide a stable right coprime factorization of G in the form
                    -1
           G = Q * R  ,

  where G, Q and R are the corresponding transfer-function matrices.
  The resulting state dynamics matrix of the systems Q and R has
  eigenvalues lying inside a given stability domain.
  The Z matrix is not explicitly computed.

  Note: If the given state-space representation is not stabilizable,
  the unstabilizable part of the original system is automatically
  deflated and the order of the systems Q and R is accordingly
  reduced.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the state vector, i.e. the order of the
          matrix A, and also the number of rows of the matrix B and
          the number of columns of the matrices C and CR.  N >= 0.

  M       (input) INTEGER
          The dimension of input vector, i.e. the number of columns
          of the matrices B, D and DR and the number of rows of the
          matrices CR and DR.  M >= 0.

  P       (input) INTEGER
          The dimension of output vector, i.e. the number of rows
          of the matrices C and D.  P >= 0.

  ALPHA   (input) DOUBLE PRECISION array, dimension (2)
          ALPHA(1) contains the desired stability degree to be
          assigned for the eigenvalues of A+B*F, and ALPHA(2)
          the stability margin. The eigenvalues outside the
          ALPHA(2)-stability region will be assigned to have the
          real parts equal to ALPHA(1) < 0 and unmodified
          imaginary parts for a continuous-time system
          (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1
          for a discrete-time system (DICO = 'D').

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading NQ-by-NQ part of this array contains
          the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the
          state dynamics matrix of the numerator factor Q, in a
          real Schur form. The trailing NR-by-NR part of this matrix
          represents the state dynamics matrix of a minimal
          realization of the denominator factor R.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix.
          On exit, the leading NQ-by-M part of this array contains
          the leading NQ-by-M part of the matrix Z'*B, the
          input/state matrix of the numerator factor Q. The last
          NR rows of this matrix form the input/state matrix of
          a minimal realization of the denominator factor R.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-NQ part of this array contains
          the leading P-by-NQ part of the matrix (C+D*F)*Z,
          the state/output matrix of the numerator factor Q.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          input/output matrix. D represents also the input/output
          matrix of the numerator factor Q.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  NQ      (output) INTEGER
          The order of the resulting factors Q and R.
          Generally, NQ = N - NS, where NS is the number of
          uncontrollable eigenvalues outside the stability region.

  NR      (output) INTEGER
          The order of the minimal realization of the factor R.
          Generally, NR is the number of controllable eigenvalues
          of A outside the stability region (the number of modified
          eigenvalues).

  CR      (output) DOUBLE PRECISION array, dimension (LDCR,N)
          The leading M-by-NQ part of this array contains the
          leading M-by-NQ part of the feedback matrix F*Z, which
          moves the eigenvalues of A lying outside the ALPHA-stable
          region to values which are on the ALPHA-stability
          boundary.  The last NR columns of this matrix form the
          state/output matrix of a minimal realization of the
          denominator factor R.

  LDCR    INTEGER
          The leading dimension of array CR.  LDCR >= MAX(1,M).

  DR      (output) DOUBLE PRECISION array, dimension (LDDR,M)
          The leading M-by-M part of this array contains an
          identity matrix representing the input/output matrix
          of the denominator factor R.

  LDDR    INTEGER
          The leading dimension of array DR.  LDDR >= MAX(1,M).
Tolerances 
  TOL     DOUBLE PRECISION
          The absolute tolerance level below which the elements of
          B are considered zero (used for controllability tests).
          If the user sets TOL <= 0, then an implicitly computed,
          default tolerance, defined by  TOLDEF = N*EPS*NORM(B),
          is used instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH) and NORM(B) denotes
          the 1-norm of B.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LWORK >= MAX( 1, N*(N+5), 5*M, 4*P ).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = K:  K violations of the numerical stability condition
                NORM(F) <= 10*NORM(A)/NORM(B) occured during the
                assignment of eigenvalues.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A to a real Schur form failed;
          = 2:  a failure was detected during the ordering of the
                real Schur form of A, or in the iterative process
                for reordering the eigenvalues of Z'*(A + B*F)*Z
                along the diagonal.
Method 
  The subroutine is based on the factorization algorithm of [1].
References 
  [1] Varga A.
      Coprime factors model reduction method based on
      square-root balancing-free techniques.
      System Analysis, Modelling and Simulation,
      vol. 11, pp. 303-311, 1993.
Numerical Aspects 
                                         3
  The algorithm requires no more than 14N  floating point
  operations.
Further Comments 
  None
Example

Program Text 

*     SB08FD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDCR, LDD, LDDR
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDCR = MMAX, LDD = PMAX, LDDR = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*( NMAX + 5 ), 5*MMAX,
     $                                 4*PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, IWARN, J, M, N, NQ, NR, P
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALPHA(2), B(LDB,MMAX), C(LDC,NMAX),
     $                 CR(LDCR,NMAX), D(LDD,MMAX), DR(LDDR,MMAX),
     $                 DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         SB08FD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, ALPHA(1), TOL, DICO
      ALPHA(2) = ALPHA(1)
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P )
*              Find a RCF for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ )
   20             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   40             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M )
   70             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 )
                  DO 80 I = NQ-NR+1, NQ
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( A(I,J), J = NQ-NR+1, NQ )
   80             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 )
                  DO 90 I = NQ-NR+1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   90             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 )
                  DO 100 I = 1, M
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( CR(I,J), J = NQ-NR+1, NQ )
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99983 )
                  DO 110 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, M )
  110             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB08FD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08FD = ',I2)
99996 FORMAT (/' The numerator state dynamics matrix AQ is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The numerator input/state matrix BQ is ')
99992 FORMAT (/' The numerator state/output matrix CQ is ')
99991 FORMAT (/' The numerator input/output matrix DQ is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99986 FORMAT (/' The denominator state dynamics matrix AR is ')
99985 FORMAT (/' The denominator input/state matrix BR is ')
99984 FORMAT (/' The denominator state/output matrix CR is ')
99983 FORMAT (/' The denominator input/output matrix DR is ')
      END
Program Data 
 SB08FD EXAMPLE PROGRAM DATA (Continuous system)
  7  2  3 -1.0   1.E-10 C
 -0.04165  0.0000  4.9200   0.4920  0.0000   0.0000  0.0000
 -5.2100  -12.500  0.0000   0.0000  0.0000   0.0000  0.0000
  0.0000   3.3300 -3.3300   0.0000  0.0000   0.0000  0.0000
  0.5450   0.0000  0.0000   0.0000  0.0545   0.0000  0.0000
  0.0000   0.0000  0.0000  -0.49200 0.004165 0.0000  4.9200
  0.0000   0.0000  0.0000   0.0000  0.5210  -12.500  0.0000
  0.0000   0.0000  0.0000   0.0000  0.0000   3.3300 -3.3300
  0.0000   0.0000
  12.500   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   0.0000
  0.0000   12.500
  0.0000   0.0000
  1.0000   0.0000  0.0000   0.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   1.0000  0.0000  0.0000  0.0000
  0.0000   0.0000  0.0000   0.0000  1.0000  0.0000  0.0000
  0.0000   0.0000  
  0.0000   0.0000  
  0.0000   0.0000
Program Results 
 SB08FD EXAMPLE PROGRAM RESULTS


 The numerator state dynamics matrix AQ is 
  -1.4178  -5.1682   3.2450  -0.2173   0.0564  -3.2129  -3.6183
   0.9109  -1.4178  -2.1262   0.1231   0.0805  -0.4392  -0.2528
   0.0000   0.0000 -13.1627   0.0608  -0.0218   2.3461   5.8272
   0.0000   0.0000   0.0000  -3.5957  -3.3373   1.3622  -3.6083
   0.0000   0.0000   0.0000   0.0000 -12.4245  -9.8634   8.1191
   0.0000   0.0000   0.0000   0.0000   0.0000  -1.0000  -0.0135
   0.0000   0.0000   0.0000   0.0000   0.0000   1.7393  -1.0000

 The numerator input/state matrix BQ is 
   5.0302  -0.0063
   0.7078  -0.0409
 -11.3663   0.0051
   0.1760   0.5879
  -0.0265  12.2119
   1.0104   1.3262
   0.4474  -2.2388

 The numerator state/output matrix CQ is 
  -0.8659   0.2787  -0.3432   0.0020   0.0000   0.2026   0.1172
   0.0797  -0.3951   0.0976  -0.0292   0.0062   0.7676   0.4879
  -0.0165  -0.0645   0.0097   0.8032  -0.1602   0.3050  -0.4812

 The numerator input/output matrix DQ is 
   0.0000   0.0000
   0.0000   0.0000
   0.0000   0.0000

 The denominator state dynamics matrix AR is 
  -1.0000  -0.0135
   1.7393  -1.0000

 The denominator input/state matrix BR is 
   1.0104   1.3262
   0.4474  -2.2388

 The denominator state/output matrix CR is 
  -0.1091  -0.4653
  -0.7055   0.4766

 The denominator input/output matrix DR is 
   1.0000   0.0000
   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08GD.html000077500000000000000000000137271201767322700161050ustar00rootroot00000000000000 SB08GD - SLICOT Library Routine Documentation

SB08GD

State-space representation of a left coprime factorization

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the state-space representation for the system
  G = (A,B,C,D) from the factors Q = (AQR,BQ,CQR,DQ) and
  R = (AQR,BR,CQR,DR) of its left coprime factorization
                -1
           G = R  * Q,

  where G, Q and R are the corresponding transfer-function matrices.
Specification 
      SUBROUTINE SB08GD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, BR,
     $                   LDBR, DR, LDDR, IWORK, DWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A. Also the number of rows of the
          matrices B and BR and the number of columns of the matrix
          C. N represents the order of the systems Q and R.  N >= 0.

  M       (input) INTEGER
          The dimension of input vector, i.e. the number of columns
          of the matrices B and D.  M >= 0.

  P       (input) INTEGER
          The dimension of output vector, i.e. the number of rows of
          the matrices C, D and DR and the number of columns of the
          matrices BR and DR.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix AQR of the systems
          Q and R.
          On exit, the leading N-by-N part of this array contains
          the state dynamics matrix of the system G.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix BQ of the system Q.
          On exit, the leading N-by-M part of this array contains
          the input/state matrix of the system G.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix CQR of the systems
          Q and R.
          On exit, the leading P-by-N part of this array contains
          the state/output matrix of the system G.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the input/output matrix DQ of the system Q.
          On exit, the leading P-by-M part of this array contains
          the input/output matrix of the system G.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  BR      (input) DOUBLE PRECISION array, dimension (LDBR,P)
          The leading N-by-P part of this array must contain the
          input/state matrix BR of the system R.

  LDBR    INTEGER
          The leading dimension of array BR.  LDBR >= MAX(1,N).

  DR      (input/output) DOUBLE PRECISION array, dimension (LDDR,P)
          On entry, the leading P-by-P part of this array must
          contain the input/output matrix DR of the system R.
          On exit, the leading P-by-P part of this array contains
          the LU factorization of the matrix DR, as computed by
          LAPACK Library routine DGETRF.

  LDDR    INTEGER
          The leading dimension of array DR.  LDDR >= MAX(1,P).
Workspace 
  IWORK   INTEGER array, dimension (P)

  DWORK   DOUBLE PRECISION array, dimension (MAX(1,4*P))
          On exit, DWORK(1) contains an estimate of the reciprocal
          condition number of the matrix DR.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the matrix DR is singular;
          = 2:  the matrix DR is numerically singular (warning);
                the calculations continued.
Method 
  The subroutine computes the matrices of the state-space
  representation G = (A,B,C,D) by using the formulas:

                   -1              -1
  A = AQR - BR * DR  * CQR,  C = DR  * CQR,
                   -1              -1
  B = BQ  - BR * DR  * DQ,   D = DR  * DQ.
References 
  [1] Varga A.
      Coprime factors model reduction method based on
      square-root balancing-free techniques.
      System Analysis, Modelling and Simulation,
      vol. 11, pp. 303-311, 1993.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08HD.html000077500000000000000000000137501201767322700161020ustar00rootroot00000000000000 SB08HD - SLICOT Library Routine Documentation

SB08HD

State-space representation of a right coprime factorization

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the state-space representation for the system
  G = (A,B,C,D) from the factors Q = (AQR,BQR,CQ,DQ) and
  R = (AQR,BQR,CR,DR) of its right coprime factorization
                    -1
           G = Q * R  ,

  where G, Q and R are the corresponding transfer-function matrices.
Specification 
      SUBROUTINE SB08HD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, CR,
     $                   LDCR, DR, LDDR, IWORK, DWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A. Also the number of rows of the
          matrix B and the number of columns of the matrices C and
          CR. N represents the order of the systems Q and R.
          N >= 0.

  M       (input) INTEGER
          The dimension of input vector. Also the number of columns
          of the matrices B, D and DR and the number of rows of the
          matrices CR and DR.  M >= 0.

  P       (input) INTEGER
          The dimension of output vector. Also the number of rows
          of the matrices C and D.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix AQR of the systems
          Q and R.
          On exit, the leading N-by-N part of this array contains
          the state dynamics matrix of the system G.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix BQR of the systems Q and R.
          On exit, the leading N-by-M part of this array contains
          the input/state matrix of the system G.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix CQ of the system Q.
          On exit, the leading P-by-N part of this array contains
          the state/output matrix of the system G.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the input/output matrix DQ of the system Q.
          On exit, the leading P-by-M part of this array contains
          the input/output matrix of the system G.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  CR      (input) DOUBLE PRECISION array, dimension (LDCR,N)
          The leading M-by-N part of this array must contain the
          state/output matrix CR of the system R.

  LDCR    INTEGER
          The leading dimension of array CR.  LDCR >= MAX(1,M).

  DR      (input/output) DOUBLE PRECISION array, dimension (LDDR,M)
          On entry, the leading M-by-M part of this array must
          contain the input/output matrix DR of the system R.
          On exit, the leading M-by-M part of this array contains
          the LU factorization of the matrix DR, as computed by
          LAPACK Library routine DGETRF.

  LDDR    INTEGER
          The leading dimension of array DR.  LDDR >= MAX(1,M).
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (MAX(1,4*M))
          On exit, DWORK(1) contains an estimate of the reciprocal
          condition number of the matrix DR.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the matrix DR is singular;
          = 2:  the matrix DR is numerically singular (warning);
                the calculations continued.
Method 
  The subroutine computes the matrices of the state-space
  representation G = (A,B,C,D) by using the formulas:

                    -1                   -1
  A = AQR - BQR * DR  * CR,  B = BQR * DR  ,
                   -1                   -1
  C = CQ  - DQ * DR  * CR,   D = DQ * DR  .
References 
  [1] Varga A.
      Coprime factors model reduction method based on
      square-root balancing-free techniques.
      System Analysis, Modelling and Simulation,
      vol. 11, pp. 303-311, 1993.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08MD.html000077500000000000000000000234171201767322700161100ustar00rootroot00000000000000 SB08MD - SLICOT Library Routine Documentation

SB08MD

Spectral factorization of polynomials (continuous-time case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a real polynomial E(s) such that

     (a)  E(-s) * E(s) = A(-s) * A(s) and
     (b)  E(s) is stable - that is, all the zeros of E(s) have
          non-positive real parts,

  which corresponds to computing the spectral factorization of the
  real polynomial A(s) arising from continuous optimality problems.

  The input polynomial may be supplied either in the form

     A(s) = a(0) + a(1) * s + ... + a(DA) * s**DA

  or as

     B(s) = A(-s) * A(s)
          = b(0) + b(1) * s**2  + ... + b(DA) * s**(2*DA)        (1)
Specification 
      SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         ACONA
      INTEGER           DA, INFO, LDWORK
      DOUBLE PRECISION  RES
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), DWORK(*), E(*)
Arguments

Mode Parameters 

  ACONA   CHARACTER*1
          Indicates whether the coefficients of A(s) or B(s) =
          A(-s) * A(s) are to be supplied as follows:
          = 'A':  The coefficients of A(s) are to be supplied;
          = 'B':  The coefficients of B(s) are to be supplied.
Input/Output Parameters 
  DA      (input) INTEGER
          The degree of the polynomials A(s) and E(s).  DA >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (DA+1)
          On entry, this array must contain either the coefficients
          of the polynomial A(s) in increasing powers of s if
          ACONA = 'A', or the coefficients of the polynomial B(s) in
          increasing powers of s**2 (see equation (1)) if ACONA =
          'B'.
          On exit, this array contains the coefficients of the
          polynomial B(s) in increasing powers of s**2.

  RES     (output) DOUBLE PRECISION
          An estimate of the accuracy with which the coefficients of
          the polynomial E(s) have been computed (see also METHOD
          and NUMERICAL ASPECTS).

  E       (output) DOUBLE PRECISION array, dimension (DA+1)
          The coefficients of the spectral factor E(s) in increasing
          powers of s.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 5*DA+5.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if on entry, A(I) = 0.0, for I = 1,2,...,DA+1.
          = 2:  if on entry, ACONA = 'B' but the supplied
                coefficients of the polynomial B(s) are not the
                coefficients of A(-s) * A(s) for some real A(s);
                in this case, RES and E are unassigned;
          = 3:  if the iterative process (see METHOD) has failed to
                converge in 30 iterations;
          = 4:  if the last computed iterate (see METHOD) is
                unstable. If ACONA = 'B', then the supplied
                coefficients of the polynomial B(s) may not be the
                coefficients of A(-s) * A(s) for some real A(s).
Method 
      _                                               _
  Let A(s) be the conjugate polynomial of A(s), i.e., A(s) = A(-s).

  The method used by the routine is based on applying the
  Newton-Raphson iteration to the function
            _       _
     F(e) = A * A - e * e,

  which leads to the iteration formulae (see [1]):

     _(i)   (i)  _(i)   (i)     _      )
     q   * x   + x   * q    = 2 A * A  )
                                       )   for i = 0, 1, 2,...
      (i+1)    (i)   (i)               )
     q     = (q   + x   )/2            )

                 (0)         DA
  Starting from q   = (1 + s)   (which has no zeros in the closed
                                               (1)   (2)   (3)
  right half-plane), the sequence of iterates q   , q   , q   ,...
  converges to a solution of F(e) = 0 which has no zeros in the
  open right half-plane.

  The iterates satisfy the following conditions:

           (i)
     (a)  q   is a stable polynomial (no zeros in the closed right
          half-plane) and

           (i)        (i-1)
     (b)  q   (1) <= q     (1).

                                    (i-1)                       (i)
  The iterative process stops with q     , (where i <= 30)  if q
  violates either (a) or (b), or if the condition
                    _(i) (i)  _
     (c)  RES  = ||(q   q   - A A)|| < tol,

  is satisfied, where || . || denotes the largest coefficient of
                  _(i) (i)  _
  the polynomial (q   q   - A A) and tol is an estimate of the
                                                 _(i)  (i)
  rounding error in the computed coefficients of q    q   . If there
  is no convergence after 30 iterations then the routine returns
  with the Error Indicator (INFO) set to 3, and the value of RES may
  indicate whether or not the last computed iterate is close to the
  solution.

  If ACONA = 'B', then it is possible that the equation e(-s) *
  e(s) = B(s) has no real solution, which will be the case if A(1)
  < 0 or if ( -1)**DA * A(DA+1) < 0.
References 
  [1] Vostry, Z.
      New Algorithm for Polynomial Spectral Factorization with
      Quadratic Convergence II.
      Kybernetika, 12, pp. 248-259, 1976.
Numerical Aspects 
  The conditioning of the problem depends upon the distance of the
  zeros of A(s) from the imaginary axis and on their multiplicity.
  For a well-conditioned problem the accuracy of the computed
  coefficients of E(s) is of the order of RES. However, for problems
  with zeros near the imaginary axis or with multiple zeros, the
  value of RES may be an overestimate of the true accuracy.
Further Comments 
  In order for the problem e(-s) * e(s) = B(s) to have a real
  solution e(s), it is necessary and sufficient that B(j*omega)
  >= 0 for any purely imaginary argument j*omega (see [1]).
Example

Program Text 

*     SB08MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DAMAX
      PARAMETER        ( DAMAX = 10 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 5*DAMAX+5 )
*     .. Local Scalars ..
      DOUBLE PRECISION RES
      INTEGER          DA, I, INFO
      CHARACTER*1      ACONA
*     .. Local Arrays ..
      DOUBLE PRECISION A(DAMAX+1), DWORK(LDWORK), E(DAMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB08MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      READ ( NIN, FMT = '()' )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = * ) DA, ACONA
      IF ( DA.LE.-1 .OR. DA.GT.DAMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DA
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 )
*        Compute the spectral factorization of the given polynomial.
         CALL SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( ACONA, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 0, DA
                  WRITE ( NOUT, FMT = 99995 ) 2*I, A(I+1)
   20          CONTINUE
               WRITE ( NOUT, FMT = * )
            END IF
            WRITE ( NOUT, FMT = 99996 )
            DO 40 I = 0, DA
               WRITE ( NOUT, FMT = 99995 ) I, E(I+1)
   40       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) RES
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' SB08MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08MD = ',I2)
99997 FORMAT (' The coefficients of the polynomial B(s) are ',//' powe',
     $       'r of s     coefficient ')
99996 FORMAT (' The coefficients of the spectral factor E(s) are ',
     $       //' power of s     coefficient ')
99995 FORMAT (2X,I5,9X,F9.4)
99994 FORMAT (/' RES = ',1P,E8.1)
99993 FORMAT (/' DA is out of range.',/' DA = ',I5)
      END
Program Data 
 SB08MD EXAMPLE PROGRAM DATA
   3     A
   8.0  -6.0  -3.0  1.0
Program Results 
 SB08MD EXAMPLE PROGRAM RESULTS

 The coefficients of the polynomial B(s) are 

 power of s     coefficient 
      0           64.0000
      2          -84.0000
      4           21.0000
      6           -1.0000
 
 The coefficients of the spectral factor E(s) are 

 power of s     coefficient 
      0            8.0000
      1           14.0000
      2            7.0000
      3            1.0000

 RES =  2.7E-15

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB08ND.html000077500000000000000000000234541201767322700161120ustar00rootroot00000000000000 SB08ND - SLICOT Library Routine Documentation

SB08ND

Spectral factorization of polynomials (discrete-time case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a real polynomial E(z) such that

     (a)  E(1/z) * E(z) = A(1/z) * A(z) and
     (b)  E(z) is stable - that is, E(z) has no zeros with modulus
          greater than 1,

  which corresponds to computing the spectral factorization of the
  real polynomial A(z) arising from discrete optimality problems.

  The input polynomial may be supplied either in the form

  A(z) = a(0) + a(1) * z + ... + a(DA) * z**DA

  or as

  B(z) = A(1/z) * A(z)
       = b(0) + b(1) * (z + 1/z) + ... + b(DA) * (z**DA + 1/z**DA)
                                                                 (1)
Specification 
      SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      CHARACTER         ACONA
      INTEGER           DA, INFO, LDWORK
      DOUBLE PRECISION  RES
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), DWORK(*), E(*)
Arguments

Mode Parameters 

  ACONA   CHARACTER*1
          Indicates whether the coefficients of A(z) or B(z) =
          A(1/z) * A(z) are to be supplied as follows:
          = 'A':  The coefficients of A(z) are to be supplied;
          = 'B':  The coefficients of B(z) are to be supplied.
Input/Output Parameters 
  DA      (input) INTEGER
          The degree of the polynomials A(z) and E(z).  DA >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (DA+1)
          On entry, if ACONA = 'A', this array must contain the
          coefficients of the polynomial A(z) in increasing powers
          of z, and if ACONA = 'B', this array must contain the
          coefficients b ,b ,...,b   of the polynomial B(z) in
                        0  1      DA
          equation (1). That is, A(i) = b    for i = 1,2,...,DA+1.
                                         i-1
          On exit, this array contains the coefficients of the
          polynomial B(z) in eqation (1). Specifically, A(i)
          contains b   ,  for i = 1,2,...DA+1.
                    i-1

  RES     (output) DOUBLE PRECISION
          An estimate of the accuracy with which the coefficients of
          the polynomial E(z) have been computed (see also METHOD
          and NUMERICAL ASPECTS).

  E       (output) DOUBLE PRECISION array, dimension (DA+1)
          The coefficients of the spectral factor E(z) in increasing
          powers of z.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= 5*DA+5.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 2:  if on entry, ACONA = 'B' but the supplied
                coefficients of the polynomial B(z) are not the
                coefficients of A(1/z) * A(z) for some real A(z);
                in this case, RES and E are unassigned;
          = 3:  if the iterative process (see METHOD) has failed to
                converge in 30 iterations;
          = 4:  if the last computed iterate (see METHOD) is
                unstable. If ACONA = 'B', then the supplied
                coefficients of the polynomial B(z) may not be the
                coefficients of A(1/z) * A(z) for some real A(z).
Method 
      _                                               _
  Let A(z) be the conjugate polynomial of A(z), i.e., A(z) = A(1/z).

  The method used by the routine is based on applying the
  Newton-Raphson iteration to the function
            _       _
     F(e) = A * A - e * e,

  which leads to the iteration formulae (see [1] and [2])

     _(i)   (i)  _(i)   (i)     _      )
     q   * x   + x   * q    = 2 A * A  )
                                       )   for i = 0, 1, 2,...
      (i+1)    (i)   (i)               )
     q     = (q   + x   )/2            )

  The iteration starts from

      (0)                                        DA
     q   (z) = (b(0) + b(1) * z + ... + b(DA) * z  ) / SQRT( b(0))

  which is a Hurwitz polynomial that has no zeros in the closed unit
                                         (i)
  circle (see [2], Theorem 3). Then lim q   = e, the convergence is
  uniform and e is a Hurwitz polynomial.

  The iterates satisfy the following conditions:
           (i)
     (a)  q    has no zeros in the closed unit circle,
           (i)     (i-1)
     (b)  q    <= q     and
           0       0
           DA   (i) 2    DA     2
     (c)  SUM (q   )  - SUM (A )  >= 0.
          k=0   k       k=0   k
                                  (i)
  The iterative process stops if q    violates (a), (b) or (c),
  or if the condition
                    _(i) (i)  _
     (d)  RES  = ||(q   q   - A A)|| < tol,

  is satisfied, where || . || denotes the largest coefficient of
                  _(i) (i)  _
  the polynomial (q   q   - A A) and tol is an estimate of the
                                                 _(i)  (i)
  rounding error in the computed coefficients of q    q   . If
                                         (i-1)
  condition (a) or (b) is violated then q      is taken otherwise
   (i)
  q    is used. Thus the computed reciprocal polynomial E(z) = z**DA
  * q(1/z) is stable. If there is no convergence after 30 iterations
  then the routine returns with the Error Indicator (INFO) set to 3,
  and the value of RES may indicate whether or not the last computed
  iterate is close to the solution.
                                            (0)
  If ACONA = 'B', then it is possible that q    is not a Hurwitz
  polynomial, in which case the equation e(1/z) * e(z) = B(z) has no
  real solution (see [2], Theorem 3).
References 
  [1] Kucera, V.
      Discrete Linear Control, The polynomial Approach.
      John Wiley & Sons, Chichester, 1979.

  [2] Vostry, Z.
      New Algorithm for Polynomial Spectral Factorization with
      Quadratic Convergence I.
      Kybernetika, 11, pp. 415-422, 1975.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     SB08ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DAMAX
      PARAMETER        ( DAMAX = 10 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 5*DAMAX+5 )
*     .. Local Scalars ..
      DOUBLE PRECISION RES
      INTEGER          DA, I, INFO
      CHARACTER*1      ACONA
*     .. Local Arrays ..
      DOUBLE PRECISION A(DAMAX+1), DWORK(LDWORK), E(DAMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB08ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      READ ( NIN, FMT = '()' )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = * ) DA, ACONA
      IF ( DA.LE.-1 .OR. DA.GT.DAMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DA
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 )
*        Compute the spectral factorization of the given polynomial.
         CALL SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( ACONA, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 0, DA
                  WRITE ( NOUT, FMT = 99995 ) I, A(I+1)
   20          CONTINUE
               WRITE ( NOUT, FMT = * )
            END IF
            WRITE ( NOUT, FMT = 99996 )
            DO 40 I = 0, DA
               WRITE ( NOUT, FMT = 99995 ) I, E(I+1)
   40       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) RES
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' SB08ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08ND = ',I2)
99997 FORMAT (' The coefficients of the polynomial B(z) are ',//' powe',
     $       'r of z     coefficient ')
99996 FORMAT (' The coefficients of the spectral factor E(z) are ',
     $       //' power of z     coefficient ')
99995 FORMAT (2X,I5,9X,F9.4)
99994 FORMAT (/' RES = ',1P,E8.1)
99993 FORMAT (/' DA is out of range.',/' DA = ',I5)
      END
Program Data 
 SB08ND EXAMPLE PROGRAM DATA
   2     A
   2.0  4.5  1.0
Program Results 
 SB08ND EXAMPLE PROGRAM RESULTS

 The coefficients of the polynomial B(z) are 

 power of z     coefficient 
      0           25.2500
      1           13.5000
      2            2.0000
 
 The coefficients of the spectral factor E(z) are 

 power of z     coefficient 
      0            0.5000
      1            3.0000
      2            4.0000

 RES =  4.4E-16

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB09MD.html000077500000000000000000000210251201767322700161020ustar00rootroot00000000000000 SB09MD - SLICOT Library Routine Documentation

SB09MD

Evaluation of closeness of two multivariable sequences

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compare two multivariable sequences M1(k) and M2(k) for
  k = 1,2,...,N, and evaluate their closeness. Each of the
  parameters M1(k) and M2(k) is an NC by NB matrix.
Specification 
      SUBROUTINE SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE,
     $                   LDSE, PRE, LDPRE, TOL, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The number of parameters.  N >= 0.

  NC      (input) INTEGER
          The number of rows in M1(k) and M2(k).  NC >= 0.

  NB      (input) INTEGER
          The number of columns in M1(k) and M2(k).  NB >= 0.

  H1      (input) DOUBLE PRECISION array, dimension (LDH1,N*NB)
          The leading NC-by-N*NB part of this array must contain
          the multivariable sequence M1(k), where k = 1,2,...,N.
          Each parameter M1(k) is an NC-by-NB matrix, whose
          (i,j)-th element must be stored in H1(i,(k-1)*NB+j) for
          i = 1,2,...,NC and j = 1,2,...,NB.

  LDH1    INTEGER
          The leading dimension of array H1.  LDH1 >= MAX(1,NC).

  H2      (input) DOUBLE PRECISION array, dimension (LDH2,N*NB)
          The leading NC-by-N*NB part of this array must contain
          the multivariable sequence M2(k), where k = 1,2,...,N.
          Each parameter M2(k) is an NC-by-NB matrix, whose
          (i,j)-th element must be stored in H2(i,(k-1)*NB+j) for
          i = 1,2,...,NC and j = 1,2,...,NB.

  LDH2    INTEGER
          The leading dimension of array H2.  LDH2 >= MAX(1,NC).

  SS      (output) DOUBLE PRECISION array, dimension (LDSS,NB)
          The leading NC-by-NB part of this array contains the
          matrix SS.

  LDSS    INTEGER
          The leading dimension of array SS.  LDSS >= MAX(1,NC).

  SE      (output) DOUBLE PRECISION array, dimension (LDSE,NB)
          The leading NC-by-NB part of this array contains the
          quadratic error matrix SE.

  LDSE    INTEGER
          The leading dimension of array SE.  LDSE >= MAX(1,NC).

  PRE     (output) DOUBLE PRECISION array, dimension (LDPRE,NB)
          The leading NC-by-NB part of this array contains the
          percentage relative error matrix PRE.

  LDPRE   INTEGER
          The leading dimension of array PRE.  LDPRE >= MAX(1,NC).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in the computation of the error
          matrices SE and PRE. If the user sets TOL to be less than
          EPS then the tolerance is taken as EPS, where EPS is the
          machine precision (see LAPACK Library routine DLAMCH).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The (i,j)-th element of the matrix SS is defined by:
                     N          2
            SS    = SUM  M1  (k) .                            (1)
              ij    k=1    ij

  The (i,j)-th element of the quadratic error matrix SE is defined
  by:
                     N                      2
            SE    = SUM  (M1  (k) - M2  (k)) .                (2)
              ij    k=1     ij        ij

  The (i,j)-th element of the percentage relative error matrix PRE
  is defined by:

            PRE   = 100 x SQRT( SE  / SS  ).                  (3)
               ij                 ij    ij

  The following precautions are taken by the routine to guard
  against underflow and overflow:

  (i) if ABS( M1  (k) ) > 1/TOL or ABS( M1  (k) - M2  (k) ) > 1/TOL,
                ij                        ij        ij

      then SE   and SS   are set to 1/TOL and PRE   is set to 1; and
             ij       ij                         ij

  (ii) if ABS( SS  ) <= TOL, then PRE   is set to 100.
                 ij                  ij
Numerical Aspects 
  The algorithm requires approximately
     2xNBxNCx(N+1) multiplications/divisions,
     4xNBxNCxN     additions/subtractions and
       NBxNC       square roots.
Further Comments 
  None
Example

Program Text 

*     SB09MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, NCMAX, NBMAX
      PARAMETER        ( NMAX = 20, NCMAX = 20, NBMAX = 20 )
      INTEGER          LDH1, LDH2, LDSS, LDSE, LDPRE
      PARAMETER        ( LDH1 = NCMAX, LDH2 = NCMAX, LDSS = NCMAX,
     $                   LDSE = NCMAX, LDPRE = NCMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, N, NB, NC
*     .. Local Arrays ..
      DOUBLE PRECISION H1(LDH1,NMAX*NBMAX), H2(LDH2,NMAX*NBMAX),
     $                 PRE(LDPRE,NBMAX), SE(LDSE,NBMAX), SS(LDSS,NBMAX)
*     .. External Subroutines ..
      EXTERNAL         SB09MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NC, NB, TOL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE IF ( NB.LT.0 .OR. NB.GT.NBMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) NB
      ELSE IF ( NC.LT.0 .OR. NC.GT.NCMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) NC
      ELSE
         READ ( NIN, FMT = * ) ( ( H1(I,J), I = 1,NC ), J = 1,N*NB )
         READ ( NIN, FMT = * ) ( ( H2(I,J), I = 1,NC ), J = 1,N*NB )
*        Compare the given sequences and evaluate their closeness.
         CALL SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, LDSE,
     $                PRE, LDPRE, TOL, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, NC
               WRITE ( NOUT, FMT = 99996 ) ( SS(I,J), J = 1,NB )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 40 I = 1, NC
               WRITE ( NOUT, FMT = 99996 ) ( SE(I,J), J = 1,NB )
   40       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 60 I = 1, NC
               WRITE ( NOUT, FMT = 99996 ) ( PRE(I,J), J = 1,NB )
   60       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB09MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB09MD = ',I2)
99997 FORMAT (' The sum-of-squares matrix SS is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The quadratic error matrix SE is ')
99994 FORMAT (/' The percentage relative error matrix PRE is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' NB is out of range.',/' NB = ',I5)
99991 FORMAT (/' NC is out of range.',/' NC = ',I5)
      END
Program Data 
 SB09MD EXAMPLE PROGRAM DATA
   2     2     2     0.0
   1.3373  0.1205  0.6618 -0.3372
  -0.4062  1.6120  0.9299  0.7429
   1.1480 -0.1837  0.8843 -0.4947
  -0.4616  1.4674  0.6028  0.9524
Program Results 
 SB09MD EXAMPLE PROGRAM RESULTS

 The sum-of-squares matrix SS is 
   1.9534   1.3027
   2.6131   0.6656

 The quadratic error matrix SE is 
   0.0389   0.1565
   0.1134   0.0687

 The percentage relative error matrix PRE is 
  14.1125  34.6607
  20.8363  32.1262

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10AD.html000077500000000000000000000357231201767322700160700ustar00rootroot00000000000000 SB10AD - SLICOT Library Routine Documentation

SB10AD

H-infinity optimal controller using modified Glover's and Doyle's formulas (continuous-time)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of an H-infinity optimal n-state
  controller

           | AK | BK |
       K = |----|----|,
           | CK | DK |

  using modified Glover's and Doyle's 1988 formulas, for the system

           | A  | B1  B2  |   | A | B |
       P = |----|---------| = |---|---|
           | C1 | D11 D12 |   | C | D |
           | C2 | D21 D22 |

  and for the estimated minimal possible value of gamma with respect
  to GTOL, where B2 has as column size the number of control inputs
  (NCON) and C2 has as row size the number of measurements (NMEAS)
  being provided to the controller, and then to compute the matrices
  of the closed-loop system

           | AC | BC |
       G = |----|----|,
           | CC | DC |

  if the stabilizing controller exists.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) D12 is full column rank and D21 is full row rank,

  (A3) | A-j*omega*I  B2  | has full column rank for all omega,
       |    C1        D12 |

  (A4) | A-j*omega*I  B1  |  has full row rank for all omega.
       |    C2        D21 |
Specification 
      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     .. 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     .. 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 )
Arguments

Input/Output Parameters 

  JOB     (input) INTEGER
          Indicates the strategy for reducing the GAMMA value, as
          follows:
          = 1: Use bisection method for decreasing GAMMA from GAMMA
               to GAMMAMIN until the closed-loop system leaves
               stability.
          = 2: Scan from GAMMA to 0 trying to find the minimal GAMMA
               for which the closed-loop system retains stability.
          = 3: First bisection, then scanning.
          = 4: Find suboptimal controller only.

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  GAMMA   (input/output) DOUBLE PRECISION
          The initial value of gamma on input. It is assumed that
          gamma is sufficiently large so that the controller is
          admissible. GAMMA >= 0.
          On output it contains the minimal estimated gamma.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  AC      (output) DOUBLE PRECISION array, dimension (LDAC,2*N)
          The leading 2*N-by-2*N part of this array contains the
          closed-loop system state matrix AC.

  LDAC    INTEGER
          The leading dimension of the array AC.
          LDAC >= max(1,2*N).

  BC      (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON)
          The leading 2*N-by-(M-NCON) part of this array contains
          the closed-loop system input matrix BC.

  LDBC    INTEGER
          The leading dimension of the array BC.
          LDBC >= max(1,2*N).

  CC      (output) DOUBLE PRECISION array, dimension (LDCC,2*N)
          The leading (NP-NMEAS)-by-2*N part of this array contains
          the closed-loop system output matrix CC.

  LDCC    INTEGER
          The leading dimension of the array CC.
          LDCC >= max(1,NP-NMEAS).

  DC      (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON)
          The leading (NP-NMEAS)-by-(M-NCON) part of this array
          contains the closed-loop system input/output matrix DC.

  LDDC    INTEGER
          The leading dimension of the array DC.
          LDDC >= max(1,NP-NMEAS).

  RCOND   (output) DOUBLE PRECISION array, dimension (4)
                   For the last successful step:
          RCOND(1) contains the reciprocal condition number of the
                   control transformation matrix;
          RCOND(2) contains the reciprocal condition number of the
                   measurement transformation matrix;
          RCOND(3) contains an estimate of the reciprocal condition
                   number of the X-Riccati equation;
          RCOND(4) contains an estimate of the reciprocal condition
                   number of the Y-Riccati equation.
Tolerances 
  GTOL    DOUBLE PRECISION
          Tolerance used for controlling the accuracy of GAMMA
          and its distance to the estimated minimal possible
          value of GAMMA.
          If GTOL <= 0, then a default value equal to sqrt(EPS)
          is used, where EPS is the relative machine precision.

  ACTOL   DOUBLE PRECISION
          Upper bound for the poles of the closed-loop system
          used for determining if it is stable.
          ACTOL <= 0 for stable systems.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)

  LIWORK  INTEGER
          The dimension of the array IWORK.
          LIWORK >= max(2*max(N,M-NCON,NP-NMEAS,NCON,NMEAS),N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          value of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= LW1 + max(1,LW2,LW3,LW4,LW5 + MAX(LW6,LW7)),
          where
          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( ND1*M1 + max( 4*min( ND1, M1 ) + max( ND1,M1 ),
                                   6*min( ND1, M1 ) ),
                     NP1*ND2 + max( 4*min( NP1, ND2 ) +
                                                     max( NP1,ND2 ),
                                    6*min( NP1, ND2 ) ) );
          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( 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 ) ) ) ) );
          M1  = M   - M2, NP1 = NP - NP2,
          ND1 = NP1 - M2, ND2 = M1 - NP2.
          For good performance, LDWORK must generally be larger.

  BWORK   LOGICAL array, dimension (LBWORK)

  LBWORK  INTEGER
          The dimension of the array BWORK.  LBWORK >= 2*N.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix | A-j*omega*I  B2  | had not full
                              |    C1        D12 |
                column rank in respect to the tolerance EPS;
          = 2:  if the matrix | A-j*omega*I  B1  |  had not full row
                              |    C2        D21 |
                rank in respect to the tolerance EPS;
          = 3:  if the matrix D12 had not full column rank in
                respect to the tolerance SQRT(EPS);
          = 4:  if the matrix D21 had not full row rank in respect
                to the tolerance SQRT(EPS);
          = 5:  if the singular value decomposition (SVD) algorithm
                did not converge (when computing the SVD of one of
                the matrices |A   B2 |, |A   B1 |, D12 or D21);
                             |C1  D12|  |C2  D21|
          = 6:  if the controller is not admissible (too small value
                of gamma);
          = 7:  if the X-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties);
          = 8:  if the Y-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties);
          = 9:  if the determinant of Im2 + Tu*D11HAT*Ty*D22 is
                zero [3];
          = 10: if there are numerical problems when estimating
                singular values of D1111, D1112, D1111', D1121';
          = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22
                are singular to working precision;
          = 12: if a stabilizing controller cannot be found.
Method 
  The routine implements the Glover's and Doyle's 1988 formulas [1],
  [2], modified to improve the efficiency as described in [3].

  JOB = 1: It tries with a decreasing value of GAMMA, starting with
  the given, and with the newly obtained controller estimates of the
  closed-loop system. If it is stable, (i.e., max(eig(AC)) < ACTOL)
  the iterations can be continued until the given tolerance between
  GAMMA and the estimated GAMMAMIN is reached. Otherwise, in the
  next step GAMMA is increased. The step in the all next iterations
  is step = step/2. The closed-loop system is obtained by the
  formulas given in [2].

  JOB = 2: The same as for JOB = 1, but with non-varying step till
  GAMMA = 0, step = max(0.1, GTOL).

  JOB = 3: Combines the JOB = 1 and JOB = 2 cases for a quicker
  procedure.

  JOB = 4: Suboptimal controller for current GAMMA only.
References 
  [1] Glover, K. and Doyle, J.C.
      State-space formulae for all stabilizing controllers that
      satisfy an Hinf norm bound and relations to risk sensitivity.
      Systems and Control Letters, vol. 11, pp. 167-172, 1988.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, MA, 1995.

  [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
      Fortran 77 routines for Hinf and H2 design of continuous-time
      linear control systems.
      Rep. 98-14, Department of Engineering, Leicester University,
      Leicester, U.K., 1998.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  input and output transformations and on the condition numbers of
  the two Riccati equations, as given by the values of RCOND(1),
  RCOND(2), RCOND(3) and RCOND(4), respectively.
  This approach by estimating the closed-loop system and checking
  its poles seems to be reliable.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10DD.html000077500000000000000000000426411201767322700160700ustar00rootroot00000000000000 SB10DD - SLICOT Library Routine Documentation

SB10DD

H-infinity (sub)optimal controller for a discrete-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of an H-infinity (sub)optimal n-state
  controller

                        | AK | BK |
                    K = |----|----|,
                        | CK | DK |

  for the discrete-time system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---|
                | C1 | D11 D12 |   | C | D |
                | C2 | D21 D22 |

  and for a given value of gamma, where B2 has as column size the
  number of control inputs (NCON) and C2 has as row size the number
  of measurements (NMEAS) being provided to the controller.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) D12 is full column rank and D21 is full row rank,

            j*Theta
  (A3) | A-e       *I  B2  | has full column rank for all
       |    C1         D12 |

       0 <= Theta < 2*Pi ,

            j*Theta
  (A4) | A-e       *I  B1  |  has full row rank for all
       |    C2         D21 |

       0 <= Theta < 2*Pi .
Specification 
      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     .. 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     .. 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( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  GAMMA   (input) DOUBLE PRECISION
          The value of gamma. It is assumed that gamma is
          sufficiently large so that the controller is admissible.
          GAMMA > 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array contains the matrix
          X, solution of the X-Riccati equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          The leading N-by-N part of this array contains the matrix
          Z, solution of the Z-Riccati equation.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= max(1,N).

  RCOND   (output) DOUBLE PRECISION array, dimension (8)
          RCOND contains estimates of the reciprocal condition
          numbers of the matrices which are to be inverted and
          estimates of the reciprocal condition numbers of the
          Riccati equations which have to be solved during the
          computation of the controller. (See the description of
          the algorithm in [2].)
          RCOND(1) contains the reciprocal condition number of the
                   matrix R3;
          RCOND(2) contains the reciprocal condition number of the
                   matrix R1 - R2'*inv(R3)*R2;
          RCOND(3) contains the reciprocal condition number of the
                   matrix V21;
          RCOND(4) contains the reciprocal condition number of the
                   matrix St3;
          RCOND(5) contains the reciprocal condition number of the
                   matrix V12;
          RCOND(6) contains the reciprocal condition number of the
                   matrix Im2 + DKHAT*D22
          RCOND(7) contains the reciprocal condition number of the
                   X-Riccati equation;
          RCOND(8) contains the reciprocal condition number of the
                   Z-Riccati equation.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used in neglecting the small singular values
          in rank determination. If TOL <= 0, then a default value
          equal to 1000*EPS is used, where EPS is the relative
          machine precision.
Workspace 
  IWORK   INTEGER array, dimension max(2*max(M2,N),M,M2+NP2,N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= max(LW1,LW2,LW3,LW4), where
          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 = 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);
          LW4 = 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));
          For good performance, LDWORK must generally be larger.
          Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
          max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) +
              max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N +
              max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)).

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
                                   j*Theta
          = 1:  if the matrix | A-e       *I  B2  | had not full
                              |      C1       D12 |
                column rank;
                                   j*Theta
          = 2:  if the matrix | A-e       *I  B1  | had not full
                              |      C2       D21 |
                row rank;
          = 3:  if the matrix D12 had not full column rank;
          = 4:  if the matrix D21 had not full row rank;
          = 5:  if the controller is not admissible (too small value
                of gamma);
          = 6:  if the X-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties);
          = 7:  if the Z-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties);
          = 8:  if the matrix Im2 + DKHAT*D22 is singular.
          = 9:  if the singular value decomposition (SVD) algorithm
                did not converge (when computing the SVD of one of
                the matrices |A   B2 |, |A   B1 |, D12 or D21).
                             |C1  D12|  |C2  D21|
Method 
  The routine implements the method presented in [1].
References 
  [1] Green, M. and Limebeer, D.J.N.
      Linear Robust Control.
      Prentice-Hall, Englewood Cliffs, NJ, 1995.

  [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
      Fortran 77 routines for Hinf and H2 design of linear
      discrete-time control systems.
      Report 99-8, Department of Engineering, Leicester University,
      April 1999.
Numerical Aspects 
  With approaching the minimum value of gamma some of the matrices
  which are to be inverted tend to become ill-conditioned and
  the X- or Z-Riccati equation may also become ill-conditioned
  which may deteriorate the accuracy of the result. (The
  corresponding reciprocal condition numbers are given in
  the output array RCOND.)
Further Comments 
  None
Example

Program Text 

*     SB10DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK, LDX,
     $                 LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX,
     $                   LDAK = NMAX, LDBK = NMAX, LDCK = PMAX,
     $                   LDDK = PMAX, LDX = NMAX, LDZ = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*MAX( MMAX, NMAX ),
     $                                 MMAX + PMAX, NMAX*NMAX ) )
      INTEGER          MPMX
      PARAMETER        ( MPMX = MAX( MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK =
     $                   MAX( ( NMAX + MPMX )*( NMAX + MPMX + 6 ),
     $                        13*NMAX*NMAX + MMAX*MMAX + 2*MPMX*MPMX +
     $                        NMAX*( MMAX + MPMX ) +
     $                        MAX( MMAX*( MMAX + 7*NMAX ),
     $                             2*MPMX*( 8*NMAX + MMAX + 2*MPMX ) )
     $                             + 6*NMAX +
     $                             MAX( 14*NMAX + 23, 16*NMAX,
     $                                  2*NMAX + MAX( MMAX, 2*MPMX ),
     $                                  3*MAX( MMAX, 2*MPMX ) ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION GAMMA, TOL
      INTEGER          I, INFO, J, M, N, NCON, NMEAS, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX),
     $                 D(LDD,MMAX), DK(LDDK,PMAX), X(LDX,NMAX),
     $                 Z(LDZ,NMAX), DWORK(LDWORK), RCOND( 8 )
*     .. External Subroutines ..
      EXTERNAL         SB10DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) NCON
      ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99986 ) NMEAS
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) GAMMA, TOL
         CALL 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 )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, NCON
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, NCON
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 8 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10DD =',I2)
99997 FORMAT (/' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (10(1X,F8.4))
99991 FORMAT ( 5(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5)
99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5)
      END
Program Data 
 SB10DD EXAMPLE PROGRAM DATA
   6     5     5     2     2
  -0.7  0.0  0.3  0.0 -0.5 -0.1
  -0.6  0.2 -0.4 -0.3  0.0  0.0
  -0.5  0.7 -0.1  0.0  0.0 -0.8
  -0.7  0.0  0.0 -0.5 -1.0  0.0
   0.0  0.3  0.6 -0.9  0.1 -0.4
   0.5 -0.8  0.0  0.0  0.2 -0.9
  -1.0 -2.0 -2.0  1.0  0.0
   1.0  0.0  1.0 -2.0  1.0
  -3.0 -4.0  0.0  2.0 -2.0
   1.0 -2.0  1.0  0.0 -1.0
   0.0  1.0 -2.0  0.0  3.0
   1.0  0.0  3.0 -1.0 -2.0
   1.0 -1.0  2.0 -2.0  0.0 -3.0
  -3.0  0.0  1.0 -1.0  1.0  0.0
   0.0  2.0  0.0 -4.0  0.0 -2.0
   1.0 -3.0  0.0  0.0  3.0  1.0
   0.0  1.0 -2.0  1.0  0.0 -2.0
   1.0 -1.0 -2.0  0.0  0.0
   0.0  1.0  0.0  1.0  0.0
   2.0 -1.0 -3.0  0.0  1.0
   0.0  1.0  0.0  1.0 -1.0
   0.0  0.0  1.0  2.0  1.0
 111.294   0.00000001
Program Results 
 SB10DD EXAMPLE PROGRAM RESULTS


 The controller state matrix AK is

 -18.0030  52.0376  26.0831  -0.4271 -40.9022  18.0857
  18.8203 -57.6244 -29.0938   0.5870  45.3309 -19.8644
 -26.5994  77.9693  39.0368  -1.4020 -60.1129  26.6910
 -21.4163  62.1719  30.7507  -0.9201 -48.6221  21.8351
  -0.8911   4.2787   2.3286  -0.2424  -3.0376   1.2169
  -5.3286  16.1955   8.4824  -0.2489 -12.2348   5.1590

 The controller input matrix BK is

  16.9788  14.1648
 -18.9215 -15.6726
  25.2046  21.2848
  20.1122  16.8322
   1.4104   1.2040
   5.3181   4.5149

 The controller output matrix CK is

  -9.1941  27.5165  13.7364  -0.3639 -21.5983   9.6025
   3.6490 -10.6194  -5.2772   0.2432   8.1108  -3.6293

 The controller matrix DK is

   9.0317   7.5348
  -3.4006  -2.8219

 The estimated condition numbers are

  0.24960D+00  0.98548D+00  0.99186D+00  0.63733D-05  0.48625D+00
  0.29430D-01  0.56942D-02  0.12470D-01

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10ED.html000077500000000000000000000415121201767322700160650ustar00rootroot00000000000000 SB10ED - SLICOT Library Routine Documentation

SB10ED

H2 optimal state controller for a discrete-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the H2 optimal n-state controller

                        | AK | BK |
                    K = |----|----|
                        | CK | DK |

  for the discrete-time system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---| ,
                | C1 |  0  D12 |   | C | D |
                | C2 | D21 D22 |

  where B2 has as column size the number of control inputs (NCON)
  and C2 has as row size the number of measurements (NMEAS) being
  provided to the controller.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) D12 is full column rank and D21 is full row rank,

            j*Theta
  (A3) | A-e       *I  B2  | has full column rank for all
       |    C1         D12 |

       0 <= Theta < 2*Pi ,

            j*Theta
  (A4) | A-e       *I  B1  |  has full row rank for all
       |    C2         D21 |

       0 <= Theta < 2*Pi .
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   TOL
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( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  A       (input/worksp.) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.
          This array is modified internally, but it is restored on
          exit.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  RCOND   (output) DOUBLE PRECISION array, dimension (7)
          RCOND contains estimates the reciprocal condition
          numbers of the matrices which are to be inverted and the
          reciprocal condition numbers of the Riccati equations
          which have to be solved during the computation of the
          controller. (See the description of the algorithm in [2].)
          RCOND(1) contains the reciprocal condition number of the
                   control transformation matrix TU;
          RCOND(2) contains the reciprocal condition number of the
                   measurement transformation matrix TY;
          RCOND(3) contains the reciprocal condition number of the
                   matrix Im2 + B2'*X2*B2;
          RCOND(4) contains the reciprocal condition number of the
                   matrix Ip2 + C2*Y2*C2';
          RCOND(5) contains the reciprocal condition number of the
                   X-Riccati equation;
          RCOND(6) contains the reciprocal condition number of the
                   Y-Riccati equation;
          RCOND(7) contains the reciprocal condition number of the
                   matrix Im2 + DKHAT*D22 .
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used for controlling the accuracy of the
          transformations applied for diagonalizing D12 and D21,
          and for checking the nonsingularity of the matrices to be
          inverted. If TOL <= 0, then a default value equal to
          sqrt(EPS) is used, where EPS is the relative machine
          precision.
Workspace 
  IWORK   INTEGER array, dimension max(2*M2,2*N,N*N,NP2)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 +
                    max(1,LW1,LW2,LW3,LW4,LW5,LW6), where
          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),
          with M1 = M - M2 and NP1 = NP - NP2.
          For good performance, LDWORK must generally be larger.
          Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
          2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1),
                  2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N),
                            Q*(N+Q+max(Q,3)))).

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
                                   j*Theta
          = 1:  if the matrix | A-e       *I  B2  | had not full
                              |      C1       D12 |
                column rank in respect to the tolerance EPS;
                                   j*Theta
          = 2:  if the matrix | A-e       *I  B1  |  had not full
                              |      C2       D21 |
                row rank in respect to the tolerance EPS;
          = 3:  if the matrix D12 had not full column rank in
                respect to the tolerance TOL;
          = 4:  if the matrix D21 had not full row rank in respect
                to the tolerance TOL;
          = 5:  if the singular value decomposition (SVD) algorithm
                did not converge (when computing the SVD of one of
                the matrices |A-I  B2 |, |A-I  B1 |, D12 or D21).
                             |C1   D12|  |C2   D21|
          = 6:  if the X-Riccati equation was not solved
                successfully;
          = 7:  if the matrix Im2 + B2'*X2*B2 is not positive
                definite, or it is numerically singular (with
                respect to the tolerance TOL);
          = 8:  if the Y-Riccati equation was not solved
                successfully;
          = 9:  if the matrix Ip2 + C2*Y2*C2' is not positive
                definite, or it is numerically singular (with
                respect to the tolerance TOL);
          =10:  if the matrix Im2 + DKHAT*D22 is singular, or its
                estimated condition number is larger than or equal
                to 1/TOL.
Method 
  The routine implements the formulas given in [1].
References 
  [1] Zhou, K., Doyle, J.C., and Glover, K.
      Robust and Optimal Control.
      Prentice-Hall, Upper Saddle River, NJ, 1996.

  [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
      Fortran 77 routines for Hinf and H2 design of linear
      discrete-time control systems.
      Report 99-8, Department of Engineering, Leicester University,
      April 1999.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  matrices which are to be inverted and on the condition numbers of
  the matrix Riccati equations which are to be solved in the
  computation of the controller. (The corresponding reciprocal
  condition numbers are given in the output array RCOND.)
Further Comments 
  None
Example

Program Text 

*     SB10ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX,
     $                   LDAK = NMAX, LDBK = NMAX, LDCK = PMAX,
     $                   LDDK = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*MMAX, PMAX, 2*NMAX,
     $                                 NMAX*NMAX ) )
      INTEGER          MPMX
      PARAMETER        ( MPMX = MAX( MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*MPMX*( 3*MPMX + 2*NMAX ) +
     $                   MAX( ( NMAX + MPMX )*( NMAX + MPMX + 6 ),
     $                   MPMX*( MPMX + MAX( NMAX, MPMX, 5 ) + 1 ),
     $                   2*NMAX*NMAX + MAX( 14*NMAX*NMAX + 6*NMAX +
     $                   MAX( 14*NMAX + 23, 16*NMAX ),
     $                   MPMX*( NMAX + MPMX + MAX( MPMX, 3 ) ) ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, NCON, NMEAS, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,MMAX), C(LDC,NMAX), CK(LDCK,NMAX),
     $                 D(LDD,MMAX), DK(LDDK,MMAX), DWORK(LDWORK),
     $                 RCOND( 8 )
*     .. External Subroutines ..
      EXTERNAL         SB10ED
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) NCON
      ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99986 ) NMEAS
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) TOL
         CALL 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 )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, NCON
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, NCON
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 7 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10ED EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10ED =',I2)
99997 FORMAT (' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (10(1X,F8.4))
99991 FORMAT ( 5(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5)
99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5)
      END
Program Data 
 SB10ED EXAMPLE PROGRAM DATA
   6     5     5     2     2
  -0.7  0.0  0.3  0.0 -0.5 -0.1
  -0.6  0.2 -0.4 -0.3  0.0  0.0
  -0.5  0.7 -0.1  0.0  0.0 -0.8
  -0.7  0.0  0.0 -0.5 -1.0  0.0
   0.0  0.3  0.6 -0.9  0.1 -0.4
   0.5 -0.8  0.0  0.0  0.2 -0.9
  -1.0 -2.0 -2.0  1.0  0.0
   1.0  0.0  1.0 -2.0  1.0
  -3.0 -4.0  0.0  2.0 -2.0
   1.0 -2.0  1.0  0.0 -1.0
   0.0  1.0 -2.0  0.0  3.0
   1.0  0.0  3.0 -1.0 -2.0
   1.0 -1.0  2.0 -2.0  0.0 -3.0
  -3.0  0.0  1.0 -1.0  1.0  0.0
   0.0  2.0  0.0 -4.0  0.0 -2.0
   1.0 -3.0  0.0  0.0  3.0  1.0
   0.0  1.0 -2.0  1.0  0.0 -2.0
   1.0 -1.0 -2.0  0.0  0.0
   0.0  1.0  0.0  1.0  0.0
   2.0 -1.0 -3.0  0.0  1.0
   0.0  1.0  0.0  1.0 -1.0
   0.0  0.0  1.0  2.0  1.0
   0.00000001
Program Results 
 SB10ED EXAMPLE PROGRAM RESULTS

 The controller state matrix AK is

  -0.0551  -2.1891  -0.6607  -0.2532   0.6674  -1.0044
  -1.0379   2.3804   0.5031   0.3960  -0.6605   1.2673
  -0.0876  -2.1320  -0.4701  -1.1461   1.2927  -1.5116
  -0.1358  -2.1237  -0.9560  -0.7144   0.6673  -0.7957
   0.4900   0.0895   0.2634  -0.2354   0.1623  -0.2663
   0.1672  -0.4163   0.2871  -0.1983   0.4944  -0.6967

 The controller input matrix BK is

  -0.5985  -0.5464
   0.5285   0.6087
  -0.7600  -0.4472
  -0.7288  -0.6090
   0.0532   0.0658
  -0.0663   0.0059

 The controller output matrix CK is

   0.2500  -1.0200  -0.3371  -0.2733   0.2747  -0.4444
   0.0654   0.2095   0.0632   0.2089  -0.1895   0.1834

 The controller matrix DK is

  -0.2181  -0.2070
   0.1094   0.1159

 The estimated condition numbers are

  0.10000D+01  0.10000D+01  0.25207D+00  0.83985D-01  0.48628D-02
  0.55015D-03  0.49886D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10FD.html000077500000000000000000000462111201767322700160670ustar00rootroot00000000000000 SB10FD - SLICOT Library Routine Documentation

SB10FD

H-infinity (sub)optimal state controller for a continuous-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of an H-infinity (sub)optimal n-state
  controller

           | AK | BK |
       K = |----|----|,
           | CK | DK |

  using modified Glover's and Doyle's 1988 formulas, for the system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---|
                | C1 | D11 D12 |   | C | D |
                | C2 | D21 D22 |

  and for a given value of gamma, where B2 has as column size the
  number of control inputs (NCON) and C2 has as row size the number
  of measurements (NMEAS) being provided to the controller.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) D12 is full column rank and D21 is full row rank,

  (A3) | A-j*omega*I  B2  | has full column rank for all omega,
       |    C1        D12 |

  (A4) | A-j*omega*I  B1  |  has full row rank for all omega.
       |    C2        D21 |
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   GAMMA, TOL
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 )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  GAMMA   (input) DOUBLE PRECISION
          The value of gamma. It is assumed that gamma is
          sufficiently large so that the controller is admissible.
          GAMMA >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  RCOND   (output) DOUBLE PRECISION array, dimension (4)
          RCOND(1) contains the reciprocal condition number of the
                   control transformation matrix;
          RCOND(2) contains the reciprocal condition number of the
                   measurement transformation matrix;
          RCOND(3) contains an estimate of the reciprocal condition
                   number of the X-Riccati equation;
          RCOND(4) contains an estimate of the reciprocal condition
                   number of the Y-Riccati equation.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used for controlling the accuracy of the applied
          transformations for computing the normalized form in
          SLICOT Library routine SB10PD. Transformation matrices
          whose reciprocal condition numbers are less than TOL are
          not allowed. If TOL <= 0, then a default value equal to
          sqrt(EPS) is used, where EPS is the relative machine
          precision.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK), where
          LIWORK = max(2*max(N,M-NCON,NP-NMEAS,NCON),N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 +
                    max(1,LW1,LW2,LW3,LW4,LW5,LW6), where
          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(D1*D1 + max(2*D1, (D1+D2)*NP2),
                        D2*D2 + max(2*D2, D2*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)))))),
          with D1 = NP1 - M2, D2 = M1 - NP2,
              NP1 = NP - NP2, M1 = M - M2.
          For good performance, LDWORK must generally be larger.
          Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
          2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1),
            2*N*(N+2*Q)+max(1,4*Q*Q+
                            max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)),
                              Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))).

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix | A-j*omega*I  B2  | had not full
                              |    C1        D12 |
                column rank in respect to the tolerance EPS;
          = 2:  if the matrix | A-j*omega*I  B1  |  had not full row
                              |    C2        D21 |
                rank in respect to the tolerance EPS;
          = 3:  if the matrix D12 had not full column rank in
                respect to the tolerance TOL;
          = 4:  if the matrix D21 had not full row rank in respect
                to the tolerance TOL;
          = 5:  if the singular value decomposition (SVD) algorithm
                did not converge (when computing the SVD of one of
                the matrices |A   B2 |, |A   B1 |, D12 or D21).
                             |C1  D12|  |C2  D21|
          = 6:  if the controller is not admissible (too small value
                of gamma);
          = 7:  if the X-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties);
          = 8:  if the Y-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties);
          = 9:  if the determinant of Im2 + Tu*D11HAT*Ty*D22 is
                zero [3].
Method 
  The routine implements the Glover's and Doyle's 1988 formulas [1],
  [2] modified to improve the efficiency as described in [3].
References 
  [1] Glover, K. and Doyle, J.C.
      State-space formulae for all stabilizing controllers that
      satisfy an Hinf norm bound and relations to risk sensitivity.
      Systems and Control Letters, vol. 11, pp. 167-172, 1988.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.

  [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
      Fortran 77 routines for Hinf and H2 design of continuous-time
      linear control systems.
      Rep. 98-14, Department of Engineering, Leicester University,
      Leicester, U.K., 1998.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  input and output transformations and on the condition numbers of
  the two Riccati equations, as given by the values of RCOND(1),
  RCOND(2), RCOND(3) and RCOND(4), respectively.
Further Comments 
  None
Example

Program Text 

*     SB10FD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX, N2MAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10, N2MAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK,
     $                 LDAC, LDBC, LDCC, LDDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX,
     $                   LDAK = NMAX, LDBK = NMAX, LDCK = MMAX,
     $                   LDDK = MMAX, LDAC = 2*NMAX, LDBC = 2*NMAX,
     $                   LDCC = PMAX, LDDC = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*MAX( NMAX, MMAX, PMAX ),
     $                            NMAX*NMAX ) )
      INTEGER          MPMX
      PARAMETER        ( MPMX = MAX( MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*MPMX*( 3*MPMX + 2*NMAX ) +
     $                   MAX( ( NMAX + MPMX )*( NMAX + MPMX + 6 ),
     $                   MPMX*( MPMX + MAX( NMAX, MPMX, 5 ) + 1 ),
     $                   2*NMAX*( NMAX + 2*MPMX ) +
     $                   MAX( 4*MPMX*MPMX + MAX( 2*MPMX, 3*NMAX*NMAX +
     $                   MAX( 2*NMAX*MPMX, 10*NMAX*NMAX+12*NMAX+5 ) ),
     $                   MPMX*( 3*NMAX + 3*MPMX +
     $                          MAX( 2*NMAX, 4*MPMX +
     $                               MAX( NMAX, MPMX ) ) ) ) ) )
*     .. Local Scalars ..
      INTEGER SDIM
      LOGICAL SELECT
      DOUBLE PRECISION GAMMA, TOL
      INTEGER          I, INFO1, INFO2, INFO3, J, M, N, NCON, NMEAS, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(N2MAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AK(LDAK,NMAX), AC(LDAC,N2MAX),
     $                 B(LDB,MMAX), BK(LDBK,PMAX), BC(LDBC,MMAX),
     $                 C(LDC,NMAX), CK(LDCK,NMAX), CC(LDCC,N2MAX),
     $                 D(LDD,MMAX), DK(LDDK,PMAX), DC(LDDC,MMAX),
     $                 DWORK(LDWORK), RCOND( 4 )
*     .. External Subroutines ..
      EXTERNAL         SB10FD, SB10LD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99986 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99985 ) NP
      ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99984 ) NCON
      ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) NMEAS
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) GAMMA, TOL
*        Compute the suboptimal controller
         CALL 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, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99989 ) ( AK(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99989 ) ( BK(I,J), J = 1,NMEAS )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 30 I = 1, NCON
               WRITE ( NOUT, FMT = 99989 ) ( CK(I,J), J = 1,N )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99993 )
            DO 40 I = 1, NCON
               WRITE ( NOUT, FMT = 99989 ) ( DK(I,J), J = 1,NMEAS )
   40       CONTINUE
            WRITE( NOUT, FMT = 99992 )
            WRITE( NOUT, FMT = 99988 ) ( RCOND(I), I = 1, 4 )
*           Compute the closed-loop matrices
            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 )
*
            IF ( INFO2.EQ.0 ) THEN
*              Compute the closed-loop poles
               CALL DGEES( 'N','N', SELECT, 2*N, AC, LDAC, SDIM,
     $                     DWORK(1), DWORK(2*N+1), DWORK, 2*N,
     $                     DWORK(4*N+1), LDWORK-4*N, BWORK, INFO3)
*
               IF( INFO3.EQ.0 ) THEN
                  WRITE( NOUT, FMT = 99991 )
                  WRITE( NOUT, FMT = 99988 ) (DWORK(I), I =1, 2*N)
                  WRITE( NOUT, FMT = 99990 )
                  WRITE( NOUT, FMT = 99988 ) (DWORK(2*N+I), I =1, 2*N)
               ELSE
                  WRITE( NOUT, FMT = 99996 ) INFO3
               END IF
            ELSE
               WRITE( NOUT, FMT = 99997 ) INFO2
            END IF
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10FD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10FD =',I2)
99997 FORMAT (/' INFO on exit from SB10LD =',I2)
99996 FORMAT (' The controller state matrix AK is'/)
99995 FORMAT (/' The controller input matrix BK is'/)
99994 FORMAT (/' The controller output matrix CK is'/)
99993 FORMAT (/' The controller matrix DK is'/)
99992 FORMAT (/' The estimated condition numbers are'/)
99991 FORMAT (/' The real parts of the closed-loop system poles are'/)
99990 FORMAT (/' The imaginary parts of the closed-loop system',
     $           ' poles are'/)
99989 FORMAT (10(1X,F8.4))
99988 FORMAT ( 5(1X,D12.5))
99987 FORMAT (/' N is out of range.',/' N = ',I5)
99986 FORMAT (/' M is out of range.',/' M = ',I5)
99985 FORMAT (/' N is out of range.',/' N = ',I5)
99984 FORMAT (/' NCON is out of range.',/' NCON = ',I5)
99983 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5)
      END
Program Data 
 SB10FD EXAMPLE PROGRAM DATA
   6     5     5     2     2
  -1.0  0.0  4.0  5.0 -3.0 -2.0
  -2.0  4.0 -7.0 -2.0  0.0  3.0
  -6.0  9.0 -5.0  0.0  2.0 -1.0
  -8.0  4.0  7.0 -1.0 -3.0  0.0
   2.0  5.0  8.0 -9.0  1.0 -4.0
   3.0 -5.0  8.0  0.0  2.0 -6.0
  -3.0 -4.0 -2.0  1.0  0.0
   2.0  0.0  1.0 -5.0  2.0
  -5.0 -7.0  0.0  7.0 -2.0
   4.0 -6.0  1.0  1.0 -2.0
  -3.0  9.0 -8.0  0.0  5.0
   1.0 -2.0  3.0 -6.0 -2.0
   1.0 -1.0  2.0 -4.0  0.0 -3.0
  -3.0  0.0  5.0 -1.0  1.0  1.0
  -7.0  5.0  0.0 -8.0  2.0 -2.0
   9.0 -3.0  4.0  0.0  3.0  7.0
   0.0  1.0 -2.0  1.0 -6.0 -2.0
   1.0 -2.0 -3.0  0.0  0.0
   0.0  4.0  0.0  1.0  0.0
   5.0 -3.0 -4.0  0.0  1.0
   0.0  1.0  0.0  1.0 -3.0
   0.0  0.0  1.0  7.0  1.0
  15.0  0.00000001
Program Results 
 SB10FD EXAMPLE PROGRAM RESULTS

 The controller state matrix AK is

  -2.8043  14.7367   4.6658   8.1596   0.0848   2.5290
   4.6609   3.2756  -3.5754  -2.8941   0.2393   8.2920
 -15.3127  23.5592  -7.1229   2.7599   5.9775  -2.0285
 -22.0691  16.4758  12.5523 -16.3602   4.4300  -3.3168
  30.6789  -3.9026  -1.3868  26.2357  -8.8267  10.4860
  -5.7429   0.0577  10.8216 -11.2275   1.5074 -10.7244

 The controller input matrix BK is

  -0.1581  -0.0793
  -0.9237  -0.5718
   0.7984   0.6627
   0.1145   0.1496
  -0.6743  -0.2376
   0.0196  -0.7598

 The controller output matrix CK is

  -0.2480  -0.1713  -0.0880   0.1534   0.5016  -0.0730
   2.8810  -0.3658   1.3007   0.3945   1.2244   2.5690

 The controller matrix DK is

   0.0554   0.1334
  -0.3195   0.0333

 The estimated condition numbers are

  0.10000D+01  0.10000D+01  0.11241D-01  0.80492D-03

 The real parts of the closed-loop system poles are

 -0.10731D+03 -0.66556D+02 -0.38269D+02 -0.38269D+02 -0.20089D+02
 -0.62557D+01 -0.62557D+01 -0.32405D+01 -0.32405D+01 -0.17178D+01
 -0.41466D+01 -0.76437D+01

 The imaginary parts of the closed-loop system poles are

  0.00000D+00  0.00000D+00  0.13114D+02 -0.13114D+02  0.00000D+00
  0.12961D+02 -0.12961D+02  0.67998D+01 -0.67998D+01  0.00000D+00
  0.00000D+00  0.00000D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10HD.html000077500000000000000000000345561201767322700161020ustar00rootroot00000000000000 SB10HD - SLICOT Library Routine Documentation

SB10HD

H2 optimal state controller for a continuous-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the H2 optimal n-state controller

           | AK | BK |
       K = |----|----|
           | CK | DK |

  for the system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---| ,
                | C1 |  0  D12 |   | C | D |
                | C2 | D21 D22 |

  where B2 has as column size the number of control inputs (NCON)
  and C2 has as row size the number of measurements (NMEAS) being
  provided to the controller.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) The block D11 of D is zero,

  (A3) D12 is full column rank and D21 is full row rank.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   TOL
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 )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  RCOND   (output) DOUBLE PRECISION array, dimension (4)
          RCOND(1) contains the reciprocal condition number of the
                   control transformation matrix;
          RCOND(2) contains the reciprocal condition number of the
                   measurement transformation matrix;
          RCOND(3) contains an estimate of the reciprocal condition
                   number of the X-Riccati equation;
          RCOND(4) contains an estimate of the reciprocal condition
                   number of the Y-Riccati equation.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used for controlling the accuracy of the applied
          transformations for computing the normalized form in
          SLICOT Library routine SB10UD. Transformation matrices
          whose reciprocal condition numbers are less than TOL are
          not allowed. If TOL <= 0, then a default value equal to
          sqrt(EPS) is used, where EPS is the relative machine
          precision.
Workspace 
  IWORK   INTEGER array, dimension max(2*N,N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 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),
          where M1 = M - M2 and NP1 = NP - NP2.
          For good performance, LDWORK must generally be larger.
          Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
          2*Q*(3*Q+2*N)+max(1,Q*(Q+max(N,5)+1),N*(14*N+12+2*Q)+5).

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix D12 had not full column rank in
                respect to the tolerance TOL;
          = 2:  if the matrix D21 had not full row rank in respect
                to the tolerance TOL;
          = 3:  if the singular value decomposition (SVD) algorithm
                did not converge (when computing the SVD of one of
                the matrices D12 or D21).
          = 4:  if the X-Riccati equation was not solved
                successfully;
          = 5:  if the Y-Riccati equation was not solved
                successfully.
Method 
  The routine implements the formulas given in [1], [2].
References 
  [1] Zhou, K., Doyle, J.C., and Glover, K.
      Robust and Optimal Control.
      Prentice-Hall, Upper Saddle River, NJ, 1996.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  input and output transformations and on the condition numbers of
  the two Riccati equations, as given by the values of RCOND(1),
  RCOND(2), RCOND(3) and RCOND(4), respectively.
Further Comments 
  None
Example

Program Text 

*     SB10HD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX,
     $                   LDAK = NMAX, LDBK = NMAX, LDCK = PMAX,
     $                   LDDK = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX, NMAX*NMAX ) )
      INTEGER          MPMX
      PARAMETER        ( MPMX = MAX( MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*MPMX*( 2*NMAX + 3*MPMX ) +
     $                   MAX( MPMX*( MPMX + MAX( NMAX, 5 ) + 1 ),
     $                   NMAX*( 14*NMAX + 12 + 2*MPMX ) + 5 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, NCON, NMEAS, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,MMAX), C(LDC,NMAX), CK(LDCK,NMAX),
     $                 D(LDD,MMAX), DK(LDDK,MMAX), DWORK(LDWORK),
     $                 RCOND( 4 )
*     .. External Subroutines ..
      EXTERNAL         SB10HD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) NCON
      ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99986 ) NMEAS
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) TOL
*        Compute the optimal H2 controller
         CALL 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 )
*
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, NCON
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, NCON
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 4 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10HD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10HD =',I2)
99997 FORMAT (' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (6(1X,F10.4))
99991 FORMAT (5(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5)
99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5)
      END
Program Data 
 SB10HD EXAMPLE PROGRAM DATA
   6     5     5     2     2
  -1.0  0.0  4.0  5.0 -3.0 -2.0
  -2.0  4.0 -7.0 -2.0  0.0  3.0
  -6.0  9.0 -5.0  0.0  2.0 -1.0
  -8.0  4.0  7.0 -1.0 -3.0  0.0
   2.0  5.0  8.0 -9.0  1.0 -4.0
   3.0 -5.0  8.0  0.0  2.0 -6.0
  -3.0 -4.0 -2.0  1.0  0.0
   2.0  0.0  1.0 -5.0  2.0
  -5.0 -7.0  0.0  7.0 -2.0
   4.0 -6.0  1.0  1.0 -2.0
  -3.0  9.0 -8.0  0.0  5.0
   1.0 -2.0  3.0 -6.0 -2.0
   1.0 -1.0  2.0 -4.0  0.0 -3.0
  -3.0  0.0  5.0 -1.0  1.0  1.0
  -7.0  5.0  0.0 -8.0  2.0 -2.0
   9.0 -3.0  4.0  0.0  3.0  7.0
   0.0  1.0 -2.0  1.0 -6.0 -2.0
   0.0  0.0  0.0 -4.0 -1.0
   0.0  0.0  0.0  1.0  0.0
   0.0  0.0  0.0  0.0  1.0
   3.0  1.0  0.0  1.0 -3.0
  -2.0  0.0  1.0  7.0  1.0
   0.00000001
Program Results 
 SB10HD EXAMPLE PROGRAM RESULTS

 The controller state matrix AK is

    88.0015  -145.7298   -46.2424    82.2168   -45.2996   -31.1407
    25.7489   -31.4642   -12.4198     9.4625    -3.5182     2.7056
    54.3008  -102.4013   -41.4968    50.8412   -20.1286   -26.7191
   108.1006  -198.0785   -45.4333    70.3962   -25.8591   -37.2741
  -115.8900   226.1843    47.2549   -47.8435   -12.5004    34.7474
    59.0362  -101.8471   -20.1052    36.7834   -16.1063   -26.4309

 The controller input matrix BK is

     3.7345     3.4758
    -0.3020     0.6530
     3.4735     4.0499
     4.3198     7.2755
    -3.9424   -10.5942
     2.1784     2.5048

 The controller output matrix CK is

    -2.3346     3.2556     0.7150    -0.9724     0.6962     0.4074
     7.6899    -8.4558    -2.9642     7.0365    -4.2844     0.1390

 The controller matrix DK is

     0.0000     0.0000
     0.0000     0.0000

 The estimated condition numbers are

  0.23570D+00  0.26726D+00  0.22747D-01  0.21130D-02

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10ID.html000077500000000000000000000300741201767322700160720ustar00rootroot00000000000000 SB10ID - SLICOT Library Routine Documentation

SB10ID

Positive feedback controller for a continuous-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the positive feedback controller

           | Ak | Bk |
       K = |----|----|
           | Ck | Dk |

  for the shaped plant

           | A | B |
       G = |---|---|
           | C | D |

  in the McFarlane/Glover Loop Shaping Design Procedure.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, M, N, NK, NP
      DOUBLE PRECISION   FACTOR
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 )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the plant.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A of the shaped plant.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B of the shaped plant.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C of the shaped plant.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system matrix D of the shaped plant.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  FACTOR  (input) DOUBLE PRECISION
          = 1 implies that an optimal controller is required;
          > 1 implies that a suboptimal controller is required,
              achieving a performance FACTOR less than optimal.
          FACTOR >= 1.

  NK      (output) INTEGER
          The order of the positive feedback controller.  NK <= N.

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading NK-by-NK part of this array contains the
          controller state matrix Ak.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NP)
          The leading NK-by-NP part of this array contains the
          controller input matrix Bk.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading M-by-NK part of this array contains the
          controller output matrix Ck.

  LDCK    INTEGER
          The leading dimension of the array CK.  LDCK >= max(1,M).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NP)
          The leading M-by-NP part of this array contains the
          controller matrix Dk.

  LDDK    INTEGER
          The leading dimension of the array DK.  LDDK >= max(1,M).

  RCOND   (output) DOUBLE PRECISION array, dimension (2)
          RCOND(1) contains an estimate of the reciprocal condition
                   number of the X-Riccati equation;
          RCOND(2) contains an estimate of the reciprocal condition
                   number of the Z-Riccati equation.
Workspace 
  IWORK   INTEGER array, dimension max(2*N,N*N,M,NP)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 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 ).
          For good performance, LDWORK must generally be larger.
          An upper bound of LDWORK in the above formula is
          LDWORK >= 10*N*N + M*M + NP*NP + 2*M*N + 2*N*NP + 4*N +
                    5 + max(1,4*N*N+8*N).

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the X-Riccati equation is not solved successfully;
          = 2:  the Z-Riccati equation is not solved successfully;
          = 3:  the iteration to compute eigenvalues or singular
                values failed to converge;
          = 4:  the matrix Ip - D*Dk is singular;
          = 5:  the matrix Im - Dk*D is singular;
          = 6:  the closed-loop system is unstable.
Method 
  The routine implements the formulas given in [1].
References 
  [1] McFarlane, D. and Glover, K.
      A loop shaping design procedure using H_infinity synthesis.
      IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769,
      1992.
Numerical Aspects 
  The accuracy of the results depends on the conditioning of the
  two Riccati equations solved in the controller design (see the
  output parameter RCOND).
Further Comments 
  None
Example

Program Text 

*     SB10ID EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK
      PARAMETER        ( LDA  = NMAX, LDAK = NMAX, LDB  = NMAX,
     $                   LDBK = NMAX, LDC  = PMAX, LDCK = MMAX,
     $                   LDD  = PMAX, LDDK = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX, NMAX*NMAX, MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*NMAX*NMAX + MMAX*MMAX + PMAX*PMAX +
     $                            2*MMAX*NMAX + NMAX*PMAX + 4*NMAX +
     $                            MAX( 10*NMAX*NMAX + 8*NMAX + 5,
     $                                    NMAX*PMAX + 2*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FACTOR
      INTEGER          I, INFO, J, M, N, NK, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX),
     $                 D(LDD,MMAX), DK(LDDK,PMAX), DWORK(LDWORK),
     $                 RCOND( 2 )
*     .. External Subroutines ..
      EXTERNAL         SB10ID
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) FACTOR
         CALL 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 )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, NK
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,NK )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, NK
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,NK )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 2 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10ID EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10ID =',I2)
99997 FORMAT (/' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (10(1X,F9.4))
99991 FORMAT ( 2(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
      END
Program Data 
 SB10ID EXAMPLE PROGRAM DATA
   6     2     3   
  -1.0  0.0  4.0  5.0 -3.0 -2.0
  -2.0  4.0 -7.0 -2.0  0.0  3.0
  -6.0  9.0 -5.0  0.0  2.0 -1.0
  -8.0  4.0  7.0 -1.0 -3.0  0.0
   2.0  5.0  8.0 -9.0  1.0 -4.0
   3.0 -5.0  8.0  0.0  2.0 -6.0
  -3.0 -4.0
   2.0  0.0
  -5.0 -7.0
   4.0 -6.0
  -3.0  9.0
   1.0 -2.0
   1.0 -1.0  2.0 -4.0  0.0 -3.0
  -3.0  0.0  5.0 -1.0  1.0  1.0
  -7.0  5.0  0.0 -8.0  2.0 -2.0
   1.0 -2.0
   0.0  4.0
   5.0 -3.0
   1.0
Program Results 
 SB10ID EXAMPLE PROGRAM RESULTS


 The controller state matrix AK is

  -39.0671    9.9293   22.2322  -27.4113   43.8655
   -6.6117    3.0006   11.0878  -11.4130   15.4269
   33.6805   -6.6934  -23.9953   14.1438  -33.4358
  -32.3191    9.7316   25.4033  -24.0473   42.0517
  -44.1655   18.7767   34.8873  -42.4369   50.8437

 The controller input matrix BK is

  -10.2905  -16.5382  -10.9782
   -4.3598   -8.7525   -5.1447
    6.5962    1.8975    6.2316
   -9.8770  -14.7041  -11.8778
   -9.6726  -22.7309  -18.2692

 The controller output matrix CK is

   -0.6647   -0.0599   -1.0376    0.5619    1.7297
   -8.4202    3.9573    7.3094   -7.6283   10.6768

 The controller matrix DK is

    0.8466    0.4979   -0.6993
   -1.2226   -4.8689   -4.5056

 The estimated condition numbers are

  0.13861D-01  0.90541D-02

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10JD.html000077500000000000000000000115721201767322700160750ustar00rootroot00000000000000 SB10JD - SLICOT Library Routine Documentation

SB10JD

Converting a descriptor state-space system into regular state-space form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To convert the descriptor state-space system

  E*dx/dt = A*x + B*u
        y = C*x + D*u

  into regular state-space form

   dx/dt = Ad*x + Bd*u
       y = Cd*x + Dd*u .
Specification 
      SUBROUTINE SB10JD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, E,
     $                   LDE, NSYS, DWORK, LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N,
     $                   NP, NSYS
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK( * ),  E( LDE, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the descriptor system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state matrix A of the descriptor system.
          On exit, the leading NSYS-by-NSYS part of this array
          contains the state matrix Ad of the converted system.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B of the descriptor system.
          On exit, the leading NSYS-by-M part of this array
          contains the input matrix Bd of the converted system.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading NP-by-N part of this array must
          contain the output matrix C of the descriptor system.
          On exit, the leading NP-by-NSYS part of this array
          contains the output matrix Cd of the converted system.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading NP-by-M part of this array must
          contain the matrix D of the descriptor system.
          On exit, the leading NP-by-M part of this array contains
          the matrix Dd of the converted system.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the matrix E of the descriptor system.
          On exit, this array contains no useful information.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= max(1,N).

  NSYS    (output) INTEGER
          The order of the converted state-space system.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= max( 1, 2*N*N + 2*N + N*MAX( 5, N + M + NP ) ).
          For good performance, LDWORK must generally be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the iteration for computing singular value
                decomposition did not converge.
Method 
  The routine performs the transformations described in [1].
References 
  [1] Chiang, R.Y. and Safonov, M.G.
      Robust Control Toolbox User's Guide.
      The MathWorks Inc., Natick, Mass., 1992.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10KD.html000077500000000000000000000302621201767322700160730ustar00rootroot00000000000000 SB10KD - SLICOT Library Routine Documentation

SB10KD

Positive feedback controller for a discrete-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the positive feedback controller

           | Ak | Bk |
       K = |----|----|
           | Ck | Dk |

  for the shaped plant

           | A | B |
       G = |---|---|
           | C | 0 |

  in the Discrete-Time Loop Shaping Design Procedure.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK,
     $                   LDWORK, M, N, NP
      DOUBLE PRECISION   FACTOR
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 )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the plant.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A of the shaped plant.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B of the shaped plant.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C of the shaped plant.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  FACTOR  (input) DOUBLE PRECISION
          = 1  implies that an optimal controller is required;
          > 1  implies that a suboptimal controller is required
               achieving a performance FACTOR less than optimal.
          FACTOR >= 1.

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix Ak.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NP)
          The leading N-by-NP part of this array contains the
          controller input matrix Bk.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading M-by-N part of this array contains the
          controller output matrix Ck.

  LDCK    INTEGER
          The leading dimension of the array CK.  LDCK >= max(1,M).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NP)
          The leading M-by-NP part of this array contains the
          controller matrix Dk.

  LDDK    INTEGER
          The leading dimension of the array DK.  LDDK >= max(1,M).

  RCOND   (output) DOUBLE PRECISION array, dimension (4)
          RCOND(1) contains an estimate of the reciprocal condition
                   number of the linear system of equations from
                   which the solution of the P-Riccati equation is
                   obtained;
          RCOND(2) contains an estimate of the reciprocal condition
                   number of the linear system of equations from
                   which the solution of the Q-Riccati equation is
                   obtained;
          RCOND(3) contains an estimate of the reciprocal condition
                   number of the linear system of equations from
                   which the solution of the X-Riccati equation is
                   obtained;
          RCOND(4) contains an estimate of the reciprocal condition
                   number of the matrix Rx + Bx'*X*Bx (see the
                   comments in the code).
Workspace 
  IWORK   INTEGER array, dimension 2*max(N,NP+M)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 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 ).
          For good performance, LDWORK must generally be larger.

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the P-Riccati equation is not solved successfully;
          = 2:  the Q-Riccati equation is not solved successfully;
          = 3:  the X-Riccati equation is not solved successfully;
          = 4:  the iteration to compute eigenvalues failed to
                converge;
          = 5:  the matrix Rx + Bx'*X*Bx is singular;
          = 6:  the closed-loop system is unstable.
Method 
  The routine implements the method presented in [1].
References 
  [1] McFarlane, D. and Glover, K.
      A loop shaping design procedure using H_infinity synthesis.
      IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769,
      1992.
Numerical Aspects 
  The accuracy of the results depends on the conditioning of the
  two Riccati equations solved in the controller design. For
  better conditioning it is advised to take FACTOR > 1.
Further Comments 
  None
Example

Program Text 

*     SB10KD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK
      PARAMETER        ( LDA  = NMAX, LDAK = NMAX, LDB  = NMAX,
     $                   LDBK = NMAX, LDC  = PMAX, LDCK = MMAX,
     $                   LDDK = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAX( NMAX, MMAX + PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 15*NMAX*NMAX + 6*NMAX +
     $                            MAX( 14*NMAX + 23, 16*NMAX,
     $                                 2*NMAX+PMAX+MMAX,
     $                                 3*(PMAX+MMAX) ) +
     $                            MAX( NMAX*NMAX,
     $                                 11*NMAX*PMAX + 2*MMAX*MMAX +
     $                                 8*PMAX*PMAX + 8*MMAX*NMAX +
     $                                 4*MMAX*PMAX + PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FACTOR
      INTEGER          I, INFO, J, M, N, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX),
     $                 DK(LDDK,PMAX), DWORK(LDWORK), RCOND(4)
*     .. External Subroutines ..
      EXTERNAL         SB10KD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) FACTOR
         CALL 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 )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 4 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10KD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10KD =',I2)
99997 FORMAT (/' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (10(1X,F8.4))
99991 FORMAT ( 5(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
      END
Program Data 
 SB10KD EXAMPLE PROGRAM DATA
   6     2     2   
   0.2  0.0  0.3  0.0 -0.3 -0.1
  -0.3  0.2 -0.4 -0.3  0.0  0.0
  -0.1  0.1 -0.1  0.0  0.0 -0.3
   0.1  0.0  0.0 -0.1 -0.1  0.0
   0.0  0.3  0.6  0.2  0.1 -0.4
   0.2 -0.4  0.0  0.0  0.2 -0.2
  -1.0 -2.0
   1.0  3.0 
  -3.0 -4.0 
   1.0 -2.0 
   0.0  1.0
   1.0  5.0  
   1.0 -1.0  2.0 -2.0  0.0 -3.0
  -3.0  0.0  1.0 -1.0  1.0 -1.0
   1.1
Program Results 
 SB10KD EXAMPLE PROGRAM RESULTS


 The controller state matrix AK is

   0.0337   0.0222   0.0858   0.1264  -0.1872   0.1547
   0.4457   0.0668  -0.2255  -0.3204  -0.4548  -0.0691
  -0.2419  -0.2506  -0.0982  -0.1321  -0.0130  -0.0838
  -0.4402   0.3654  -0.0335  -0.2444   0.6366  -0.6469
  -0.3623   0.3854   0.4162   0.4502   0.0065   0.1261
  -0.0121  -0.4377   0.0604   0.2265  -0.3389   0.4542

 The controller input matrix BK is

   0.0931  -0.0269
  -0.0872   0.1599
   0.0956  -0.1469
  -0.1728   0.0129
   0.2022  -0.1154
   0.2419  -0.1737

 The controller output matrix CK is

  -0.3677   0.2188   0.0403  -0.0854   0.3564  -0.3535
   0.1624  -0.0708   0.0058   0.0606  -0.2163   0.1802

 The controller matrix DK is

  -0.0857  -0.0246
   0.0460   0.0074

 The estimated condition numbers are

  0.11269D-01  0.17596D-01  0.18225D+00  0.75968D-03

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10LD.html000077500000000000000000000162451201767322700161010ustar00rootroot00000000000000 SB10LD - SLICOT Library Routine Documentation

SB10LD

Closed-loop system matrices for a system with robust controller

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the closed-loop system

           | AC | BC |
       G = |----|----|,
           | CC | DC |

  from the matrices of the open-loop system

            | A | B |
        P = |---|---|
            | C | D |

  and the matrices of the controller

           | AK | BK |
       K = |----|----|.
           | CK | DK |
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAC, LDAK, LDB, LDBC, LDBK, LDC,
     $                   LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, M, N,
     $                   NCON, NMEAS, NP
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( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0.
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0.
          M-NCON >= NMEAS.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  AK      (input) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array must contain the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (input) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array must contain the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (input) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array must contain the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (input) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array must contain
          the controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  AC      (output) DOUBLE PRECISION array, dimension (LDAC,2*N)
          The leading 2*N-by-2*N part of this array contains the
          closed-loop system state matrix AC.

  LDAC    INTEGER
          The leading dimension of the array AC.
          LDAC >= max(1,2*N).

  BC      (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON)
          The leading 2*N-by-(M-NCON) part of this array contains
          the closed-loop system input matrix BC.

  LDBC    INTEGER
          The leading dimension of the array BC.
          LDBC >= max(1,2*N).

  CC      (output) DOUBLE PRECISION array, dimension (LDCC,2*N)
          The leading (NP-NMEAS)-by-2*N part of this array contains
          the closed-loop system output matrix CC.

  LDCC    INTEGER
          The leading dimension of the array CC.
          LDCC >= max(1,NP-NMEAS).

  DC      (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON)
          The leading (NP-NMEAS)-by-(M-NCON) part of this array
          contains the closed-loop system input/output matrix DC.

  LDDC    INTEGER
          The leading dimension of the array DC.
          LDDC >= max(1,NP-NMEAS).
Workspace 
  IWORK   INTEGER array, dimension 2*max(NCON,NMEAS)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 2*M*M+NP*NP+2*M*N+M*NP+2*N*NP.
          For good performance, LDWORK must generally be larger.

  Error Indicactor

  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix Inp2 - D22*DK is singular to working
                precision;
          = 2:  if the matrix Im2 - DK*D22 is singular to working
                precision.
Method 
  The routine implements the formulas given in [1].
References 
  [1] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  matrices  Inp2 - D22*DK  and  Im2 - DK*D22.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10MD.html000077500000000000000000000266141201767322700161030ustar00rootroot00000000000000 SB10MD - SLICOT Library Routine Documentation

SB10MD

D-step in the D-K iteration for continuous-time case

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To perform the D-step in the D-K iteration. It handles
  continuous-time case.
Specification 
      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     .. 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     .. 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(*)
Arguments

Input/Output Parameters 

  NC      (input) INTEGER
          The order of the matrix A.  NC >= 0.

  MP      (input) INTEGER
          The order of the matrix D.  MP >= 0.

  LENDAT  (input) INTEGER
          The length of the vector OMEGA.  LENDAT >= 2.

  F       (input) INTEGER
          The number of the measurements and controls, i.e.,
          the size of the block I_f in the D-scaling system.
          F >= 0.

  ORD     (input/output) INTEGER
          The MAX order of EACH block in the fitting procedure.
          ORD <= LENDAT-1.
          On exit, if ORD < 1 then ORD = 1.

  MNB     (input) INTEGER
          The number of diagonal blocks in the block structure of
          the uncertainty, and the length of the vectors NBLOCK
          and ITYPE.  1 <= MNB <= MP.

  NBLOCK  (input) INTEGER array, dimension (MNB)
          The vector of length MNB containing the block structure
          of the uncertainty. NBLOCK(I), I = 1:MNB, is the size of
          each block.

  ITYPE   (input) INTEGER array, dimension (MNB)
          The vector of length MNB indicating the type of each
          block.
          For I = 1 : MNB,
          ITYPE(I) = 1 indicates that the corresponding block is a
          real block. IN THIS CASE ONLY MJU(JW) WILL BE ESTIMATED
          CORRECTLY, BUT NOT D(S)!
          ITYPE(I) = 2 indicates that the corresponding block is a
          complex block. THIS IS THE ONLY ALLOWED VALUE NOW!
          NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1.

  QUTOL   (input) DOUBLE PRECISION
          The acceptable mean relative error between the D(jw) and
          the frequency responce of the estimated block
          [ADi,BDi;CDi,DDi]. When it is reached, the result is
          taken as good enough.
          A good value is QUTOL = 2.0.
          If QUTOL < 0 then only mju(jw) is being estimated,
          not D(s).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,NC)
          On entry, the leading NC-by-NC part of this array must
          contain the A matrix of the closed-loop system.
          On exit, if MP > 0, the leading NC-by-NC part of this
          array contains an upper Hessenberg matrix similar to A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,NC).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,MP)
          On entry, the leading NC-by-MP part of this array must
          contain the B matrix of the closed-loop system.
          On exit, the leading NC-by-MP part of this array contains
          the transformed B matrix corresponding to the Hessenberg
          form of A.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,NC).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,NC)
          On entry, the leading MP-by-NC part of this array must
          contain the C matrix of the closed-loop system.
          On exit, the leading MP-by-NC part of this array contains
          the transformed C matrix corresponding to the Hessenberg
          form of A.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,MP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,MP)
          The leading MP-by-MP part of this array must contain the
          D matrix of the closed-loop system.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,MP).

  OMEGA   (input) DOUBLE PRECISION array, dimension (LENDAT)
          The vector with the frequencies.

  TOTORD  (output) INTEGER
          The TOTAL order of the D-scaling system.
          TOTORD is set to zero, if QUTOL < 0.

  AD      (output) DOUBLE PRECISION array, dimension (LDAD,MP*ORD)
          The leading TOTORD-by-TOTORD part of this array contains
          the A matrix of the D-scaling system.
          Not referenced if QUTOL < 0.

  LDAD    INTEGER
          The leading dimension of the array AD.
          LDAD >= MAX(1,MP*ORD), if QUTOL >= 0;
          LDAD >= 1,             if QUTOL <  0.

  BD      (output) DOUBLE PRECISION array, dimension (LDBD,MP+F)
          The leading TOTORD-by-(MP+F) part of this array contains
          the B matrix of the D-scaling system.
          Not referenced if QUTOL < 0.

  LDBD    INTEGER
          The leading dimension of the array BD.
          LDBD >= MAX(1,MP*ORD), if QUTOL >= 0;
          LDBD >= 1,             if QUTOL <  0.

  CD      (output) DOUBLE PRECISION array, dimension (LDCD,MP*ORD)
          The leading (MP+F)-by-TOTORD part of this array contains
          the C matrix of the D-scaling system.
          Not referenced if QUTOL < 0.

  LDCD    INTEGER
          The leading dimension of the array CD.
          LDCD >= MAX(1,MP+F), if QUTOL >= 0;
          LDCD >= 1,           if QUTOL <  0.

  DD      (output) DOUBLE PRECISION array, dimension (LDDD,MP+F)
          The leading (MP+F)-by-(MP+F) part of this array contains
          the D matrix of the D-scaling system.
          Not referenced if QUTOL < 0.

  LDDD    INTEGER
          The leading dimension of the array DD.
          LDDD >= MAX(1,MP+F), if QUTOL >= 0;
          LDDD >= 1,           if QUTOL <  0.

  MJU     (output) DOUBLE PRECISION array, dimension (LENDAT)
          The vector with the upper bound of the structured
          singular value (mju) for each frequency in OMEGA.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)

  LIWORK  INTEGER
          The length of the array IWORK.
          LIWORK >= MAX( NC, 4*MNB-2, MP, 2*ORD+1 ), if QUTOL >= 0;
          LIWORK >= MAX( NC, 4*MNB-2, MP ),          if QUTOL <  0.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK, DWORK(2) returns the optimal value of LZWORK,
          and DWORK(3) returns an estimate of the minimum reciprocal
          of the condition numbers (with respect to inversion) of
          the generated Hessenberg matrices.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 3, LWM, LWD ), where
          LWM = LWA + MAX( NC + MAX( NC, MP-1 ),
                           2*MP*MP*MNB - MP*MP + 9*MNB*MNB +
                           MP*MNB + 11*MP + 33*MNB - 11 );
          LWD = LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ),
                           if QUTOL >= 0;
          LWD = 0,         if QUTOL <  0;
          LWA = MP*LENDAT + 2*MNB + MP - 1;
          LWB = LENDAT*(MP + 2) + ORD*(ORD + 2) + 1;
          LW1 = 2*LENDAT + 4*HNPTS;  HNPTS = 2048;
          LW2 =   LENDAT + 6*HNPTS;  MN  = MIN( 2*LENDAT, 2*ORD+1 );
          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 ) ).

  ZWORK   COMPLEX*16 array, dimension (LZWORK)

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= MAX( LZM, LZD ), where
          LZM = MAX( MP*MP + NC*MP + NC*NC + 2*NC,
                     6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 );
          LZD = MAX( LENDAT*(2*ORD + 3), ORD*ORD + 3*ORD + 1 ),
                           if QUTOL >= 0;
          LZD = 0,         if QUTOL <  0.
Error Indicator 
  INFO    (output) INTEGER
          =  0:  successful exit;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  if one or more values w in OMEGA are (close to
                 some) poles of the closed-loop system, i.e., the
                 matrix jw*I - A is (numerically) singular;
          =  2:  the block sizes must be positive integers;
          =  3:  the sum of block sizes must be equal to MP;
          =  4:  the size of a real block must be equal to 1;
          =  5:  the block type must be either 1 or 2;
          =  6:  errors in solving linear equations or in matrix
                 inversion;
          =  7:  errors in computing eigenvalues or singular values.
          = 1i:  INFO on exit from SB10YD is i. (1i means 10 + i.)
Method 
  I.   First, W(jw) for the given closed-loop system is being
       estimated.
  II.  Now, AB13MD SLICOT subroutine can obtain the D(jw) scaling
       system with respect to NBLOCK and ITYPE, and colaterally,
       mju(jw).
       If QUTOL < 0 then the estimations stop and the routine exits.
  III. Now that we have D(jw), SB10YD subroutine can do block-by-
       block fit. For each block it tries with an increasing order
       of the fit, starting with 1 until the
       (mean quadratic error + max quadratic error)/2
       between the Dii(jw) and the estimated frequency responce
       of the block becomes less than or equal to the routine
       argument QUTOL, or the order becomes equal to ORD.
  IV.  Arrange the obtained blocks in the AD, BD, CD and DD
       matrices and estimate the total order of D(s), TOTORD.
  V.   Add the system I_f to the system obtained in IV.
References 
  [1] Balas, G., Doyle, J., Glover, K., Packard, A. and Smith, R.
      Mu-analysis and Synthesis toolbox - User's Guide,
      The Mathworks Inc., Natick, MA, USA, 1998.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10PD.html000077500000000000000000000202451201767322700161000ustar00rootroot00000000000000 SB10PD - SLICOT Library Routine Documentation

SB10PD

Normalization of a system for H-infinity controller design

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the matrices D12 and D21 of the linear time-invariant
  system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---|
                | C1 | D11 D12 |   | C | D |
                | C2 | D21 D22 |

  to unit diagonal form, to transform the matrices B, C, and D11 to
  satisfy the formulas in the computation of an H2 and H-infinity
  (sub)optimal controllers and to check the rank conditions.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDTU, LDTY, LDWORK,
     $                   M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK( * ), RCOND( 2 ),
     $                   TU( LDTU, * ), TY( LDTY, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the system input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading NP-by-N part of this array must
          contain the system output matrix C.
          On exit, the leading NP-by-N part of this array contains
          the transformed system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading NP-by-M part of this array must
          contain the system input/output matrix D. The
          NMEAS-by-NCON trailing submatrix D22 is not referenced.
          On exit, the leading (NP-NMEAS)-by-(M-NCON) part of this
          array contains the transformed submatrix D11.
          The transformed submatrices D12 = [ 0  Im2 ]' and
          D21 = [ 0  Inp2 ] are not stored. The corresponding part
          of this array contains no useful information.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  TU      (output) DOUBLE PRECISION array, dimension (LDTU,M2)
          The leading M2-by-M2 part of this array contains the
          control transformation matrix TU.

  LDTU    INTEGER
          The leading dimension of the array TU.  LDTU >= max(1,M2).

  TY      (output) DOUBLE PRECISION array, dimension (LDTY,NP2)
          The leading NP2-by-NP2 part of this array contains the
          measurement transformation matrix TY.

  LDTY    INTEGER
          The leading dimension of the array TY.
          LDTY >= max(1,NP2).

  RCOND   (output) DOUBLE PRECISION array, dimension (2)
          RCOND(1) contains the reciprocal condition number of the
                   control transformation matrix TU;
          RCOND(2) contains the reciprocal condition number of the
                   measurement transformation matrix TY.
          RCOND is set even if INFO = 3 or INFO = 4; if INFO = 3,
          then RCOND(2) was not computed, but it is set to 0.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used for controlling the accuracy of the applied
          transformations. Transformation matrices TU and TY whose
          reciprocal condition numbers are less than TOL are not
          allowed. If TOL <= 0, then a default value equal to
          sqrt(EPS) is used, where EPS is the relative machine
          precision.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= MAX(1,LW1,LW2,LW3,LW4), where
          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),
          with M1 = M - M2 and NP1 = NP - NP2.
          For good performance, LDWORK must generally be larger.
          Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is
          MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix | A   B2  | had not full column rank
                              | C1  D12 |
                in respect to the tolerance EPS;
          = 2:  if the matrix | A   B1  | had not full row rank in
                              | C2  D21 |
                respect to the tolerance EPS;
          = 3:  if the matrix D12 had not full column rank in
                respect to the tolerance TOL;
          = 4:  if the matrix D21 had not full row rank in respect
                to the tolerance TOL;
          = 5:  if the singular value decomposition (SVD) algorithm
                did not converge (when computing the SVD of one of
                the matrices |A   B2 |, |A   B1 |, D12 or D21).
                             |C1  D12|  |C2  D21|
Method 
  The routine performs the transformations described in [2].
References 
  [1] Glover, K. and Doyle, J.C.
      State-space formulae for all stabilizing controllers that
      satisfy an Hinf norm bound and relations to risk sensitivity.
      Systems and Control Letters, vol. 11, pp. 167-172, 1988.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.
Numerical Aspects 
  The precision of the transformations can be controlled by the
  condition numbers of the matrices TU and TY as given by the
  values of RCOND(1) and RCOND(2), respectively. An error return
  with INFO = 3 or INFO = 4 will be obtained if the condition
  number of TU or TY, respectively, would exceed 1/TOL.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10QD.html000077500000000000000000000213761201767322700161070ustar00rootroot00000000000000 SB10QD - SLICOT Library Routine Documentation

SB10QD

State feedback and output injection matrices for an H-infinity (sub)optimal state controller (continuous-time)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the state feedback and the output injection
  matrices for an H-infinity (sub)optimal n-state controller,
  using Glover's and Doyle's 1988 formulas, for the system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---|
                | C1 | D11 D12 |   | C | D |
                | C2 | D21 D22 |

  and for a given value of gamma, where B2 has as column size the
  number of control inputs (NCON) and C2 has as row size the number
  of measurements (NMEAS) being provided to the controller.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) D12 is full column rank with D12 = | 0 | and D21 is
                                          | I |
       full row rank with D21 = | 0 I | as obtained by the
       subroutine SB10PD,

  (A3) | A-j*omega*I  B2  | has full column rank for all omega,
       |    C1        D12 |

  (A4) | A-j*omega*I  B1  |  has full row rank for all omega.
       |    C2        D21 |
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDF, LDH, LDWORK,
     $                   LDX, LDY, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   GAMMA
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( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  GAMMA   (input) DOUBLE PRECISION
          The value of gamma. It is assumed that gamma is
          sufficiently large so that the controller is admissible.
          GAMMA >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  F       (output) DOUBLE PRECISION array, dimension (LDF,N)
          The leading M-by-N part of this array contains the state
          feedback matrix F.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= max(1,M).

  H       (output) DOUBLE PRECISION array, dimension (LDH,NP)
          The leading N-by-NP part of this array contains the output
          injection matrix H.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array contains the matrix
          X, solution of the X-Riccati equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
          The leading N-by-N part of this array contains the matrix
          Y, solution of the Y-Riccati equation.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= max(1,N).

  XYCOND  (output) DOUBLE PRECISION array, dimension (2)
          XYCOND(1) contains an estimate of the reciprocal condition
                    number of the X-Riccati equation;
          XYCOND(2) contains an estimate of the reciprocal condition
                    number of the Y-Riccati equation.
Workspace 
  IWORK   INTEGER array, dimension max(2*max(N,M-NCON,NP-NMEAS),N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 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))),
          where M1 = M - M2 and NP1 = NP - NP2.
          For good performance, LDWORK must generally be larger.
          Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is
          max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))).

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the controller is not admissible (too small value
                of gamma);
          = 2:  if the X-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties);
          = 3:  if the Y-Riccati equation was not solved
                successfully (the controller is not admissible or
                there are numerical difficulties).
Method 
  The routine implements the Glover's and Doyle's formulas [1],[2]
  modified as described in [3]. The X- and Y-Riccati equations
  are solved with condition and accuracy estimates [4].
References 
  [1] Glover, K. and Doyle, J.C.
      State-space formulae for all stabilizing controllers that
      satisfy an Hinf norm bound and relations to risk sensitivity.
      Systems and Control Letters, vol. 11, pp. 167-172, 1988.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.

  [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
      Fortran 77 routines for Hinf and H2 design of continuous-time
      linear control systems.
      Rep. 98-14, Department of Engineering, Leicester University,
      Leicester, U.K., 1998.

  [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
      DGRSVX and DMSRIC: Fortan 77 subroutines for solving
      continuous-time matrix algebraic Riccati equations with
      condition and accuracy estimates.
      Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
      Chemnitz, May 1998.
Numerical Aspects 
  The precision of the solution of the matrix Riccati equations
  can be controlled by the values of the condition numbers
  XYCOND(1) and XYCOND(2) of these equations.
Further Comments 
  The Riccati equations are solved by the Schur approach
  implementing condition and accuracy estimates.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10RD.html000077500000000000000000000215541201767322700161060ustar00rootroot00000000000000 SB10RD - SLICOT Library Routine Documentation

SB10RD

H-infinity (sub)optimal controller matrices using state feedback and output injection matrices (continuous-time)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of an H-infinity (sub)optimal controller

           | AK | BK |
       K = |----|----|,
           | CK | DK |

  from the state feedback matrix F and output injection matrix H as
  determined by the SLICOT Library routine SB10QD.
Specification 
      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     .. 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     .. 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, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0.
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0.
          M-NCON >= NMEAS.

  GAMMA   (input) DOUBLE PRECISION
          The value of gamma. It is assumed that gamma is
          sufficiently large so that the controller is admissible.
          GAMMA >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  F       (input) DOUBLE PRECISION array, dimension (LDF,N)
          The leading M-by-N part of this array must contain the
          state feedback matrix F.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= max(1,M).

  H       (input) DOUBLE PRECISION array, dimension (LDH,NP)
          The leading N-by-NP part of this array must contain the
          output injection matrix H.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  TU      (input) DOUBLE PRECISION array, dimension (LDTU,M2)
          The leading M2-by-M2 part of this array must contain the
          control transformation matrix TU, as obtained by the
          SLICOT Library routine SB10PD.

  LDTU    INTEGER
          The leading dimension of the array TU.  LDTU >= max(1,M2).

  TY      (input) DOUBLE PRECISION array, dimension (LDTY,NP2)
          The leading NP2-by-NP2 part of this array must contain the
          measurement transformation matrix TY, as obtained by the
          SLICOT Library routine SB10PD.

  LDTY    INTEGER
          The leading dimension of the array TY.
          LDTY >= max(1,NP2).

  X       (input) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array must contain the
          matrix X, solution of the X-Riccati equation, as obtained
          by the SLICOT Library routine SB10QD.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  Y       (input) DOUBLE PRECISION array, dimension (LDY,N)
          The leading N-by-N part of this array must contain the
          matrix Y, solution of the Y-Riccati equation, as obtained
          by the SLICOT Library routine SB10QD.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= max(1,N).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).
Workspace 
  IWORK   INTEGER array, dimension (LIWORK), where
          LIWORK = max(2*(max(NP,M)-M2-NP2,M2,N),NP2)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= max(1, M2*NP2 + NP2*NP2 + M2*M2 +
                        max(D1*D1 + max(2*D1, (D1+D2)*NP2),
                            D2*D2 + max(2*D2, D2*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))))))
          where D1 = NP1 - M2, D2 = M1 - NP2,
               NP1 = NP - NP2, M1 = M - M2.
          For good performance, LDWORK must generally be larger.
          Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
          max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the controller is not admissible (too small value
                of gamma);
          = 2:  if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero.
Method 
  The routine implements the Glover's and Doyle's formulas [1],[2].
References 
  [1] Glover, K. and Doyle, J.C.
      State-space formulae for all stabilizing controllers that
      satisfy an Hinf norm bound and relations to risk sensitivity.
      Systems and Control Letters, vol. 11, pp. 167-172, 1988.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  input and output transformations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10SD.html000077500000000000000000000225131201767322700161030ustar00rootroot00000000000000 SB10SD - SLICOT Library Routine Documentation

SB10SD

H2 optimal controller matrices for a normalized discrete-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the H2 optimal controller

           | AK | BK |
       K = |----|----|,
           | CK | DK |

  for the normalized discrete-time system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---|
                | C1 | D11 D12 |   | C | D |
                | C2 | D21  0  |

  where B2 has as column size the number of control inputs (NCON)
  and C2 has as row size the number of measurements (NMEAS) being
  provided to the controller.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) D12 is full column rank with D12 = | 0 | and D21 is
                                          | I |
       full row rank with D21 = | 0 I | as obtained by the
       SLICOT Library routine SB10PD,

            j*Theta
  (A3) | A-e       *I  B2  | has full column rank for all
       |    C1         D12 |

       0 <= Theta < 2*Pi ,

            j*Theta
  (A4) | A-e       *I  B1  | has full row rank for all
       |    C2         D21 |

       0 <= Theta < 2*Pi .
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, LDX, LDY, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   TOL
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( * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D. Only the leading
          (NP-NP2)-by-(M-M2) submatrix D11 is used.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array contains the matrix
          X, solution of the X-Riccati equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
          The leading N-by-N part of this array contains the matrix
          Y, solution of the Y-Riccati equation.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= max(1,N).

  RCOND   (output) DOUBLE PRECISION array, dimension (4)
          RCOND contains estimates of the reciprocal condition
          numbers of the matrices which are to be inverted and the
          reciprocal condition numbers of the Riccati equations
          which have to be solved during the computation of the
          controller. (See the description of the algorithm in [2].)
          RCOND(1) contains the reciprocal condition number of the
                   matrix Im2 + B2'*X2*B2;
          RCOND(2) contains the reciprocal condition number of the
                   matrix Ip2 + C2*Y2*C2';
          RCOND(3) contains the reciprocal condition number of the
                   X-Riccati equation;
          RCOND(4) contains the reciprocal condition number of the
                   Y-Riccati equation.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used in determining the nonsingularity of the
          matrices which must be inverted. If TOL <= 0, then a
          default value equal to sqrt(EPS) is used, where EPS is the
          relative machine precision.
Workspace 
  IWORK   INTEGER array, dimension max(M2,2*N,N*N,NP2)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= max(1, 14*N*N+6*N+max(14*N+23,16*N),
                           M2*(N+M2+max(3,M1)), NP2*(N+NP2+3)),
          where M1 = M - M2.
          For good performance, LDWORK must generally be larger.

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the X-Riccati equation was not solved
                successfully;
          = 2:  if the matrix Im2 + B2'*X2*B2 is not positive
                definite, or it is numerically singular (with
                respect to the tolerance TOL);
          = 3:  if the Y-Riccati equation was not solved
                successfully;
          = 4:  if the matrix Ip2 + C2*Y2*C2' is not positive
                definite, or it is numerically singular (with
                respect to the tolerance TOL).
Method 
  The routine implements the formulas given in [1]. The X- and
  Y-Riccati equations are solved with condition estimates.
References 
  [1] Zhou, K., Doyle, J.C., and Glover, K.
      Robust and Optimal Control.
      Prentice-Hall, Upper Saddle River, NJ, 1996.

  [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
      Fortran 77 routines for Hinf and H2 design of linear
      discrete-time control systems.
      Report 99-8, Department of Engineering, Leicester University,
      April 1999.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  matrices which are to be inverted and on the condition numbers of
  the matrix Riccati equations which are to be solved in the
  computation of the controller. (The corresponding reciprocal
  condition numbers are given in the output array RCOND.)
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10TD.html000077500000000000000000000161721201767322700161100ustar00rootroot00000000000000 SB10TD - SLICOT Library Routine Documentation

SB10TD

H2 optimal controller matrices for a discrete-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the H2 optimal discrete-time controller

           | AK | BK |
       K = |----|----|,
           | CK | DK |

  from the matrices of the controller for the normalized system,
  as determined by the SLICOT Library routine SB10SD.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDAK, LDBK, LDCK, LDD, LDDK, LDTU, LDTY,
     $                   LDWORK, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   RCOND, TOL
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AK( LDAK, * ), BK( LDBK, * ), CK( LDCK, * ),
     $                   D( LDD, * ), DK( LDDK, * ), DWORK( * ),
     $                   TU( LDTU, * ), TY( LDTY, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0.
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0.
          M-NCON >= NMEAS.

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D. Only the trailing
          NMEAS-by-NCON submatrix D22 is used.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  TU      (input) DOUBLE PRECISION array, dimension (LDTU,M2)
          The leading M2-by-M2 part of this array must contain the
          control transformation matrix TU, as obtained by the
          SLICOT Library routine SB10PD.

  LDTU    INTEGER
          The leading dimension of the array TU.  LDTU >= max(1,M2).

  TY      (input) DOUBLE PRECISION array, dimension (LDTY,NP2)
          The leading NP2-by-NP2 part of this array must contain the
          measurement transformation matrix TY, as obtained by the
          SLICOT Library routine SB10PD.

  LDTY    INTEGER
          The leading dimension of the array TY.
          LDTY >= max(1,NP2).

  AK      (input/output) DOUBLE PRECISION array, dimension (LDAK,N)
          On entry, the leading N-by-N part of this array must
          contain controller state matrix for the normalized system
          as obtained by the SLICOT Library routine SB10SD.
          On exit, the leading N-by-N part of this array contains
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (input/output) DOUBLE PRECISION array, dimension
          (LDBK,NMEAS)
          On entry, the leading N-by-NMEAS part of this array must
          contain controller input matrix for the normalized system
          as obtained by the SLICOT Library routine SB10SD.
          On exit, the leading N-by-NMEAS part of this array
          contains controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (input/output) DOUBLE PRECISION array, dimension (LDCK,N)
          On entry, the leading NCON-by-N part of this array must
          contain controller output matrix for the normalized
          system as obtained by the SLICOT Library routine SB10SD.
          On exit, the leading NCON-by-N part of this array contains
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (input/output) DOUBLE PRECISION array, dimension
          (LDDK,NMEAS)
          On entry, the leading NCON-by-NMEAS part of this array
          must contain controller matrix DK for the normalized
          system as obtained by the SLICOT Library routine SB10SD.
          On exit, the leading NCON-by-NMEAS part of this array
          contains controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).

  RCOND   (output) DOUBLE PRECISION
          RCOND contains an estimate of the reciprocal condition
          number of the matrix Im2 + DKHAT*D22 which must be
          inverted in the computation of the controller.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used in determining the nonsingularity of the
          matrix which must be inverted. If TOL <= 0, then a default
          value equal to sqrt(EPS) is used, where EPS is the
          relative machine precision.
Workspace 
  IWORK   INTEGER array, dimension (2*M2)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix Im2 + DKHAT*D22 is singular, or the
                estimated condition number is larger than or equal
                to 1/TOL.
Method 
  The routine implements the formulas given in [1].
References 
  [1] Zhou, K., Doyle, J.C., and Glover, K.
      Robust and Optimal Control.
      Prentice-Hall, Upper Saddle River, NJ, 1996.

  [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
      Fortran 77 routines for Hinf and H2 design of linear
      discrete-time control systems.
      Report 99-8, Department of Engineering, Leicester University,
      April 1999.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  input and output transformations and of the matrix Im2 +
  DKHAT*D22.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10UD.html000077500000000000000000000164051201767322700161100ustar00rootroot00000000000000 SB10UD - SLICOT Library Routine Documentation

SB10UD

Normalization of a system for H2 controller design

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the matrices D12 and D21 of the linear time-invariant
  system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---|
                | C1 |  0  D12 |   | C | D |
                | C2 | D21 D22 |

  to unit diagonal form, and to transform the matrices B and C to
  satisfy the formulas in the computation of the H2 optimal
  controller.
Specification 
      SUBROUTINE SB10UD( N, M, NP, NCON, NMEAS, B, LDB, C, LDC, D, LDD,
     $                   TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, LDWORK,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDB, LDC, LDD, LDTU, LDTY, LDWORK, M, N,
     $                   NCON, NMEAS, NP
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), C( LDC, * ), D( LDD, * ),
     $                   DWORK( * ), RCOND( 2 ), TU( LDTU, * ),
     $                   TY( LDTY, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the system input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading NP-by-N part of this array must
          contain the system output matrix C.
          On exit, the leading NP-by-N part of this array contains
          the transformed system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading NP-by-M part of this array must
          contain the system input/output matrix D.
          The (NP-NMEAS)-by-(M-NCON) leading submatrix D11 is not
          referenced.
          On exit, the trailing NMEAS-by-NCON part (in the leading
          NP-by-M part) of this array contains the transformed
          submatrix D22.
          The transformed submatrices D12 = [ 0  Im2 ]' and
          D21 = [ 0  Inp2 ] are not stored. The corresponding part
          of this array contains no useful information.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  TU      (output) DOUBLE PRECISION array, dimension (LDTU,M2)
          The leading M2-by-M2 part of this array contains the
          control transformation matrix TU.

  LDTU    INTEGER
          The leading dimension of the array TU.  LDTU >= max(1,M2).

  TY      (output) DOUBLE PRECISION array, dimension (LDTY,NP2)
          The leading NP2-by-NP2 part of this array contains the
          measurement transformation matrix TY.

  LDTY    INTEGER
          The leading dimension of the array TY.
          LDTY >= max(1,NP2).

  RCOND   (output) DOUBLE PRECISION array, dimension (2)
          RCOND(1) contains the reciprocal condition number of the
                   control transformation matrix TU;
          RCOND(2) contains the reciprocal condition number of the
                   measurement transformation matrix TY.
          RCOND is set even if INFO = 1 or INFO = 2; if INFO = 1,
          then RCOND(2) was not computed, but it is set to 0.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used for controlling the accuracy of the applied
          transformations. Transformation matrices TU and TY whose
          reciprocal condition numbers are less than TOL are not
          allowed. If TOL <= 0, then a default value equal to
          sqrt(EPS) is used, where EPS is the relative machine
          precision.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 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 )
          where M1 = M - M2 and NP1 = NP - NP2.
          For good performance, LDWORK must generally be larger.
          Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is
          MAX(1,Q*(Q+MAX(N,5)+1)).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the matrix D12 had not full column rank in
                respect to the tolerance TOL;
          = 2:  if the matrix D21 had not full row rank in respect
                to the tolerance TOL;
          = 3:  if the singular value decomposition (SVD) algorithm
                did not converge (when computing the SVD of D12 or
                D21).
Method 
  The routine performs the transformations described in [1], [2].
References 
  [1] Zhou, K., Doyle, J.C., and Glover, K.
      Robust and Optimal Control.
      Prentice-Hall, Upper Saddle River, NJ, 1996.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.
Numerical Aspects 
  The precision of the transformations can be controlled by the
  condition numbers of the matrices TU and TY as given by the
  values of RCOND(1) and RCOND(2), respectively. An error return
  with INFO = 1 or INFO = 2 will be obtained if the condition
  number of TU or TY, respectively, would exceed 1/TOL.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10VD.html000077500000000000000000000157761201767322700161230ustar00rootroot00000000000000 SB10VD - SLICOT Library Routine Documentation

SB10VD

State feedback and output injection matrices for an H2 optimal state controller (continuous-time)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the state feedback and the output injection
  matrices for an H2 optimal n-state controller for the system

                | A  | B1  B2  |   | A | B |
            P = |----|---------| = |---|---|
                | C1 |  0  D12 |   | C | D |
                | C2 | D21 D22 |

  where B2 has as column size the number of control inputs (NCON)
  and C2 has as row size the number of measurements (NMEAS) being
  provided to the controller.

  It is assumed that

  (A1) (A,B2) is stabilizable and (C2,A) is detectable,

  (A2) D12 is full column rank with D12 = | 0 | and D21 is
                                          | I |
       full row rank with D21 = | 0 I | as obtained by the
       SLICOT Library routine SB10UD. Matrix D is not used
       explicitly.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LDF, LDH, LDWORK, LDX,
     $                   LDY, M, N, NCON, NMEAS, NP
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, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0,
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0,
          M-NCON >= NMEAS.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  F       (output) DOUBLE PRECISION array, dimension (LDF,N)
          The leading NCON-by-N part of this array contains the
          state feedback matrix F.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= max(1,NCON).

  H       (output) DOUBLE PRECISION array, dimension (LDH,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          output injection matrix H.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          The leading N-by-N part of this array contains the matrix
          X, solution of the X-Riccati equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= max(1,N).

  Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
          The leading N-by-N part of this array contains the matrix
          Y, solution of the Y-Riccati equation.

  LDY     INTEGER
          The leading dimension of the array Y.  LDY >= max(1,N).

  XYCOND  (output) DOUBLE PRECISION array, dimension (2)
          XYCOND(1) contains an estimate of the reciprocal condition
                    number of the X-Riccati equation;
          XYCOND(2) contains an estimate of the reciprocal condition
                    number of the Y-Riccati equation.
Workspace 
  IWORK   INTEGER array, dimension max(2*N,N*N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal
          LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 13*N*N + 12*N + 5.
          For good performance, LDWORK must generally be larger.

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the X-Riccati equation was not solved
                successfully;
          = 2:  if the Y-Riccati equation was not solved
                successfully.
Method 
  The routine implements the formulas given in [1], [2]. The X-
  and Y-Riccati equations are solved with condition and accuracy
  estimates [3].
References 
  [1] Zhou, K., Doyle, J.C., and Glover, K.
      Robust and Optimal Control.
      Prentice-Hall, Upper Saddle River, NJ, 1996.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.

  [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
      DGRSVX and DMSRIC: Fortan 77 subroutines for solving
      continuous-time matrix algebraic Riccati equations with
      condition and accuracy estimates.
      Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
      Chemnitz, May 1998.
Numerical Aspects 
  The precision of the solution of the matrix Riccati equations
  can be controlled by the values of the condition numbers
  XYCOND(1) and XYCOND(2) of these equations.
Further Comments 
  The Riccati equations are solved by the Schur approach
  implementing condition and accuracy estimates.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10WD.html000077500000000000000000000153451201767322700161140ustar00rootroot00000000000000 SB10WD - SLICOT Library Routine Documentation

SB10WD

H2 optimal controller matrices using state feedback and output injection matrices (continuous-time)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the H2 optimal controller

           | AK | BK |
       K = |----|----|,
           | CK | DK |

  from the state feedback matrix F and output injection matrix H as
  determined by the SLICOT Library routine SB10VD.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDF, LDH, LDTU, LDTY, M, N, NCON, NMEAS,
     $                   NP
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, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  NCON    (input) INTEGER
          The number of control inputs (M2).  M >= NCON >= 0.
          NP-NMEAS >= NCON.

  NMEAS   (input) INTEGER
          The number of measurements (NP2).  NP >= NMEAS >= 0.
          M-NCON >= NMEAS.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B. Only the submatrix
          B2 = B(:,M-M2+1:M) is used.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C. Only the submatrix
          C2 = C(NP-NP2+1:NP,:) is used.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D. Only the submatrix
          D22 = D(NP-NP2+1:NP,M-M2+1:M) is used.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  F       (input) DOUBLE PRECISION array, dimension (LDF,N)
          The leading NCON-by-N part of this array must contain the
          state feedback matrix F.

  LDF     INTEGER
          The leading dimension of the array F.  LDF >= max(1,NCON).

  H       (input) DOUBLE PRECISION array, dimension (LDH,NMEAS)
          The leading N-by-NMEAS part of this array must contain the
          output injection matrix H.

  LDH     INTEGER
          The leading dimension of the array H.  LDH >= max(1,N).

  TU      (input) DOUBLE PRECISION array, dimension (LDTU,M2)
          The leading M2-by-M2 part of this array must contain the
          control transformation matrix TU, as obtained by the
          SLICOT Library routine SB10UD.

  LDTU    INTEGER
          The leading dimension of the array TU.  LDTU >= max(1,M2).

  TY      (input) DOUBLE PRECISION array, dimension (LDTY,NP2)
          The leading NP2-by-NP2 part of this array must contain the
          measurement transformation matrix TY, as obtained by the
          SLICOT Library routine SB10UD.

  LDTY    INTEGER
          The leading dimension of the array TY.
          LDTY >= max(1,NP2).

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix AK.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
          The leading N-by-NMEAS part of this array contains the
          controller input matrix BK.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading NCON-by-N part of this array contains the
          controller output matrix CK.

  LDCK    INTEGER
          The leading dimension of the array CK.
          LDCK >= max(1,NCON).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
          The leading NCON-by-NMEAS part of this array contains the
          controller input/output matrix DK.

  LDDK    INTEGER
          The leading dimension of the array DK.
          LDDK >= max(1,NCON).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine implements the formulas given in [1], [2].
References 
  [1] Zhou, K., Doyle, J.C., and Glover, K.
      Robust and Optimal Control.
      Prentice-Hall, Upper Saddle River, NJ, 1996.

  [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
      Smith, R.
      mu-Analysis and Synthesis Toolbox.
      The MathWorks Inc., Natick, Mass., 1995.
Numerical Aspects 
  The accuracy of the result depends on the condition numbers of the
  input and output transformations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10YD.html000077500000000000000000000204461201767322700161140ustar00rootroot00000000000000 SB10YD - SLICOT Library Routine Documentation

SB10YD

Fitting frequency response data with a stable, minimum phase SISO system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To fit a supplied frequency response data with a stable, minimum
  phase SISO (single-input single-output) system represented by its
  matrices A, B, C, D. It handles both discrete- and continuous-time
  cases.
Specification 
      SUBROUTINE SB10YD( DISCFL, FLAG, LENDAT, RFRDAT, IFRDAT, OMEGA, N,
     $                   A, LDA, B, C, D, TOL, IWORK, DWORK, LDWORK,
     $                   ZWORK, LZWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            DISCFL, FLAG, INFO, LDA, LDWORK, LENDAT,
     $                   LZWORK, N
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IWORK(*)
      DOUBLE PRECISION   A(LDA, *), B(*), C(*), D(*), DWORK(*),
     $                   IFRDAT(*), OMEGA(*), RFRDAT(*)
      COMPLEX*16         ZWORK(*)
Arguments

Input/Output Parameters 

  DISCFL  (input) INTEGER
          Indicates the type of the system, as follows:
          = 0: continuous-time system;
          = 1: discrete-time system.

  FLAG    (input) INTEGER
          If FLAG = 0, then the system zeros and poles are not
          constrained.
          If FLAG = 1, then the system zeros and poles will have
          negative real parts in the continuous-time case, or moduli
          less than 1 in the discrete-time case. Consequently, FLAG
          must be equal to 1 in mu-synthesis routines.

  LENDAT  (input) INTEGER
          The length of the vectors RFRDAT, IFRDAT and OMEGA.
          LENDAT >= 2.

  RFRDAT  (input) DOUBLE PRECISION array, dimension (LENDAT)
          The real part of the frequency data to be fitted.

  IFRDAT  (input) DOUBLE PRECISION array, dimension (LENDAT)
          The imaginary part of the frequency data to be fitted.

  OMEGA   (input) DOUBLE PRECISION array, dimension (LENDAT)
          The frequencies corresponding to RFRDAT and IFRDAT.
          These values must be nonnegative and monotonically
          increasing. Additionally, for discrete-time systems
          they must be between 0 and PI.

  N       (input/output) INTEGER
          On entry, the desired order of the system to be fitted.
          N <= LENDAT-1.
          On exit, the order of the obtained system. The value of N
          could only be modified if N > 0 and FLAG = 1.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the
          matrix A. If FLAG = 1, then A is in an upper Hessenberg
          form, and corresponds to a minimal realization.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (output) DOUBLE PRECISION array, dimension (N)
          The computed vector B.

  C       (output) DOUBLE PRECISION array, dimension (N)
          The computed vector C. If FLAG = 1, the first N-1 elements
          are zero (for the exit value of N).

  D       (output) DOUBLE PRECISION array, dimension (1)
          The computed scalar D.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used for determining the effective
          rank of matrices. If the user sets TOL > 0, then the given
          value of TOL is used as a lower bound for the reciprocal
          condition number;  a (sub)matrix whose estimated condition
          number is less than 1/TOL is considered to be of full
          rank.  If the user sets TOL <= 0, then an implicitly
          computed, default tolerance, defined by TOLDEF = SIZE*EPS,
          is used instead, where SIZE is the product of the matrix
          dimensions, and EPS is the machine precision (see LAPACK
          Library routine DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension max(2,2*N+1)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK and DWORK(2) contains the optimal value of
          LZWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK = max( 2, LW1, LW2, LW3, LW4 ), where
          LW1 = 2*LENDAT + 4*HNPTS;  HNPTS = 2048;
          LW2 =   LENDAT + 6*HNPTS;
          MN  = min( 2*LENDAT, 2*N+1 )
          LW3 = 2*LENDAT*(2*N+1) + max( 2*LENDAT, 2*N+1 ) +
                max( MN + 6*N + 4, 2*MN + 1 ), if N > 0;
          LW3 = 4*LENDAT + 5                 , if N = 0;
          LW4 = max( N*N + 5*N, 6*N + 1 + min( 1,N ) ), if FLAG = 1;
          LW4 = 0,                                      if FLAG = 0.
          For optimum performance LDWORK should be larger.

  ZWORK   COMPLEX*16 array, dimension (LZWORK)

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK = LENDAT*(2*N+3), if N > 0;
          LZWORK = LENDAT,         if N = 0.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the discrete --> continuous transformation cannot
                be made;
          = 2:  if the system poles cannot be found;
          = 3:  if the inverse system cannot be found, i.e., D is
                (close to) zero;
          = 4:  if the system zeros cannot be found;
          = 5:  if the state-space representation of the new
                transfer function T(s) cannot be found;
          = 6:  if the continuous --> discrete transformation cannot
                be made.
Method 
  First, if the given frequency data are corresponding to a
  continuous-time system, they are changed to a discrete-time
  system using a bilinear transformation with a scaled alpha.
  Then, the magnitude is obtained from the supplied data.
  Then, the frequency data are linearly interpolated around
  the unit-disc.
  Then, Oppenheim and Schafer complex cepstrum method is applied
  to get frequency data corresponding to a stable, minimum-
  phase system. This is done in the following steps:
  - Obtain LOG (magnitude)
  - Obtain IFFT of the result (DG01MD SLICOT subroutine);
  - halve the data at 0;
  - Obtain FFT of the halved data (DG01MD SLICOT subroutine);
  - Obtain EXP of the result.
  Then, the new frequency data are interpolated back to the
  original frequency.
  Then, based on these newly obtained data, the system matrices
  A, B, C, D are constructed; the very identification is
  performed by Least Squares Method using DGELSY LAPACK subroutine.
  If needed, a discrete-to-continuous time transformation is
  applied on the system matrices by AB04MD SLICOT subroutine.
  Finally, if requested, the poles and zeros of the system are
  checked. If some of them have positive real parts in the
  continuous-time case (or are not inside the unit disk in the
  complex plane in the discrete-time case), they are exchanged with
  their negatives (or reciprocals, respectively), to preserve the
  frequency response, while getting a minimum phase and stable
  system. This is done by SB10ZP SLICOT subroutine.
References 
  [1] Oppenheim, A.V. and Schafer, R.W.
      Discrete-Time Signal Processing.
      Prentice-Hall Signal Processing Series, 1989.

  [2] Balas, G., Doyle, J., Glover, K., Packard, A., and Smith, R.
      Mu-analysis and Synthesis toolbox - User's Guide,
      The Mathworks Inc., Natick, MA, USA, 1998.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB10ZD.html000077500000000000000000000330641201767322700161150ustar00rootroot00000000000000 SB10ZD - SLICOT Library Routine Documentation

SB10ZD

Positive feedback controller for a discrete-time system (D <> 0)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the matrices of the positive feedback controller

           | Ak | Bk |
       K = |----|----|
           | Ck | Dk |

  for the shaped plant

           | A | B |
       G = |---|---|
           | C | D |

  in the Discrete-Time Loop Shaping Design Procedure.
Specification 
      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     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, M, N, NP
      DOUBLE PRECISION   FACTOR, TOL
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 )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the plant.  N >= 0.

  M       (input) INTEGER
          The column size of the matrix B.  M >= 0.

  NP      (input) INTEGER
          The row size of the matrix C.  NP >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          system state matrix A of the shaped plant.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          system input matrix B of the shaped plant.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= max(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading NP-by-N part of this array must contain the
          system output matrix C of the shaped plant.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= max(1,NP).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading NP-by-M part of this array must contain the
          system input/output matrix D of the shaped plant.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= max(1,NP).

  FACTOR  (input) DOUBLE PRECISION
          = 1  implies that an optimal controller is required
               (not recommended);
          > 1  implies that a suboptimal controller is required
               achieving a performance FACTOR less than optimal.
          FACTOR >= 1.

  AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
          The leading N-by-N part of this array contains the
          controller state matrix Ak.

  LDAK    INTEGER
          The leading dimension of the array AK.  LDAK >= max(1,N).

  BK      (output) DOUBLE PRECISION array, dimension (LDBK,NP)
          The leading N-by-NP part of this array contains the
          controller input matrix Bk.

  LDBK    INTEGER
          The leading dimension of the array BK.  LDBK >= max(1,N).

  CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
          The leading M-by-N part of this array contains the
          controller output matrix Ck.

  LDCK    INTEGER
          The leading dimension of the array CK.  LDCK >= max(1,M).

  DK      (output) DOUBLE PRECISION array, dimension (LDDK,NP)
          The leading M-by-NP part of this array contains the
          controller matrix Dk.

  LDDK    INTEGER
          The leading dimension of the array DK.  LDDK >= max(1,M).

  RCOND   (output) DOUBLE PRECISION array, dimension (6)
          RCOND(1) contains an estimate of the reciprocal condition
                   number of the linear system of equations from
                   which the solution of the P-Riccati equation is
                   obtained;
          RCOND(2) contains an estimate of the reciprocal condition
                   number of the linear system of equations from
                   which the solution of the Q-Riccati equation is
                   obtained;
          RCOND(3) contains an estimate of the reciprocal condition
                   number of the matrix (gamma^2-1)*In - P*Q;
          RCOND(4) contains an estimate of the reciprocal condition
                   number of the matrix Rx + Bx'*X*Bx;
          RCOND(5) contains an estimate of the reciprocal condition
                                               ^
                   number of the matrix Ip + D*Dk;
          RCOND(6) contains an estimate of the reciprocal condition
                                             ^
                   number of the matrix Im + Dk*D.
Tolerances 
  TOL     DOUBLE PRECISION
          Tolerance used for checking the nonsingularity of the
          matrices to be inverted. If TOL <= 0, then a default value
          equal to sqrt(EPS) is used, where EPS is the relative
          machine precision.  TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension 2*max(N,M+NP)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 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).
          For good performance, LDWORK must generally be larger.

  BWORK   LOGICAL array, dimension (2*N)
Error Indicator 
  INFO    (output) INTEGER
          =  0:  successful exit;
          <  0:  if INFO = -i, the i-th argument had an illegal
                 value;
          =  1:  the P-Riccati equation is not solved successfully;
          =  2:  the Q-Riccati equation is not solved successfully;
          =  3:  the iteration to compute eigenvalues or singular
                 values failed to converge;
          =  4:  the matrix (gamma^2-1)*In - P*Q is singular;
          =  5:  the matrix Rx + Bx'*X*Bx is singular;
                                   ^
          =  6:  the matrix Ip + D*Dk is singular;
                                 ^
          =  7:  the matrix Im + Dk*D is singular;
          =  8:  the matrix Ip - D*Dk is singular;
          =  9:  the matrix Im - Dk*D is singular;
          = 10:  the closed-loop system is unstable.
Method 
  The routine implements the formulas given in [1].
References 
  [1] Gu, D.-W., Petkov, P.H., and Konstantinov, M.M.
      On discrete H-infinity loop shaping design procedure routines.
      Technical Report 00-6, Dept. of Engineering, Univ. of
      Leicester, UK, 2000.
Numerical Aspects 
  The accuracy of the results depends on the conditioning of the
  two Riccati equations solved in the controller design. For
  better conditioning it is advised to take FACTOR > 1.
Further Comments 
  None
Example

Program Text 

*     SB10ZD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, PMAX
      PARAMETER        ( MMAX = 10, NMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK
      PARAMETER        ( LDA  = NMAX, LDAK = NMAX, LDB  = NMAX,
     $                   LDBK = NMAX, LDC  = PMAX, LDCK = MMAX,
     $                   LDD  = PMAX, LDDK = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAX( NMAX, MMAX + PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 16*NMAX*NMAX + 5*MMAX*MMAX +
     $                            7*PMAX*PMAX + 6*MMAX*NMAX +
     $                            7*MMAX*PMAX + 7*NMAX*PMAX + 6*NMAX +
     $                            2*( MMAX + PMAX ) +
     $                            MAX( 14*NMAX + 23, 16*NMAX,
     $                                  2*MMAX - 1, 2*PMAX - 1 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FACTOR, TOL
      INTEGER          I, INFO, J, M, N, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX),   AK(LDAK,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,PMAX), C(LDC,NMAX),   CK(LDCK,NMAX),
     $                 D(LDD,MMAX),   DK(LDDK,PMAX), DWORK(LDWORK),
     $                 RCOND( 6 )
*     .. External Subroutines ..
      EXTERNAL         SB10ZD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) FACTOR, TOL
         CALL 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 )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1,6 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10ZD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10ZD =',I2)
99997 FORMAT (/' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (10(1X,F8.4))
99991 FORMAT ( 5(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
      END
Program Data 
 SB10LD EXAMPLE PROGRAM DATA
   6     2     3   
   0.2  0.0  3.0  0.0 -0.3 -0.1
  -3.0  0.2 -0.4 -0.3  0.0  0.0
  -0.1  0.1 -1.0  0.0  0.0 -3.0
   1.0  0.0  0.0 -1.0 -1.0  0.0
   0.0  0.3  0.6  2.0  0.1 -0.4
   0.2 -4.0  0.0  0.0  0.2 -2.0
  -1.0 -2.0
   1.0  3.0 
  -3.0 -4.0 
   1.0 -2.0 
   0.0  1.0
   1.0  5.0  
   1.0 -1.0  2.0 -2.0  0.0 -3.0
  -3.0  0.0  1.0 -1.0  1.0 -1.0
   2.0  4.0 -3.0  0.0  5.0  1.0
  10.0 -6.0
  -7.0  8.0
   2.0 -4.0
   1.1  0.0
Program Results 
 SB10ZD EXAMPLE PROGRAM RESULTS


 The controller state matrix AK is

   1.0128   0.5101  -0.1546   1.1300   3.3759   0.4911
  -2.1257  -1.4517  -0.4486   0.3493  -1.5506  -1.4296
  -1.0930  -0.6026  -0.1344   0.2253  -1.5625  -0.6762
   0.3207   0.1698   0.2376  -1.1781  -0.8705   0.2896
   0.5017   0.9006   0.0668   2.3613   0.2049   0.3703
   1.0787   0.6703   0.2783  -0.7213   0.4918   0.7435

 The controller input matrix BK is

   0.4132   0.3112  -0.8077
   0.2140   0.4253   0.1811
  -0.0710   0.0807   0.3558
  -0.0121  -0.2019   0.0249
   0.1047   0.1399  -0.0457
  -0.2542  -0.3472   0.0523

 The controller output matrix CK is

  -0.0372  -0.0456  -0.0040   0.0962  -0.2059  -0.0571
   0.1999   0.2994   0.1335  -0.0251  -0.3108   0.2048

 The controller matrix DK is

   0.0629  -0.0022   0.0363
  -0.0228   0.0195   0.0600

 The estimated condition numbers are

  0.27949D-03  0.66679D-03  0.45677D-01  0.23433D-07  0.68495D-01
  0.76854D-01

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB10ZP.html000077500000000000000000000124431201767322700161270ustar00rootroot00000000000000 SB10ZP - SLICOT Library Routine Documentation

SB10ZP

Transforming a SISO system into a stable and minimum phase one

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To transform a SISO (single-input single-output) system [A,B;C,D]
  by mirroring its unstable poles and zeros in the boundary of the
  stability domain, thus preserving the frequency response of the
  system, but making it stable and minimum phase. Specifically, for
  a continuous-time system, the positive real parts of its poles
  and zeros are exchanged with their negatives. Discrete-time
  systems are first converted to continuous-time systems using a
  bilinear transformation, and finally converted back.
Specification 
      SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK,
     $                   LDWORK, INFO )
C     .. Scalar Arguments ..
      INTEGER            DISCFL, INFO, LDA, LDWORK, N
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( * ), C( * ), D( * ), DWORK( * )
Arguments

Input/Output Parameters 

  DISCFL  (input) INTEGER
          Indicates the type of the system, as follows:
          = 0: continuous-time system;
          = 1: discrete-time system.

  N       (input/output) INTEGER
          On entry, the order of the original system.  N >= 0.
          On exit, the order of the transformed, minimal system.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original system matrix A.
          On exit, the leading N-by-N part of this array contains
          the transformed matrix A, in an upper Hessenberg form.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the original system
          vector B.
          On exit, this array contains the transformed vector B.

  C       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the original system
          vector C.
          On exit, this array contains the transformed vector C.
          The first N-1 elements are zero (for the exit value of N).

  D       (input/output) DOUBLE PRECISION array, dimension (1)
          On entry, this array must contain the original system
          scalar D.
          On exit, this array contains the transformed scalar D.
Workspace 
  IWORK   INTEGER array, dimension max(2,N+1)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= max(N*N + 5*N, 6*N + 1 + min(1,N)).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the discrete --> continuous transformation cannot
                be made;
          = 2:  if the system poles cannot be found;
          = 3:  if the inverse system cannot be found, i.e., D is
                (close to) zero;
          = 4:  if the system zeros cannot be found;
          = 5:  if the state-space representation of the new
                transfer function T(s) cannot be found;
          = 6:  if the continuous --> discrete transformation cannot
                be made.
Method 
  First, if the system is discrete-time, it is transformed to
  continuous-time using alpha = beta = 1 in the bilinear
  transformation implemented in the SLICOT routine AB04MD.
  Then the eigenvalues of A, i.e., the system poles, are found.
  Then, the inverse of the original system is found and its poles,
  i.e., the system zeros, are evaluated.
  The obtained system poles Pi and zeros Zi are checked and if a
  positive real part is detected, it is exchanged by -Pi or -Zi.
  Then the polynomial coefficients of the transfer function
  T(s) = Q(s)/P(s) are found.
  The state-space representation of T(s) is then obtained.
  The system matrices B, C, D are scaled so that the transformed
  system has the same system gain as the original system.
  If the original system is discrete-time, then the result (which is
  continuous-time) is converted back to discrete-time.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB16AD.html000077500000000000000000000633031201767322700160710ustar00rootroot00000000000000 SB16AD - SLICOT Library Routine Documentation

SB16AD

Stability/performance enforcing frequency-weighted controller reduction

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute a reduced order controller (Acr,Bcr,Ccr,Dcr) for an
  original state-space controller representation (Ac,Bc,Cc,Dc) by
  using the frequency-weighted square-root or balancing-free
  square-root Balance & Truncate (B&T) or Singular Perturbation
  Approximation (SPA) model reduction methods. The algorithm tries
  to minimize the norm of the frequency-weighted error

        ||V*(K-Kr)*W||

  where K and Kr are the transfer-function matrices of the original
  and reduced order controllers, respectively. V and W are special
  frequency-weighting transfer-function matrices constructed
  to enforce closed-loop stability and/or closed-loop performance.
  If G is the transfer-function matrix of the open-loop system, then
  the following weightings V and W can be used:
                   -1
   (a)   V = (I-G*K) *G, W = I - to enforce closed-loop stability;
                           -1
   (b)   V = I,  W = (I-G*K) *G - to enforce closed-loop stability;
                   -1              -1
   (c)   V = (I-G*K) *G, W = (I-G*K)  - to enforce closed-loop
         stability and performance.

  G has the state space representation (A,B,C,D).
  If K is unstable, only the ALPHA-stable part of K is reduced.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the original controller as follows:
          = 'C':  continuous-time controller;
          = 'D':  discrete-time controller.

  JOBC    CHARACTER*1
          Specifies the choice of frequency-weighted controllability
          Grammian as follows:
          = 'S': choice corresponding to standard Enns' method [1];
          = 'E': choice corresponding to the stability enhanced
                 modified Enns' method of [2].

  JOBO    CHARACTER*1
          Specifies the choice of frequency-weighted observability
          Grammian as follows:
          = 'S': choice corresponding to standard Enns' method [1];
          = 'E': choice corresponding to the stability enhanced
                 modified combination method of [2].

  JOBMR   CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root B&T method;
          = 'F':  use the balancing-free square-root B&T method;
          = 'S':  use the square-root SPA method;
          = 'P':  use the balancing-free square-root SPA method.

  WEIGHT  CHARACTER*1
          Specifies the type of frequency-weighting, as follows:
          = 'N':  no weightings are used (V = I, W = I);
          = 'O':  stability enforcing left (output) weighting
                            -1
                  V = (I-G*K) *G is used (W = I);
          = 'I':  stability enforcing right (input) weighting
                            -1
                  W = (I-G*K) *G is used (V = I);
          = 'P':  stability and performance enforcing weightings
                            -1                -1
                  V = (I-G*K) *G ,  W = (I-G*K)  are used.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplets (A,B,C) and (Ac,Bc,Cc) as
          follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting order NCR is fixed;
          = 'A':  the resulting order NCR is automatically
                  determined on basis of the given tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the open-loop system state-space
          representation, i.e., the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NC      (input) INTEGER
          The order of the controller state-space representation,
          i.e., the order of the matrix AC.  NC >= 0.

  NCR     (input/output) INTEGER
          On entry with ORDSEL = 'F', NCR is the desired order of
          the resulting reduced order controller.  0 <= NCR <= NC.
          On exit, if INFO = 0, NCR is the order of the resulting
          reduced order controller. For a controller with NCU
          ALPHA-unstable eigenvalues and NCS ALPHA-stable
          eigenvalues (NCU+NCS = NC), NCR is set as follows:
          if ORDSEL = 'F', NCR is equal to
          NCU+MIN(MAX(0,NCR-NCU),NCMIN), where NCR is the desired
          order on entry, NCMIN is the number of frequency-weighted
          Hankel singular values greater than NCS*EPS*S1, EPS is the
          machine precision (see LAPACK Library Routine DLAMCH) and
          S1 is the largest Hankel singular value (computed in
          HSVC(1)); NCR can be further reduced to ensure
          HSVC(NCR-NCU) > HSVC(NCR+1-NCU);
          if ORDSEL = 'A', NCR is the sum of NCU and the number of
          Hankel singular values greater than MAX(TOL1,NCS*EPS*S1).

  ALPHA   (input) DOUBLE PRECISION
          Specifies the ALPHA-stability boundary for the eigenvalues
          of the state dynamics matrix AC. For a continuous-time
          controller (DICO = 'C'), ALPHA <= 0 is the boundary value
          for the real parts of eigenvalues; for a discrete-time
          controller (DICO = 'D'), 0 <= ALPHA <= 1 represents the
          boundary value for the moduli of eigenvalues.
          The ALPHA-stability domain does not include the boundary.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A of the open-loop
          system.
          On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-N
          part of this array contains the scaled state dynamics
          matrix of the open-loop system.
          If EQUIL = 'N', this array is unchanged on exit.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix B of the open-loop system.
          On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-M
          part of this array contains the scaled input/state matrix
          of the open-loop system.
          If EQUIL = 'N', this array is unchanged on exit.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C of the open-loop system.
          On exit, if INFO = 0 and EQUIL = 'S', the leading P-by-N
          part of this array contains the scaled state/output matrix
          of the open-loop system.
          If EQUIL = 'N', this array is unchanged on exit.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          input/output matrix D of the open-loop system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  AC      (input/output) DOUBLE PRECISION array, dimension (LDAC,NC)
          On entry, the leading NC-by-NC part of this array must
          contain the state dynamics matrix Ac of the original
          controller.
          On exit, if INFO = 0, the leading NCR-by-NCR part of this
          array contains the state dynamics matrix Acr of the
          reduced controller. The resulting Ac has a
          block-diagonal form with two blocks.
          For a system with NCU ALPHA-unstable eigenvalues and
          NCS ALPHA-stable eigenvalues (NCU+NCS = NC), the leading
          NCU-by-NCU block contains the unreduced part of Ac
          corresponding to the ALPHA-unstable eigenvalues.
          The trailing (NCR+NCS-NC)-by-(NCR+NCS-NC) block contains
          the reduced part of Ac corresponding to ALPHA-stable
          eigenvalues.

  LDAC    INTEGER
          The leading dimension of array AC.  LDAC >= MAX(1,NC).

  BC      (input/output) DOUBLE PRECISION array, dimension (LDBC,P)
          On entry, the leading NC-by-P part of this array must
          contain the input/state matrix Bc of the original
          controller.
          On exit, if INFO = 0, the leading NCR-by-P part of this
          array contains the input/state matrix Bcr of the reduced
          controller.

  LDBC    INTEGER
          The leading dimension of array BC.  LDBC >= MAX(1,NC).

  CC      (input/output) DOUBLE PRECISION array, dimension (LDCC,NC)
          On entry, the leading M-by-NC part of this array must
          contain the state/output matrix Cc of the original
          controller.
          On exit, if INFO = 0, the leading M-by-NCR part of this
          array contains the state/output matrix Ccr of the reduced
          controller.

  LDCC    INTEGER
          The leading dimension of array CC.  LDCC >= MAX(1,M).

  DC      (input/output) DOUBLE PRECISION array, dimension (LDDC,P)
          On entry, the leading M-by-P part of this array must
          contain the input/output matrix Dc of the original
          controller.
          On exit, if INFO = 0, the leading M-by-P part of this
          array contains the input/output matrix Dcr of the reduced
          controller.

  LDDC    INTEGER
          The leading dimension of array DC.  LDDC >= MAX(1,M).

  NCS     (output) INTEGER
          The dimension of the ALPHA-stable part of the controller.

  HSVC    (output) DOUBLE PRECISION array, dimension (NC)
          If INFO = 0, the leading NCS elements of this array
          contain the frequency-weighted Hankel singular values,
          ordered decreasingly, of the ALPHA-stable part of the
          controller.
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of the reduced controller.
          For model reduction, the recommended value is
          TOL1 = c*S1, where c is a constant in the
          interval [0.00001,0.001], and S1 is the largest
          frequency-weighted Hankel singular value of the
          ALPHA-stable part of the original controller
          (computed in HSVC(1)).
          If TOL1 <= 0 on entry, the used default value is
          TOL1 = NCS*EPS*S1, where NCS is the number of
          ALPHA-stable eigenvalues of Ac and EPS is the machine
          precision (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the ALPHA-stable part of the given
          controller. The recommended value is TOL2 = NCS*EPS*S1.
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension MAX(1,LIWRK1,LIWRK2)
          LIWRK1 = 0,       if JOBMR  = 'B';
          LIWRK1 = NC,      if JOBMR  = 'F';
          LIWRK1 = 2*NC,    if JOBMR  = 'S' or 'P';
          LIWRK2 = 0,       if WEIGHT = 'N';
          LIWRK2 = 2*(M+P), if WEIGHT = 'O', 'I', or 'P'.
          On exit, if INFO = 0, IWORK(1) contains NCMIN, the order
          of the computed minimal realization of the stable part of
          the controller.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 2*NC*NC + MAX( 1, LFREQ, LSQRED ),
          where
          LFREQ = (N+NC)*(N+NC+2*M+2*P)+
                  MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4))
                                   if WEIGHT = 'I' or 'O' or 'P';
          LFREQ  = NC*(MAX(M,P)+5) if WEIGHT = 'N' and EQUIL = 'N';
          LFREQ  = MAX(N,NC*(MAX(M,P)+5)) if WEIGHT = 'N' and
                                             EQUIL  = 'S';
          LSQRED = MAX( 1, 2*NC*NC+5*NC );
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NCR is greater
                than NSMIN, the sum of the order of the
                ALPHA-unstable part and the order of a minimal
                realization of the ALPHA-stable part of the given
                controller; in this case, the resulting NCR is set
                equal to NSMIN;
          = 2:  with ORDSEL = 'F', the selected order NCR
                corresponds to repeated singular values for the
                ALPHA-stable part of the controller, which are
                neither all included nor all excluded from the
                reduced model; in this case, the resulting NCR is
                automatically decreased to exclude all repeated
                singular values;
          = 3:  with ORDSEL = 'F', the selected order NCR is less
                than the order of the ALPHA-unstable part of the
                given controller. In this case NCR is set equal to
                the order of the ALPHA-unstable part.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the closed-loop system is not well-posed;
                its feedthrough matrix is (numerically) singular;
          = 2:  the computation of the real Schur form of the
                closed-loop state matrix failed;
          = 3:  the closed-loop state matrix is not stable;
          = 4:  the solution of a symmetric eigenproblem failed;
          = 5:  the computation of the ordered real Schur form of Ac
                failed;
          = 6:  the separation of the ALPHA-stable/unstable
                diagonal blocks failed because of very close
                eigenvalues;
          = 7:  the computation of Hankel singular values failed.
Method 
  Let K be the transfer-function matrix of the original linear
  controller

       d[xc(t)] = Ac*xc(t) + Bc*y(t)
       u(t)     = Cc*xc(t) + Dc*y(t),                      (1)

  where d[xc(t)] is dxc(t)/dt for a continuous-time system and
  xc(t+1) for a discrete-time system. The subroutine SB16AD
  determines the matrices of a reduced order controller

       d[z(t)] = Acr*z(t) + Bcr*y(t)
       u(t)    = Ccr*z(t) + Dcr*y(t),                      (2)

  such that the corresponding transfer-function matrix Kr minimizes
  the norm of the frequency-weighted error

          V*(K-Kr)*W,                                      (3)

  where V and W are special stable transfer-function matrices
  chosen to enforce stability and/or performance of the closed-loop
  system [3] (see description of the parameter WEIGHT).

  The following procedure is used to reduce K in conjunction
  with the frequency-weighted balancing approach of [2]
  (see also [3]):

  1) Decompose additively K, of order NC, as

       K = K1 + K2,

     such that K1 has only ALPHA-stable poles and K2, of order NCU,
     has only ALPHA-unstable poles.

  2) Compute for K1 a B&T or SPA frequency-weighted approximation
     K1r of order NCR-NCU using the frequency-weighted balancing
     approach of [1] in conjunction with accuracy enhancing
     techniques specified by the parameter JOBMR.

  3) Assemble the reduced model Kr as

        Kr = K1r + K2.

  For the reduction of the ALPHA-stable part, several accuracy
  enhancing techniques can be employed (see [2] for details).

  If JOBMR = 'B', the square-root B&T method of [1] is used.

  If JOBMR = 'F', the balancing-free square-root version of the
  B&T method [1] is used.

  If JOBMR = 'S', the square-root version of the SPA method [2,3]
  is used.

  If JOBMR = 'P', the balancing-free square-root version of the
  SPA method [2,3] is used.

  For each of these methods, two left and right truncation matrices
  are determined using the Cholesky factors of an input
  frequency-weighted controllability Grammian P and an output
  frequency-weighted observability Grammian Q.
  P and Q are determined as the leading NC-by-NC diagonal blocks
  of the controllability Grammian of K*W and of the
  observability Grammian of V*K. Special techniques developed in [2]
  are used to compute the Cholesky factors of P and Q directly
  (see also SLICOT Library routine SB16AY).
  The frequency-weighted Hankel singular values HSVC(1), ....,
  HSVC(NC) are computed as the square roots of the eigenvalues
  of the product P*Q.
References 
  [1] Enns, D.
      Model reduction with balanced realizations: An error bound
      and a frequency weighted generalization.
      Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984.

  [2] Varga, A. and Anderson, B.D.O.
      Square-root balancing-free methods for frequency-weighted
      balancing related model reduction.
      (report in preparation)

  [3] Anderson, B.D.O and Liu, Y.
      Controller reduction: concepts and approaches.
      IEEE Trans. Autom. Control, Vol. 34, pp. 802-812, 1989.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root
  techniques.
Further Comments 
  None
Example

Program Text 

*     SB16AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX, NCMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20,
     $                   NCMAX = 20 )
      INTEGER          MPMAX, NNCMAX
      PARAMETER        ( MPMAX  = MMAX + PMAX, NNCMAX = NMAX + NCMAX )
      INTEGER          LDA, LDB, LDC, LDD, LDAC, LDBC, LDCC, LDDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDAC = NCMAX, LDBC = NCMAX,
     $                   LDCC = PMAX, LDDC = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAX( NCMAX, MPMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*NCMAX*NCMAX +
     $                            NNCMAX*( NNCMAX + 2*MPMAX ) +
     $                            MAX( NNCMAX*( NNCMAX +
     $                                 MAX( NNCMAX, MMAX, PMAX ) + 7 ),
     $                                 MPMAX*( MPMAX + 4 ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA, TOL1, TOL2
      INTEGER          I, INFO, IWARN, J, M, N, NCR, NCS, NC, P
      CHARACTER*1      DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), HSVC(NMAX),
     $                 AC(LDAC,NCMAX), BC(LDBC,PMAX), CC(LDCC,NMAX),
     $                 DC(LDDC,PMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB16AD
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NC, NCR, ALPHA, TOL1, TOL2, DICO,
     $                      JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF( P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               IF( NC.LT.0 .OR. NC.GT.NCMAX ) THEN
                  WRITE ( NOUT, FMT = 99986 ) NC
               ELSE
                  IF( NC.GT.0 ) THEN
                     READ ( NIN, FMT = * )
     $                 ( ( AC(I,J), J = 1,NC ), I = 1,NC )
                     READ ( NIN, FMT = * )
     $                 ( ( BC(I,J), J = 1,P ), I = 1, NC )
                     READ ( NIN, FMT = * )
     $                 ( ( CC(I,J), J = 1,NC ), I = 1,M )
                  END IF
                  READ ( NIN, FMT = * )
     $                 ( ( DC(I,J), J = 1,P ), I = 1,M )
               END IF
*              Find a reduced ssr for (AC,BC,CC,DC).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99984 ) IWARN
                  WRITE ( NOUT, FMT = 99997 ) NCR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSVC(J), J = 1, NCS )
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( AC(I,J), J = 1,NCR )
   20             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( BC(I,J), J = 1,P )
   40             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( CC(I,J), J = 1,NCR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( DC(I,J), J = 1,P )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB16AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB16AD = ',I2)
99997 FORMAT (/' The order of reduced controller = ',I2)
99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced controller input/state matrix Bc is ')
99992 FORMAT (/' The reduced controller state/output matrix Cc is ')
99991 FORMAT (/' The reduced controller input/output matrix Dc is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable',
     $         ' part are')
99986 FORMAT (/' NC is out of range.',/' NC = ',I5)
99984 FORMAT (' IWARN on exit from SB16AD = ',I2)
      END
Program Data 
 SB16AD EXAMPLE PROGRAM DATA (Continuous system)
  3  1  1   3  2   0.0  0.1E0  0.0    C  S  S  F   I  N   F 
  -1.  0.   4.
   0.  2.   0.
   0.  0.  -3.
   1.
   1.
   1.
   1.  1.   1.
   0. 
  -26.4000    6.4023    4.3868
   32.0000         0         0
         0    8.0000         0
    -16
     0
     0
    9.2994    1.1624    0.1090
     0
Program Results 
 SB16AD EXAMPLE PROGRAM RESULTS


 The order of reduced controller =  2

 The Hankel singular values of weighted ALPHA-stable part are
   3.8253   0.2005

 The reduced controller state dynamics matrix Ac is 
   9.1900   0.0000
   0.0000 -34.5297

 The reduced controller input/state matrix Bc is 
 -11.9593
  86.3137

 The reduced controller state/output matrix Cc is 
   2.8955  -1.3566

 The reduced controller input/output matrix Dc is 
   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB16AY.html000077500000000000000000000272641201767322700161240ustar00rootroot00000000000000 SB16AY - SLICOT Library Routine Documentation

SB16AY

Cholesky factors of the frequency-weighted controllability and observability Grammians for controller reduction

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute for given state-space representations (A,B,C,D) and
  (Ac,Bc,Cc,Dc) of the transfer-function matrices of the
  open-loop system G and feedback controller K, respectively,
  the Cholesky factors of the frequency-weighted
  controllability and observability Grammians corresponding
  to a frequency-weighted model reduction problem.
  The controller must stabilize the closed-loop system.
  The state matrix Ac must be in a block-diagonal real Schur form
  Ac = diag(Ac1,Ac2), where Ac1 contains the unstable eigenvalues
  of Ac and Ac2 contains the stable eigenvalues of Ac.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the systems as follows:
          = 'C':  G and K are continuous-time systems;
          = 'D':  G and K are discrete-time systems.

  JOBC    CHARACTER*1
          Specifies the choice of frequency-weighted controllability
          Grammian as follows:
          = 'S': choice corresponding to standard Enns' method [1];
          = 'E': choice corresponding to the stability enhanced
                 modified Enns' method of [2].

  JOBO    CHARACTER*1
          Specifies the choice of frequency-weighted observability
          Grammian as follows:
          = 'S': choice corresponding to standard Enns' method [1];
          = 'E': choice corresponding to the stability enhanced
                 modified combination method of [2].

  WEIGHT  CHARACTER*1
          Specifies the type of frequency-weighting, as follows:
          = 'N':  no weightings are used (V = I, W = I);
          = 'O':  stability enforcing left (output) weighting
                            -1
                  V = (I-G*K) *G is used (W = I);
          = 'I':  stability enforcing right (input) weighting
                            -1
                  W = (I-G*K) *G is used (V = I);
          = 'P':  stability and performance enforcing weightings
                            -1                -1
                  V = (I-G*K) *G ,  W = (I-G*K)  are used.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the open-loop system state-space
          representation, i.e., the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NC      (input) INTEGER
          The order of the controller state-space representation,
          i.e., the order of the matrix AC.  NC >= 0.

  NCS     (input) INTEGER
          The dimension of the stable part of the controller, i.e.,
          the order of matrix Ac2.  NC >= NCS >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the system with the transfer-function
          matrix G.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          input/output matrix D of the open-loop system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  AC      (input) DOUBLE PRECISION array, dimension (LDAC,NC)
          The leading NC-by-NC part of this array must contain
          the state dynamics matrix Ac of the controller in a
          block diagonal real Schur form Ac = diag(Ac1,Ac2), where
          Ac1 is (NC-NCS)-by-(NC-NCS) and contains the unstable
          eigenvalues of Ac, and Ac2 is NCS-by-NCS and contains
          the stable eigenvalues of Ac.

  LDAC    INTEGER
          The leading dimension of array AC.  LDAC >= MAX(1,NC).

  BC      (input) DOUBLE PRECISION array, dimension (LDBC,P)
          The leading NC-by-P part of this array must contain
          the input/state matrix Bc of the controller.

  LDBC    INTEGER
          The leading dimension of array BC.  LDBC >= MAX(1,NC).

  CC      (input) DOUBLE PRECISION array, dimension (LDCC,NC)
          The leading M-by-NC part of this array must contain
          the state/output matrix Cc of the controller.

  LDCC    INTEGER
          The leading dimension of array CC.  LDCC >= MAX(1,M).

  DC      (input) DOUBLE PRECISION array, dimension (LDDC,P)
          The leading M-by-P part of this array must contain
          the input/output matrix Dc of the controller.

  LDDC    INTEGER
          The leading dimension of array DC.  LDDC >= MAX(1,M).

  SCALEC  (output) DOUBLE PRECISION
          Scaling factor for the controllability Grammian.
          See METHOD.

  SCALEO  (output) DOUBLE PRECISION
          Scaling factor for the observability Grammian. See METHOD.

  S       (output) DOUBLE PRECISION array, dimension (LDS,NCS)
          The leading NCS-by-NCS upper triangular part of this array
          contains the Cholesky factor S of the frequency-weighted
          controllability Grammian P = S*S'. See METHOD.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,NCS).

  R       (output) DOUBLE PRECISION array, dimension (LDR,NCS)
          The leading NCS-by-NCS upper triangular part of this array
          contains the Cholesky factor R of the frequency-weighted
          observability Grammian Q = R'*R. See METHOD.

  LDR     INTEGER
          The leading dimension of array R.  LDR >= MAX(1,NCS).
Workspace 
  IWORK   INTEGER array, dimension MAX(LIWRK)
          LIWRK = 0,       if WEIGHT = 'N';
          LIWRK = 2(M+P),  if WEIGHT = 'O', 'I', or 'P'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, LFREQ ),
          where
          LFREQ = (N+NC)*(N+NC+2*M+2*P)+
                  MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4))
                                   if WEIGHT = 'I' or 'O' or 'P';
          LFREQ  = NCS*(MAX(M,P)+5) if WEIGHT = 'N'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the closed-loop system is not well-posed;
                its feedthrough matrix is (numerically) singular;
          = 2:  the computation of the real Schur form of the
                closed-loop state matrix failed;
          = 3:  the closed-loop state matrix is not stable;
          = 4:  the solution of a symmetric eigenproblem failed;
          = 5:  the NCS-by-NCS trailing part Ac2 of the state
                matrix Ac is not stable or not in a real Schur form.
Method 
  If JOBC = 'S', the controllability Grammian P is determined as
  follows:

  - if WEIGHT = 'O' or 'N', P satisfies for a continuous-time
    controller the Lyapunov equation

         Ac2*P + P*Ac2' +  scalec^2*Bc*Bc' = 0

    and for a discrete-time controller

         Ac2*P*Ac2' - P +  scalec^2*Bc*Bc' = 0;

  - if WEIGHT = 'I' or 'P', let Pi be the solution of the
    continuous-time Lyapunov equation

         Ai*Pi + Pi*Ai' +  scalec^2*Bi*Bi' = 0

    or of the discrete-time Lyapunov equation

         Ai*Pi*Ai' - Pi +  scalec^2*Bi*Bi' = 0,

    where Ai and Bi are the state and input matrices of a special
    state-space realization of the input frequency weight (see [2]);
    P results as the trailing NCS-by-NCS part of Pi partitioned as

        Pi = ( *  * ).
             ( *  P )

  If JOBC = 'E', a modified controllability Grammian P1 >= P is
  determined to guarantee stability for a modified Enns' method [2].

  If JOBO = 'S', the observability Grammian Q is determined as
  follows:

  - if WEIGHT = 'I' or 'N', Q satisfies for a continuous-time
    controller the Lyapunov equation

         Ac2'*Q + Q*Ac2 +  scaleo^2*Cc'*Cc = 0

    and for a discrete-time controller

         Ac2'*Q*Ac2 - Q +  scaleo^2*Cc'*Cc = 0;

  - if WEIGHT = 'O' or 'P', let Qo be the solution of the
    continuous-time Lyapunov equation

         Ao'*Qo + Qo*Ao +  scaleo^2*Co'*Co = 0

    or of the discrete-time Lyapunov equation

         Ao'*Qo*Ao - Qo +  scaleo^2*Co'*Co = 0,

    where Ao and Co are the state and output matrices of a
    special state-space realization of the output frequency weight
    (see [2]); if WEIGHT = 'O', Q results as the leading NCS-by-NCS
    part of Qo partitioned as

        Qo = ( Q  * )
             ( *  * )

    while if WEIGHT = 'P', Q results as the trailing NCS-by-NCS
    part of Qo partitioned as

        Qo = ( *  * ).
             ( *  Q )

  If JOBO = 'E', a modified observability Grammian Q1 >= Q is
  determined to guarantee stability for a modified Enns' method [2].

  The routine computes directly the Cholesky factors S and R
  such that P = S*S' and Q = R'*R according to formulas
  developed in [2].
References 
  [1] Enns, D.
      Model reduction with balanced realizations: An error bound
      and a frequency weighted generalization.
      Proc. CDC, Las Vegas, pp. 127-132, 1984.

  [2] Varga, A. and Anderson, B.D.O.
      Frequency-weighted balancing related controller reduction.
      Proceedings of the 15th IFAC World Congress, July 21-26, 2002,
      Barcelona, Spain, Vol.15, Part 1, 2002-07-21.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SB16BD.html000077500000000000000000000513261201767322700160740ustar00rootroot00000000000000 SB16BD - SLICOT Library Routine Documentation

SB16BD

Coprime factorization based state feedback controller reduction

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, for a given open-loop model (A,B,C,D), and for
  given state feedback gain F and full observer gain G,
  such that A+B*F and A+G*C are stable, a reduced order
  controller model (Ac,Bc,Cc,Dc) using a coprime factorization
  based controller reduction approach. For reduction,
  either the square-root or the balancing-free square-root
  versions of the Balance & Truncate (B&T) or Singular Perturbation
  Approximation (SPA) model reduction methods are used in
  conjunction with stable coprime factorization techniques.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the open-loop system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears
          in the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.

  JOBMR   CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root B&T method;
          = 'F':  use the balancing-free square-root B&T method;
          = 'S':  use the square-root SPA method;
          = 'P':  use the balancing-free square-root SPA method.

  JOBCF   CHARACTER*1
          Specifies whether left or right coprime factorization is
          to be used as follows:
          = 'L':  use left coprime factorization;
          = 'R':  use right coprime factorization.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to perform a
          preliminary equilibration before performing
          order reduction as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting controller order NCR is fixed;
          = 'A':  the resulting controller order NCR is
                  automatically determined on basis of the given
                  tolerance TOL1.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the open-loop state-space representation,
          i.e., the order of the matrix A.  N >= 0.
          N also represents the order of the original state-feedback
          controller.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NCR     (input/output) INTEGER
          On entry with ORDSEL = 'F', NCR is the desired order of
          the resulting reduced order controller.  0 <= NCR <= N.
          On exit, if INFO = 0, NCR is the order of the resulting
          reduced order controller. NCR is set as follows:
          if ORDSEL = 'F', NCR is equal to MIN(NCR,NMIN), where NCR
          is the desired order on entry, and NMIN is the order of a
          minimal realization of an extended system Ge (see METHOD);
          NMIN is determined as the number of
          Hankel singular values greater than N*EPS*HNORM(Ge),
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the
          extended system (computed in HSV(1));
          if ORDSEL = 'A', NCR is equal to the number of Hankel
          singular values greater than MAX(TOL1,N*EPS*HNORM(Ge)).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, if INFO = 0, the leading NCR-by-NCR part of this
          array contains the state dynamics matrix Ac of the reduced
          controller.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must
          contain the original input/state matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must
          contain the original state/output matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          If JOBD = 'D', the leading P-by-M part of this
          array must contain the system direct input/output
          transmission matrix D.
          The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P), if JOBD = 'D';
          LDD >= 1,        if JOBD = 'Z'.

  F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
          On entry, the leading M-by-N part of this array must
          contain a stabilizing state feedback matrix.
          On exit, if INFO = 0, the leading M-by-NCR part of this
          array contains the state/output matrix Cc of the reduced
          controller.

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,P)
          On entry, the leading N-by-P part of this array must
          contain a stabilizing observer gain matrix.
          On exit, if INFO = 0, the leading NCR-by-P part of this
          array contains the input/state matrix Bc of the reduced
          controller.

  LDG     INTEGER
          The leading dimension of array G.  LDG >= MAX(1,N).

  DC      (output) DOUBLE PRECISION array, dimension (LDDC,P)
          If INFO = 0, the leading M-by-P part of this array
          contains the input/output matrix Dc of the reduced
          controller.

  LDDC    INTEGER
          The leading dimension of array DC.  LDDC >= MAX(1,M).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, it contains the N Hankel singular values
          of the extended system ordered decreasingly (see METHOD).
Tolerances 
  TOL1    DOUBLE PRECISION
          If ORDSEL = 'A', TOL1 contains the tolerance for
          determining the order of the reduced extended system.
          For model reduction, the recommended value is
          TOL1 = c*HNORM(Ge), where c is a constant in the
          interval [0.00001,0.001], and HNORM(Ge) is the
          Hankel norm of the extended system (computed in HSV(1)).
          The value TOL1 = N*EPS*HNORM(Ge) is used by default if
          TOL1 <= 0 on entry, where EPS is the machine precision
          (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL1 is ignored.

  TOL2    DOUBLE PRECISION
          The tolerance for determining the order of a minimal
          realization of the coprime factorization controller
          (see METHOD). The recommended value is
          TOL2 = N*EPS*HNORM(Ge) (see METHOD).
          This value is used by default if TOL2 <= 0 on entry.
          If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK = 0,         if ORDSEL = 'F' and NCR = N.
                                              Otherwise,
          LIWORK = MAX(PM,M), if JOBCF = 'L',
          LIWORK = MAX(PM,P), if JOBCF = 'R', where
          PM = 0,             if JOBMR = 'B',
          PM = N,             if JOBMR = 'F',
          PM = MAX(1,2*N),    if JOBMR = 'S' or 'P'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= P*N, if ORDSEL = 'F' and NCR = N. Otherwise,
          LDWORK >= (N+M)*(M+P) + MAX(LWR,4*M), if JOBCF = 'L',
          LDWORK >= (N+P)*(M+P) + MAX(LWR,4*P), if JOBCF = 'R',
          where LWR = MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2).
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NCR is
                greater than the order of a minimal
                realization of the controller.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the reduction of A+G*C to a real Schur form
                failed;
          = 2:  the matrix A+G*C is not stable (if DICO = 'C'),
                or not convergent (if DICO = 'D');
          = 3:  the computation of Hankel singular values failed;
          = 4:  the reduction of A+B*F to a real Schur form
                failed;
          = 5:  the matrix A+B*F is not stable (if DICO = 'C'),
                or not convergent (if DICO = 'D').
Method 
  Let be the linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                             (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system, and let Go(d) be the open-loop
  transfer-function matrix
                        -1
       Go(d) = C*(d*I-A) *B + D .

  Let F and G be the state feedback and observer gain matrices,
  respectively, chosen so that A+B*F and A+G*C are stable matrices.
  The controller has a transfer-function matrix K(d) given by
                                     -1
       K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G .

  The closed-loop transfer-function matrix is given by
                                  -1
       Gcl(d) = Go(d)(I+K(d)Go(d)) .

  K(d) can be expressed as a left coprime factorization (LCF),
                       -1
       K(d) = M_left(d) *N_left(d) ,

  or as a right coprime factorization (RCF),
                                   -1
       K(d) = N_right(d)*M_right(d) ,

  where M_left(d), N_left(d), N_right(d), and M_right(d) are
  stable transfer-function matrices.

  The subroutine SB16BD determines the matrices of a reduced
  controller

       d[z(t)] = Ac*z(t) + Bc*y(t)
       u(t)    = Cc*z(t) + Dc*y(t),                           (2)

  with the transfer-function matrix Kr as follows:

  (1) If JOBCF = 'L', the extended system
      Ge(d)  = [ N_left(d) M_left(d) ] is reduced to
      Ger(d) = [ N_leftr(d) M_leftr(d) ] by using either the
      B&T or SPA methods. The reduced order controller Kr(d)
      is computed as
                        -1
      Kr(d) = M_leftr(d) *N_leftr(d) ;

  (2) If JOBCF = 'R', the extended system
      Ge(d) = [ N_right(d) ] is reduced to
              [ M_right(d) ]
      Ger(d) = [ N_rightr(d) ] by using either the
               [ M_rightr(d) ]
      B&T or SPA methods. The reduced order controller Kr(d)
      is computed as
                                      -1
      Kr(d) = N_rightr(d)* M_rightr(d) .

  If ORDSEL = 'A', the order of the controller is determined by
  computing the number of Hankel singular values greater than
  the given tolerance TOL1. The Hankel singular values are
  the square roots of the eigenvalues of the product of
  the controllability and observability Grammians of the
  extended system Ge.

  If JOBMR = 'B', the square-root B&T method of [1] is used.

  If JOBMR = 'F', the balancing-free square-root version of the
  B&T method [1] is used.

  If JOBMR = 'S', the square-root version of the SPA method [2,3]
  is used.

  If JOBMR = 'P', the balancing-free square-root version of the
  SPA method [2,3] is used.
References 
  [1] Tombs, M.S. and Postlethwaite, I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [2] Varga, A.
      Efficient minimal realization procedure based on balancing.
      Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
      A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2,
      pp. 42-46, 1991.

  [3] Varga, A.
      Coprime factors model reduction method based on square-root
      balancing-free techniques.
      System Analysis, Modelling and Simulation, Vol. 11,
      pp. 303-311, 1993.

  [4] Liu, Y., Anderson, B.D.O. and Ly, O.L.
      Coprime factorization controller reduction with Bezout
      identity induced frequency weighting.
      Automatica, vol. 26, pp. 233-249, 1990.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     SB16BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD, LDDC, LDF, LDG
      PARAMETER        ( LDA = NMAX, LDB  = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDDC = MMAX, LDF = MMAX, LDG = NMAX
     $                 )
      INTEGER          LDWORK, LIWORK, MAXMP, MPMAX
      PARAMETER        ( LIWORK = 2*NMAX, MAXMP = MAX( MMAX, PMAX ),
     $                   MPMAX  = MMAX + PMAX )
      PARAMETER        ( LDWORK = ( NMAX + MAXMP )*MPMAX +
     $                            MAX ( NMAX*( 2*NMAX +
     $                                         MAX( NMAX, MPMAX ) + 5 )
     $                                      + ( NMAX*( NMAX + 1 ) )/2,
     $                                  4*MAXMP ) )
      CHARACTER        DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL
      INTEGER          I, INFO, IWARN, J, M, N, NCR, P
      DOUBLE PRECISION TOL1, TOL2
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DC(LDDC,PMAX), DWORK(LDWORK),
     $                 F(LDF,NMAX), G(LDG,PMAX), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB16BD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NCR, TOL1, TOL2,
     $                      DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M )
               READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,P ), I = 1,N )
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NCR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N )
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCR )
   20             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,P )
   40             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,NCR )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( DC(I,J), J = 1,M )
   80             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB16BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB16BD = ',I2)
99997 FORMAT (' The order of reduced controller = ',I2)
99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced controller input/state matrix Bc is ')
99992 FORMAT (/' The reduced controller state/output matrix Cc is ')
99991 FORMAT (/' The reduced controller input/output matrix Dc is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The Hankel singular values of extended system are:')
      END
Program Data 
 SB16BD EXAMPLE PROGRAM DATA (Continuous system)
  8  1  1   4   0.1E0  0.0    C  D  F  L  S   F
         0    1.0000         0         0         0         0         0        0
         0         0         0         0         0         0         0        0
         0         0   -0.0150    0.7650         0         0         0        0
         0         0   -0.7650   -0.0150         0         0         0        0
         0         0         0         0   -0.0280    1.4100         0        0
         0         0         0         0   -1.4100   -0.0280         0        0
         0         0         0         0         0         0   -0.0400    1.850
         0         0         0         0         0         0   -1.8500   -0.040
    0.0260
   -0.2510
    0.0330
   -0.8860
   -4.0170
    0.1450
    3.6040
    0.2800
  -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026
  0.0
4.4721e-002  6.6105e-001  4.6986e-003  3.6014e-001  1.0325e-001 -3.7541e-002 -4.2685e-002  3.2873e-002
  4.1089e-001
  8.6846e-002
  3.8523e-004
 -3.6194e-003
 -8.8037e-003
  8.4205e-003
  1.2349e-003
  4.2632e-003
Program Results 
 SB16BD EXAMPLE PROGRAM RESULTS

 The order of reduced controller =  4

 The Hankel singular values of extended system are:
   4.9078   4.8745   3.8455   3.7811   1.2289   1.1785   0.5176   0.1148

 The reduced controller state dynamics matrix Ac is 
   0.5946  -0.7336   0.1914  -0.3368
   0.5960  -0.0184  -0.1088   0.0207
   1.2253   0.2043   0.1009  -1.4948
  -0.0330  -0.0243   1.3440   0.0035

 The reduced controller input/state matrix Bc is 
   0.0015
  -0.0202
   0.0159
  -0.0544

 The reduced controller state/output matrix Cc is 
   0.3534   0.0274   0.0337  -0.0320

 The reduced controller input/output matrix Dc is 
   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB16CD.html000077500000000000000000000501501201767322700160670ustar00rootroot00000000000000 SB16CD - SLICOT Library Routine Documentation

SB16CD

Coprime factorization based frequency-weighted state feedback controller reduction

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, for a given open-loop model (A,B,C,D), and for
  given state feedback gain F and full observer gain G,
  such that A+B*F and A+G*C are stable, a reduced order
  controller model (Ac,Bc,Cc) using a coprime factorization
  based controller reduction approach. For reduction of
  coprime factors, a stability enforcing frequency-weighted
  model reduction is performed using either the square-root or
  the balancing-free square-root versions of the Balance & Truncate
  (B&T) model reduction method.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the open-loop system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears
          in the given state space model, as follows:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.

  JOBMR   CHARACTER*1
          Specifies the model reduction approach to be used
          as follows:
          = 'B':  use the square-root B&T method;
          = 'F':  use the balancing-free square-root B&T method.

  JOBCF   CHARACTER*1
          Specifies whether left or right coprime factorization
          of the controller is to be used as follows:
          = 'L':  use left coprime factorization;
          = 'R':  use right coprime factorization.

  ORDSEL  CHARACTER*1
          Specifies the order selection method as follows:
          = 'F':  the resulting controller order NCR is fixed;
          = 'A':  the resulting controller order NCR is
                  automatically determined on basis of the given
                  tolerance TOL.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.
          N also represents the order of the original state-feedback
          controller.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NCR     (input/output) INTEGER
          On entry with ORDSEL = 'F', NCR is the desired order of
          the resulting reduced order controller.  0 <= NCR <= N.
          On exit, if INFO = 0, NCR is the order of the resulting
          reduced order controller. NCR is set as follows:
          if ORDSEL = 'F', NCR is equal to MIN(NCR,NCRMIN), where
          NCR is the desired order on entry, and NCRMIN is the
          number of Hankel-singular values greater than N*EPS*S1,
          where EPS is the machine precision (see LAPACK Library
          Routine DLAMCH) and S1 is the largest Hankel singular
          value (computed in HSV(1)); NCR can be further reduced
          to ensure HSV(NCR) > HSV(NCR+1);
          if ORDSEL = 'A', NCR is equal to the number of Hankel
          singular values greater than MAX(TOL,N*EPS*S1).

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, if INFO = 0, the leading NCR-by-NCR part of this
          array contains the state dynamics matrix Ac of the reduced
          controller.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the open-loop system input/state matrix B.
          On exit, this array is overwritten with a NCR-by-M
          B&T approximation of the matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the open-loop system state/output matrix C.
          On exit, this array is overwritten with a P-by-NCR
          B&T approximation of the matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, if JOBD = 'D', the leading P-by-M part of this
          array must contain the system direct input/output
          transmission matrix D.
          The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P), if JOBD = 'D';
          LDD >= 1,        if JOBD = 'Z'.

  F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
          On entry, the leading M-by-N part of this array must
          contain a stabilizing state feedback matrix.
          On exit, if INFO = 0, the leading M-by-NCR part of this
          array contains the output/state matrix Cc of the reduced
          controller.

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).

  G       (input/output) DOUBLE PRECISION array, dimension (LDG,P)
          On entry, the leading N-by-P part of this array must
          contain a stabilizing observer gain matrix.
          On exit, if INFO = 0, the leading NCR-by-P part of this
          array contains the input/state matrix Bc of the reduced
          controller.

  LDG     INTEGER
          The leading dimension of array G.  LDG >= MAX(1,N).

  HSV     (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, HSV contains the N frequency-weighted
          Hankel singular values ordered decreasingly (see METHOD).
Tolerances 
  TOL     DOUBLE PRECISION
          If ORDSEL = 'A', TOL contains the tolerance for
          determining the order of reduced controller.
          The recommended value is TOL = c*S1, where c is a constant
          in the interval [0.00001,0.001], and S1 is the largest
          Hankel singular value (computed in HSV(1)).
          The value TOL = N*EPS*S1 is used by default if
          TOL <= 0 on entry, where EPS is the machine precision
          (see LAPACK Library Routine DLAMCH).
          If ORDSEL = 'F', the value of TOL is ignored.
Workspace 
  IWORK   INTEGER array, dimension LIWORK, where
          LIWORK = 0,   if JOBMR = 'B';
          LIWORK = N,   if JOBMR = 'F'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX(M,P),
                                 N*(N + MAX(N,MP) + MIN(N,MP) + 6)),
          where     MP = M, if JOBCF = 'L';
                    MP = P, if JOBCF = 'R'.
          For optimum performance LDWORK should be larger.
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  with ORDSEL = 'F', the selected order NCR is
                greater than the order of a minimal realization
                of the controller;
          = 2:  with ORDSEL = 'F', the selected order NCR
                corresponds to repeated singular values, which are
                neither all included nor all excluded from the
                reduced controller. In this case, the resulting NCR
                is set automatically to the largest value such that
                HSV(NCR) > HSV(NCR+1).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  eigenvalue computation failure;
          = 2:  the matrix A+G*C is not stable;
          = 3:  the matrix A+B*F is not stable;
          = 4:  the Lyapunov equation for computing the
                observability Grammian is (nearly) singular;
          = 5:  the Lyapunov equation for computing the
                controllability Grammian is (nearly) singular;
          = 6:  the computation of Hankel singular values failed.
Method 
  Let be the linear system

       d[x(t)] = Ax(t) + Bu(t)
       y(t)    = Cx(t) + Du(t),                             (1)

  where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
  for a discrete-time system, and let Go(d) be the open-loop
  transfer-function matrix
                       -1
       Go(d) = C*(d*I-A) *B + D .

  Let F and G be the state feedback and observer gain matrices,
  respectively, chosen such that A+BF and A+GC are stable matrices.
  The controller has a transfer-function matrix K(d) given by
                                    -1
       K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G .

  The closed-loop transfer function matrix is given by
                                 -1
       Gcl(d) = Go(d)(I+K(d)Go(d)) .

  K(d) can be expressed as a left coprime factorization (LCF)
                      -1
       K(d) = M_left(d) *N_left(d),

  or as a right coprime factorization (RCF)
                                  -1
       K(d) = N_right(d)*M_right(d) ,

  where M_left(d), N_left(d), N_right(d), and M_right(d) are
  stable transfer-function matrices.

  The subroutine SB16CD determines the matrices of a reduced
  controller

       d[z(t)] = Ac*z(t) + Bc*y(t)
       u(t)    = Cc*z(t),                                   (2)

  with the transfer-function matrix Kr, using the following
  stability enforcing approach proposed in [1]:

  (1) If JOBCF = 'L', the frequency-weighted approximation problem
      is solved

      min||[M_left(d)-M_leftr(d)  N_left(d)-N_leftr(d)][-Y(d)]|| ,
                                                       [ X(d)]
      where
                           -1
            G(d) = Y(d)*X(d)

      is a RCF of the open-loop system transfer-function matrix.
      The B&T model reduction technique is used in conjunction
      with the method proposed in [1].

  (2) If JOBCF = 'R', the frequency-weighted approximation problem
      is solved

      min || [ -U(d) V(d) ] [ N_right(d)-N_rightr(d) ] || ,
                            [ M_right(d)-M_rightr(d) ]
      where
                      -1
            G(d) = V(d) *U(d)

      is a LCF of the open-loop system transfer-function matrix.
      The B&T model reduction technique is used in conjunction
      with the method proposed in [1].

  If ORDSEL = 'A', the order of the controller is determined by
  computing the number of Hankel singular values greater than
  the given tolerance TOL. The Hankel singular values are
  the square roots of the eigenvalues of the product of
  two frequency-weighted Grammians P and Q, defined as follows.

  If JOBCF = 'L', then P is the controllability Grammian of a system
  of the form (A+BF,B,*,*), and Q is the observability Grammian of a
  system of the form (A+GC,*,F,*). This choice corresponds to an
  input frequency-weighted order reduction of left coprime
  factors [1].

  If JOBCF = 'R', then P is the controllability Grammian of a system
  of the form (A+BF,G,*,*), and Q is the observability Grammian of a
  system of the form (A+GC,*,C,*). This choice corresponds to an
  output frequency-weighted order reduction of right coprime
  factors [1].

  For the computation of truncation matrices, the B&T approach
  is used in conjunction with accuracy enhancing techniques.
  If JOBMR = 'B', the square-root B&T method of [2,4] is used.
  If JOBMR = 'F', the balancing-free square-root version of the
  B&T method [3,4] is used.
References 
  [1] Liu, Y., Anderson, B.D.O. and Ly, O.L.
      Coprime factorization controller reduction with Bezout
      identity induced frequency weighting.
      Automatica, vol. 26, pp. 233-249, 1990.

  [2] Tombs, M.S. and Postlethwaite I.
      Truncated balanced realization of stable, non-minimal
      state-space systems.
      Int. J. Control, Vol. 46, pp. 1319-1330, 1987.

  [3] Varga, A.
      Efficient minimal realization procedure based on balancing.
      Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
      A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2,
      pp. 42-46, 1991.

  [4] Varga, A.
      Coprime factors model reduction method based on square-root
      balancing-free techniques.
      System Analysis, Modelling and Simulation, Vol. 11,
      pp. 303-311, 1993.
Numerical Aspects 
  The implemented methods rely on accuracy enhancing square-root or
  balancing-free square-root techniques.
                                      3
  The algorithms require less than 30N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     SB16CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD, LDDC, LDF, LDG
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                 LDD = PMAX, LDDC = MMAX, LDF = MMAX, LDG = NMAX )
      INTEGER          LDWORK, LIWORK, MPMAX
      PARAMETER        ( LIWORK = 2*NMAX, MPMAX = MAX( MMAX, PMAX ) )
      PARAMETER        ( LDWORK = 2*NMAX*NMAX +
     $                            MAX( 2*NMAX*NMAX + 5*NMAX,
     $                                 NMAX*( NMAX + MAX( NMAX, MPMAX )
     $                                      + MIN( NMAX, MPMAX ) + 6 ) )
     $                 )
      CHARACTER        DICO, JOBCF, JOBD, JOBMR, ORDSEL
      INTEGER          I, INFO, IWARN, J, M, N, NCR, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK),
     $                 F(LDF,NMAX), G(LDG,PMAX), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB16CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NCR, TOL,
     $                      DICO, JOBD, JOBMR, JOBCF, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M )
               READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,P ), I = 1,N )
*              Find a reduced ssr for (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NCR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N )
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCR )
   20             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,P )
   40             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,NCR )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB16CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB16CD = ',I2)
99997 FORMAT (' The order of reduced controller = ',I2)
99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced controller input/state matrix Bc is ')
99992 FORMAT (/' The reduced controller state/output matrix Cc is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The frequency-weighted Hankel singular values are:')
      END
Program Data 
 SB16CD EXAMPLE PROGRAM DATA (Continuous system)
  8  1  1   2   0.1E0  C  D  F  R  F
         0    1.0000         0         0         0         0         0        0
         0         0         0         0         0         0         0        0
         0         0   -0.0150    0.7650         0         0         0        0
         0         0   -0.7650   -0.0150         0         0         0        0
         0         0         0         0   -0.0280    1.4100         0        0
         0         0         0         0   -1.4100   -0.0280         0        0
         0         0         0         0         0         0   -0.0400    1.850
         0         0         0         0         0         0   -1.8500   -0.040
    0.0260
   -0.2510
    0.0330
   -0.8860
   -4.0170
    0.1450
    3.6040
    0.2800
  -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026
  0.0
4.472135954999638e-002    6.610515358414598e-001    4.698598960657579e-003  3.601363251422058e-001    1.032530880771415e-001   -3.754055214487997e-002  -4.268536964759344e-002    3.287284547842979e-002
    4.108939884667451e-001
    8.684600000000012e-002
    3.852317308197148e-004
   -3.619366874815911e-003
   -8.803722876359955e-003
    8.420521094001852e-003
    1.234944428038507e-003
    4.263205617645322e-003
Program Results 
 SB16CD EXAMPLE PROGRAM RESULTS

 The order of reduced controller =  2

 The frequency-weighted Hankel singular values are:
   3.3073   0.7274   0.1124   0.0784   0.0242   0.0182   0.0101   0.0094

 The reduced controller state dynamics matrix Ac is 
  -0.4334   0.4884
  -0.1950  -0.1093

 The reduced controller input/state matrix Bc is 
  -0.4231
  -0.1785

 The reduced controller state/output matrix Cc is 
  -0.0326  -0.2307

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SB16CY.html000077500000000000000000000173151201767322700161220ustar00rootroot00000000000000 SB16CY - SLICOT Library Routine Documentation

SB16CY

Cholesky factors of controllability and observability Grammians of coprime factors of a state-feedback controller

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute, for a given open-loop model (A,B,C,0), and for
  given state feedback gain F and full observer gain G,
  such that A+B*F and A+G*C are stable, the Cholesky factors
  Su and Ru of a controllability Grammian P = Su*Su' and of
  an observability Grammian Q = Ru'*Ru corresponding to a
  frequency-weighted model reduction of the left or right coprime
  factors of the state-feedback controller.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the open-loop system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  JOBCF   CHARACTER*1
          Specifies whether a left or right coprime factorization
          of the state-feedback controller is to be used as follows:
          = 'L':  use a left coprime factorization;
          = 'R':  use a right coprime factorization.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the open-loop state-space representation,
          i.e., the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the open-loop system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input/state matrix B of the open-loop system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          state/output matrix C of the open-loop system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  F       (input) DOUBLE PRECISION array, dimension (LDF,N)
          The leading M-by-N part of this array must contain a
          stabilizing state feedback matrix.

  LDF     INTEGER
          The leading dimension of array F.  LDF >= MAX(1,M).

  G       (input) DOUBLE PRECISION array, dimension (LDG,P)
          The leading N-by-P part of this array must contain a
          stabilizing observer gain matrix.

  LDG     INTEGER
          The leading dimension of array G.  LDG >= MAX(1,N).

  SCALEC  (output) DOUBLE PRECISION
          Scaling factor for the controllability Grammian.
          See METHOD.

  SCALEO  (output) DOUBLE PRECISION
          Scaling factor for the observability Grammian.
          See METHOD.

  S       (output) DOUBLE PRECISION array, dimension (LDS,N)
          The leading N-by-N upper triangular part of this array
          contains the Cholesky factor Su of frequency-weighted
          cotrollability Grammian P = Su*Su'. See METHOD.

  LDS     INTEGER
          The leading dimension of the array S.  LDS >= MAX(1,N).

  R       (output) DOUBLE PRECISION array, dimension (LDR,N)
          The leading N-by-N upper triangular part of this array
          contains the Cholesky factor Ru of the frequency-weighted
          observability Grammian Q = Ru'*Ru. See METHOD.

  LDR     INTEGER
          The leading dimension of the array R.  LDR >= MAX(1,N).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)),
                                                    if JOBCF = 'L';
          LDWORK >= MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)),
                                                    if JOBCF = 'R'.
          For optimum performance LDWORK should be larger.
          An upper bound for both cases is
          LDWORK >= MAX(1, N*(N + MAX(N,M,P) + 7)).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  eigenvalue computation failure;
          = 2:  the matrix A+G*C is not stable;
          = 3:  the matrix A+B*F is not stable;
          = 4:  the Lyapunov equation for computing the
                observability Grammian is (nearly) singular;
          = 5:  the Lyapunov equation for computing the
                controllability Grammian is (nearly) singular.
Method 
  In accordance with the type of the coprime factorization
  of the controller (left or right), the Cholesky factors Su and Ru
  of the frequency-weighted controllability Grammian P = Su*Su' and
  of the frequency-weighted observability Grammian Q = Ru'*Ru are
  computed by solving appropriate Lyapunov or Stein equations [1].

  If JOBCF = 'L' and DICO = 'C', P and Q are computed as the
  solutions of the following Lyapunov equations:

         (A+B*F)*P + P*(A+B*F)' +  scalec^2*B*B' = 0,  (1)

         (A+G*C)'*Q + Q*(A+G*C) +  scaleo^2*F'*F = 0.  (2)

  If JOBCF = 'L' and DICO = 'D', P and Q are computed as the
  solutions of the following Stein equations:

         (A+B*F)*P*(A+B*F)' - P +  scalec^2*B*B' = 0,  (3)

         (A+G*C)'*Q*(A+G*C) - Q +  scaleo^2*F'*F = 0.  (4)

  If JOBCF = 'R' and DICO = 'C', P and Q are computed as the
  solutions of the following Lyapunov equations:

         (A+B*F)*P + P*(A+B*F)' +  scalec^2*G*G' = 0,  (5)

         (A+G*C)'*Q + Q*(A+G*C) +  scaleo^2*C'*C = 0.  (6)

  If JOBCF = 'R' and DICO = 'D', P and Q are computed as the
  solutions of the following Stein equations:

         (A+B*F)*P*(A+B*F)' - P +  scalec^2*G*G' = 0,  (7)

         (A+G*C)'*Q*(A+G*C) - Q +  scaleo^2*C'*C = 0.  (8)
References 
  [1] Liu, Y., Anderson, B.D.O. and Ly, O.L.
      Coprime factorization controller reduction with Bezout
      identity induced frequency weighting.
      Automatica, vol. 26, pp. 233-249, 1990.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SG02AD.html000077500000000000000000000616331201767322700160750ustar00rootroot00000000000000 SG02AD - SLICOT Library Routine Documentation

SG02AD

Solution of continuous- or discrete-time algebraic Riccati equations for descriptor systems

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the continuous-time algebraic Riccati
  equation
                                -1
     Q + A'XE + E'XA - (L+E'XB)R  (L+E'XB)' = 0 ,              (1)

  or the discrete-time algebraic Riccati equation
                                     -1
     E'XE = A'XA - (L+A'XB)(R + B'XB)  (L+A'XB)' + Q ,         (2)

  where A, E, B, Q, R, and L are N-by-N, N-by-N, N-by-M, N-by-N,
  M-by-M and N-by-M matrices, respectively, such that Q = C'C,
  R = D'D and L = C'D; X is an N-by-N symmetric matrix.
  The routine also returns the computed values of the closed-loop
  spectrum of the system, i.e., the stable eigenvalues
  lambda(1),...,lambda(N) of the pencil (A - BF,E), where F is
  the optimal gain matrix,
          -1
     F = R  (L+E'XB)' ,        for (1),

  and
                 -1
     F = (R+B'XB)  (L+A'XB)' , for (2).
                           -1
  Optionally, matrix G = BR  B' may be given instead of B and R.
  Other options include the case with Q and/or R given in a
  factored form, Q = C'C, R = D'D, and with L a zero matrix.

  The routine uses the method of deflating subspaces, based on
  reordering the eigenvalues in a generalized Schur matrix pair.

  It is assumed that E is nonsingular, but this condition is not
  checked. Note that the definition (1) of the continuous-time
  algebraic Riccati equation, and the formula for the corresponding
  optimal gain matrix, require R to be nonsingular, but the
  associated linear quadratic optimal problem could have a unique
  solution even when matrix R is singular, under mild assumptions
  (see METHOD). The routine SG02AD works accordingly in this case.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of Riccati equation to be solved as
          follows:
          = 'C':  Equation (1), continuous-time case;
          = 'D':  Equation (2), discrete-time case.

  JOBB    CHARACTER*1
          Specifies whether or not the matrix G is given, instead
          of the matrices B and R, as follows:
          = 'B':  B and R are given;
          = 'G':  G is given.

  FACT    CHARACTER*1
          Specifies whether or not the matrices Q and/or R (if
          JOBB = 'B') are factored, as follows:
          = 'N':  Not factored, Q and R are given;
          = 'C':  C is given, and Q = C'C;
          = 'D':  D is given, and R = D'D;
          = 'B':  Both factors C and D are given, Q = C'C, R = D'D.

  UPLO    CHARACTER*1
          If JOBB = 'G', or FACT = 'N', specifies which triangle of
          the matrices G, or Q and R, is stored, as follows:
          = 'U':  Upper triangle is stored;
          = 'L':  Lower triangle is stored.

  JOBL    CHARACTER*1
          Specifies whether or not the matrix L is zero, as follows:
          = 'Z':  L is zero;
          = 'N':  L is nonzero.
          JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed.
          SLICOT Library routine SB02MT should be called just before
          SG02AD, for obtaining the results when JOBB = 'G' and
          JOBL = 'N'.

  SCAL    CHARACTER*1
          If JOBB = 'B', specifies whether or not a scaling strategy
          should be used to scale Q, R, and L, as follows:
          = 'G':  General scaling should be used;
          = 'N':  No scaling should be used.
          SCAL is not used if JOBB = 'G'.

  SORT    CHARACTER*1
          Specifies which eigenvalues should be obtained in the top
          of the generalized Schur form, as follows:
          = 'S':  Stable   eigenvalues come first;
          = 'U':  Unstable eigenvalues come first.

  ACC     CHARACTER*1
          Specifies whether or not iterative refinement should be
          used to solve the system of algebraic equations giving
          the solution matrix X, as follows:
          = 'R':  Use iterative refinement;
          = 'N':  Do not use iterative refinement.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e., the order of the
          matrices A, E, Q, and X, and the number of rows of the
          matrices B and L.  N >= 0.

  M       (input) INTEGER
          The number of system inputs. If JOBB = 'B', M is the
          order of the matrix R, and the number of columns of the
          matrix B.  M >= 0.
          M is not used if JOBB = 'G'.

  P       (input) INTEGER
          The number of system outputs. If FACT = 'C' or 'D' or 'B',
          P is the number of rows of the matrices C and/or D.
          P >= 0.
          Otherwise, P is not used.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the descriptor system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N part of this array must contain the
          matrix E of the descriptor system.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,*)
          If JOBB = 'B', the leading N-by-M part of this array must
          contain the input matrix B of the system.
          If JOBB = 'G', the leading N-by-N upper triangular part
          (if UPLO = 'U') or lower triangular part (if UPLO = 'L')
          of this array must contain the upper triangular part or
          lower triangular part, respectively, of the matrix
                -1
          G = BR  B'. The stricly lower triangular part (if
          UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
          If FACT = 'N' or 'D', the leading N-by-N upper triangular
          part (if UPLO = 'U') or lower triangular part (if UPLO =
          'L') of this array must contain the upper triangular part
          or lower triangular part, respectively, of the symmetric
          state weighting matrix Q. The stricly lower triangular
          part (if UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.
          If FACT = 'C' or 'B', the leading P-by-N part of this
          array must contain the output matrix C of the system.
          If JOBB = 'B' and SCAL = 'G', then Q is modified
          internally, but is restored on exit.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= MAX(1,N) if FACT = 'N' or 'D';
          LDQ >= MAX(1,P) if FACT = 'C' or 'B'.

  R       (input) DOUBLE PRECISION array, dimension (LDR,*)
          If FACT = 'N' or 'C', the leading M-by-M upper triangular
          part (if UPLO = 'U') or lower triangular part (if UPLO =
          'L') of this array must contain the upper triangular part
          or lower triangular part, respectively, of the symmetric
          input weighting matrix R. The stricly lower triangular
          part (if UPLO = 'U') or stricly upper triangular part (if
          UPLO = 'L') is not referenced.
          If FACT = 'D' or 'B', the leading P-by-M part of this
          array must contain the direct transmission matrix D of the
          system.
          If JOBB = 'B' and SCAL = 'G', then R is modified
          internally, but is restored on exit.
          If JOBB = 'G', this array is not referenced.

  LDR     INTEGER
          The leading dimension of array R.
          LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C';
          LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B';
          LDR >= 1        if JOBB = 'G'.

  L       (input) DOUBLE PRECISION array, dimension (LDL,*)
          If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of
          this array must contain the cross weighting matrix L.
          If JOBB = 'B' and SCAL = 'G', then L is modified
          internally, but is restored on exit.
          If JOBL = 'Z' or JOBB = 'G', this array is not referenced.

  LDL     INTEGER
          The leading dimension of array L.
          LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B';
          LDL >= 1        if JOBL = 'Z' or  JOBB = 'G'.

  RCONDU  (output) DOUBLE PRECISION
          If N > 0 and INFO = 0 or INFO = 7, an estimate of the
          reciprocal of the condition number (in the 1-norm) of
          the N-th order system of algebraic equations from which
          the solution matrix X is obtained.

  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
          If INFO = 0, the leading N-by-N part of this array
          contains the solution matrix X of the problem.

  LDX     INTEGER
          The leading dimension of array X.  LDX >= MAX(1,N).

  ALFAR   (output) DOUBLE PRECISION array, dimension (2*N)
  ALFAI   (output) DOUBLE PRECISION array, dimension (2*N)
  BETA    (output) DOUBLE PRECISION array, dimension (2*N)
          The generalized eigenvalues of the 2N-by-2N matrix pair,
          ordered as specified by SORT (if INFO = 0, or INFO >= 5).
          For instance, if SORT = 'S', the leading N elements of
          these arrays contain the closed-loop spectrum of the
          system. Specifically,
             lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for
          k = 1,2,...,N.

  S       (output) DOUBLE PRECISION array, dimension (LDS,*)
          The leading 2N-by-2N part of this array contains the
          ordered real Schur form S of the first matrix in the
          reduced matrix pencil associated to the optimal problem,
          corresponding to the scaled Q, R, and L, if JOBB = 'B'
          and SCAL = 'G'. That is,

                 (S   S  )
                 ( 11  12)
             S = (       ),
                 (0   S  )
                 (     22)

          where S  , S   and S   are N-by-N matrices.
                 11   12      22
          Array S must have 2*N+M columns if JOBB = 'B', and 2*N
          columns, otherwise.

  LDS     INTEGER
          The leading dimension of array S.
          LDS >= MAX(1,2*N+M) if JOBB = 'B';
          LDS >= MAX(1,2*N)   if JOBB = 'G'.

  T       (output) DOUBLE PRECISION array, dimension (LDT,2*N)
          The leading 2N-by-2N part of this array contains the
          ordered upper triangular form T of the second matrix in
          the reduced matrix pencil associated to the optimal
          problem, corresponding to the scaled Q, R, and L, if
          JOBB = 'B' and SCAL = 'G'. That is,

                 (T   T  )
                 ( 11  12)
             T = (       ),
                 (0   T  )
                 (     22)

          where T  , T   and T   are N-by-N matrices.
                 11   12      22

  LDT     INTEGER
          The leading dimension of array T.
          LDT >= MAX(1,2*N+M) if JOBB = 'B';
          LDT >= MAX(1,2*N)   if JOBB = 'G'.

  U       (output) DOUBLE PRECISION array, dimension (LDU,2*N)
          The leading 2N-by-2N part of this array contains the right
          transformation matrix U which reduces the 2N-by-2N matrix
          pencil to the ordered generalized real Schur form (S,T).
          That is,

                 (U   U  )
                 ( 11  12)
             U = (       ),
                 (U   U  )
                 ( 21  22)

          where U  , U  , U   and U   are N-by-N matrices.
                 11   12   21      22
          If JOBB = 'B' and SCAL = 'G', then U corresponds to the
          scaled pencil. If a basis for the stable deflating
          subspace of the original problem is needed, then the
          submatrix U   must be multiplied by the scaling factor
                     21
          contained in DWORK(4).

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,2*N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used to test for near singularity of
          the original matrix pencil, specifically of the triangular
          M-by-M factor obtained during the reduction process. If
          the user sets TOL > 0, then the given value of TOL is used
          as a lower bound for the reciprocal condition number of
          that matrix; a matrix whose estimated condition number is
          less than 1/TOL is considered to be nonsingular. If the
          user sets TOL <= 0, then a default tolerance, defined by
          TOLDEF = EPS, is used instead, where EPS is the machine
          precision (see LAPACK Library routine DLAMCH).
          This parameter is not referenced if JOBB = 'G'.
Workspace 
  IWORK   INTEGER array, dimension (LIWORK)
          LIWORK >= MAX(1,M,2*N) if JOBB = 'B';
          LIWORK >= MAX(1,2*N)   if JOBB = 'G'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the
          reciprocal of the condition number of the M-by-M bottom
          right lower triangular matrix obtained while compressing
          the matrix pencil of order 2N+M to obtain a pencil of
          order 2N. If ACC = 'R', and INFO = 0 or INFO = 7, DWORK(3)
          returns the reciprocal pivot growth factor (see SLICOT
          Library routine MB02PD) for the LU factorization of the
          coefficient matrix of the system of algebraic equations
          giving the solution matrix X; if DWORK(3) is much
          less than 1, then the computed X and RCONDU could be
          unreliable. If INFO = 0 or INFO = 7, DWORK(4) returns the
          scaling factor used to scale Q, R, and L. DWORK(4) is set
          to 1 if JOBB = 'G' or SCAL = 'N'.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(7*(2*N+1)+16,16*N),           if JOBB = 'G';
          LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'.
          For optimum performance LDWORK should be larger.

  BWORK   LOGICAL array, dimension (2*N)
Warning Indicator 
  IWARN   INTEGER
          = 0:  no warning;
          = 1:  the computed solution may be inaccurate due to poor
                scaling or eigenvalues too close to the boundary of
                the stability domain (the imaginary axis, if
                DICO = 'C', or the unit circle, if DICO = 'D').
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the computed extended matrix pencil is singular,
                possibly due to rounding errors;
          = 2:  if the QZ algorithm failed;
          = 3:  if reordering of the generalized eigenvalues failed;
          = 4:  if after reordering, roundoff changed values of
                some complex eigenvalues so that leading eigenvalues
                in the generalized Schur form no longer satisfy the
                stability condition; this could also be caused due
                to scaling;
          = 5:  if the computed dimension of the solution does not
                equal N;
          = 6:  if the spectrum is too close to the boundary of
                the stability domain;
          = 7:  if a singular matrix was encountered during the
                computation of the solution matrix X.
Method 
  The routine uses a variant of the method of deflating subspaces
  proposed by van Dooren [1]. See also [2], [3], [4].
  It is assumed that E is nonsingular, the triple (E,A,B) is
  strongly stabilizable and detectable (see [3]); if, in addition,

     -    [ Q   L ]
     R := [       ] >= 0 ,
          [ L'  R ]

  then the pencils

        discrete-time                   continuous-time

  |A   0   B|     |E   0   0|    |A   0   B|     |E   0   0|
  |Q  -E'  L| - z |0  -A'  0| ,  |Q   A'  L| - s |0  -E'  0| ,   (3)
  |L'  0   R|     |0  -B'  0|    |L'  B'  R|     |0   0   0|

  are dichotomic, i.e., they have no eigenvalues on the boundary of
  the stability domain. The above conditions are sufficient for
  regularity of these pencils. A necessary condition is that
  rank([ B'  L'  R']') = m.

  Under these assumptions the algebraic Riccati equation is known to
  have a unique non-negative definite solution.
  The first step in the method of deflating subspaces is to form the
  extended matrices in (3), of order 2N + M. Next, these pencils are
  compressed to a form of order 2N (see [1])

     lambda x A  - B .
               f    f

  This generalized eigenvalue problem is then solved using the QZ
  algorithm and the stable deflating subspace Ys is determined.
  If [Y1'|Y2']' is a basis for Ys, then the required solution is
                    -1
         X = Y2 x Y1  .
References 
  [1] Van Dooren, P.
      A Generalized Eigenvalue Approach for Solving Riccati
      Equations.
      SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981.

  [2] Arnold, III, W.F. and Laub, A.J.
      Generalized Eigenproblem Algorithms and Software for
      Algebraic Riccati Equations.
      Proc. IEEE, 72, 1746-1754, 1984.

  [3] Mehrmann, V.
      The Autonomous Linear Quadratic Control Problem. Theory and
      Numerical Solution.
      Lect. Notes in Control and Information Sciences, vol. 163,
      Springer-Verlag, Berlin, 1991.

  [4] Sima, V.
      Algorithms for Linear-Quadratic Optimization.
      Pure and Applied Mathematics: A Series of Monographs and
      Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996.
Numerical Aspects 
  This routine is particularly suited for systems where the matrix R
  is ill-conditioned, or even singular.
Further Comments 
  To obtain a stabilizing solution of the algebraic Riccati
  equations set SORT = 'S'.

  The routine can also compute the anti-stabilizing solutions of
  the algebraic Riccati equations, by specifying SORT = 'U'.
Example

Program Text 

*     SG02AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          NMAX2M, NMAX2, NMMAX
      PARAMETER        ( NMAX2M = 2*NMAX+MMAX, NMAX2 = 2*NMAX,
     $                   NMMAX  = MAX(NMAX,MMAX) )
      INTEGER          LDA, LDB, LDE, LDL, LDQ, LDR, LDS, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDE = NMAX, LDL = NMAX,
     $                   LDQ = MAX(NMAX,PMAX), LDR = MAX(MMAX,PMAX),
     $                   LDS = NMAX2M, LDT = NMAX2M, LDU = NMAX2,
     $                   LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX(MMAX,NMAX2) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX(14*NMAX+23,16*NMAX,2*NMAX+MMAX,
     $                                3*MMAX) )
      INTEGER          LBWORK
      PARAMETER        ( LBWORK = NMAX2 )
*     .. Local Scalars ..
      DOUBLE PRECISION RCONDU, TOL
      INTEGER          I, INFO, IWARN, J, M, N, P
      CHARACTER*1      ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO
      LOGICAL          LJOBB
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX),  ALFAI(NMAX2),  ALFAR(NMAX2),
     $                 B(LDB,NMMAX), BETA(NMAX2),   DWORK(LDWORK),
     $                 E(LDE,NMAX),  L(LDL,MMAX),   Q(LDQ,NMAX),
     $                 R(LDR,MMAX),  S(LDS,NMAX2M), T(LDT,NMAX2),
     $                 U(LDU,NMAX2), X(LDX,NMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LBWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SG02AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBB, FACT, UPLO, JOBL,
     $                      SCAL, SORT, ACC
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) M
         ELSE
            LJOBB = LSAME( JOBB, 'B' )
            IF ( LJOBB ) THEN
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
            END IF
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99993 ) P
            ELSE
               IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'D' ) ) THEN
                  READ ( NIN, FMT = * )
     $                                 ( ( Q(I,J), J = 1,N ), I = 1,N )
               ELSE
                  READ ( NIN, FMT = * )
     $                                 ( ( Q(I,J), J = 1,N ), I = 1,P )
               END IF
               IF ( LJOBB ) THEN
                  IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'C' ) ) THEN
                      READ ( NIN, FMT = * )
     $                                  ( ( R(I,J), J = 1,M ), I = 1,M )
                  ELSE
                      READ ( NIN, FMT = * )
     $                                  ( ( R(I,J), J = 1,M ), I = 1,P )
                  END IF
                  IF ( LSAME( JOBL, 'N' ) )
     $                READ ( NIN, FMT = * )
     $                                  ( ( L(I,J), J = 1,M ), I = 1,N )
               END IF
*              Find the solution matrix X.
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N )
   20             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SG02AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SG02AD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
99993 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 SG02AD EXAMPLE PROGRAM DATA
   2     1     3     0.0     C     B     B     U     Z     N     S     N
   0.0  1.0
   0.0  0.0
   1.0  0.0
   0.0  1.0
   0.0
   1.0
   1.0  0.0
   0.0  1.0
   0.0  0.0
   0.0
   0.0
   1.0
Program Results 
 SG02AD EXAMPLE PROGRAM RESULTS

 The solution matrix X is 
   1.7321   1.0000
   1.0000   1.7321

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SG03AD.html000077500000000000000000000450261201767322700160740ustar00rootroot00000000000000 SG03AD - SLICOT Library Routine Documentation

SG03AD

Solution of continuous- or discrete-time generalized Lyapunov equations and separation estimation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the generalized continuous-time Lyapunov
  equation

          T                T
     op(A)  X op(E) + op(E)  X op(A) = SCALE * Y,                (1)

  or the generalized discrete-time Lyapunov equation

          T                T
     op(A)  X op(A) - op(E)  X op(E) = SCALE * Y,                (2)

  where op(M) is either M or M**T for M = A, E and the right hand
  side Y is symmetric. A, E, Y, and the solution X are N-by-N
  matrices. SCALE is an output scale factor, set to avoid overflow
  in X.

  Estimates of the separation and the relative forward error norm
  are provided.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies which type of the equation is considered:
          = 'C':  Continuous-time equation (1);
          = 'D':  Discrete-time equation (2).

  JOB     CHARACTER*1
          Specifies if the solution is to be computed and if the
          separation is to be estimated:
          = 'X':  Compute the solution only;
          = 'S':  Estimate the separation only;
          = 'B':  Compute the solution and estimate the separation.

  FACT    CHARACTER*1
          Specifies whether the generalized real Schur
          factorization of the pencil A - lambda * E is supplied
          on entry or not:
          = 'N':  Factorization is not supplied;
          = 'F':  Factorization is supplied.

  TRANS   CHARACTER*1
          Specifies whether the transposed equation is to be solved
          or not:
          = 'N':  op(A) = A,    op(E) = E;
          = 'T':  op(A) = A**T, op(E) = E**T.

  UPLO    CHARACTER*1
          Specifies whether the lower or the upper triangle of the
          array X is needed on input:
          = 'L':  Only the lower triangle is needed on input;
          = 'U':  Only the upper triangle is needed on input.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, if FACT = 'F', then the leading N-by-N upper
          Hessenberg part of this array must contain the
          generalized Schur factor A_s of the matrix A (see
          definition (3) in section METHOD). A_s must be an upper
          quasitriangular matrix. The elements below the upper
          Hessenberg part of the array A are not referenced.
          If FACT = 'N', then the leading N-by-N part of this
          array must contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the generalized Schur factor A_s of the matrix A. (A_s is
          an upper quasitriangular matrix.)

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, if FACT = 'F', then the leading N-by-N upper
          triangular part of this array must contain the
          generalized Schur factor E_s of the matrix E (see
          definition (4) in section METHOD). The elements below the
          upper triangular part of the array E are not referenced.
          If FACT = 'N', then the leading N-by-N part of this
          array must contain the coefficient matrix E of the
          equation.
          On exit, the leading N-by-N part of this array contains
          the generalized Schur factor E_s of the matrix E. (E_s is
          an upper triangular matrix.)

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, if FACT = 'F', then the leading N-by-N part of
          this array must contain the orthogonal matrix Q from
          the generalized Schur factorization (see definitions (3)
          and (4) in section METHOD).
          If FACT = 'N', Q need not be set on entry.
          On exit, the leading N-by-N part of this array contains
          the orthogonal matrix Q from the generalized Schur
          factorization.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= MAX(1,N).

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          On entry, if FACT = 'F', then the leading N-by-N part of
          this array must contain the orthogonal matrix Z from
          the generalized Schur factorization (see definitions (3)
          and (4) in section METHOD).
          If FACT = 'N', Z need not be set on entry.
          On exit, the leading N-by-N part of this array contains
          the orthogonal matrix Z from the generalized Schur
          factorization.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= MAX(1,N).

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, if JOB = 'B' or 'X', then the leading N-by-N
          part of this array must contain the right hand side matrix
          Y of the equation. Either the lower or the upper
          triangular part of this array is needed (see mode
          parameter UPLO).
          If JOB = 'S', X is not referenced.
          On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then
          the leading N-by-N part of this array contains the
          solution matrix X of the equation.
          If JOB = 'S', X is not referenced.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in X.
          (0 < SCALE <= 1)

  SEP     (output) DOUBLE PRECISION
          If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then
          SEP contains an estimate of the separation of the
          Lyapunov operator.

  FERR    (output) DOUBLE PRECISION
          If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an
          estimated forward error bound for the solution X. If XTRUE
          is the true solution, FERR estimates the relative error
          in the computed solution, measured in the Frobenius norm:
          norm(X - XTRUE) / norm(XTRUE)

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
  BETA    (output) DOUBLE PRECISION array, dimension (N)
          If FACT = 'N' and INFO = 0, 3, or 4, then
          (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the
          eigenvalues of the matrix pencil A - lambda * E.
          If FACT = 'F', ALPHAR, ALPHAI, and BETA are not
          referenced.
Workspace 
  IWORK   INTEGER array, dimension (N**2)
          IWORK is not referenced if JOB = 'X'.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK. The following table
          contains the minimal work space requirements depending
          on the choice of JOB and FACT.

                 JOB        FACT    |  LDWORK
                 -------------------+-------------------
                 'X'        'F'     |  MAX(1,N)
                 'X'        'N'     |  MAX(1,4*N)
                 'B', 'S'   'F'     |  MAX(1,2*N**2)
                 'B', 'S'   'N'     |  MAX(1,2*N**2,4*N)

          For optimum performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  FACT = 'F' and the matrix contained in the upper
                Hessenberg part of the array A is not in upper
                quasitriangular form;
          = 2:  FACT = 'N' and the pencil A - lambda * E cannot be
                reduced to generalized Schur form: LAPACK routine
                DGEGS has failed to converge;
          = 3:  DICO = 'D' and the pencil A - lambda * E has a
                pair of reciprocal eigenvalues. That is, lambda_i =
                1/lambda_j for some i and j, where lambda_i and
                lambda_j are eigenvalues of A - lambda * E. Hence,
                equation (2) is singular;  perturbed values were
                used to solve the equation (but the matrices A and
                E are unchanged);
          = 4:  DICO = 'C' and the pencil A - lambda * E has a
                degenerate pair of eigenvalues. That is, lambda_i =
                -lambda_j for some i and j, where lambda_i and
                lambda_j are eigenvalues of A - lambda * E. Hence,
                equation (1) is singular;  perturbed values were
                used to solve the equation (but the matrices A and
                E are unchanged).
Method 
  A straightforward generalization [3] of the method proposed by
  Bartels and Stewart [1] is utilized to solve (1) or (2).

  First the pencil A - lambda * E is reduced to real generalized
  Schur form A_s - lambda * E_s by means of orthogonal
  transformations (QZ-algorithm):

     A_s = Q**T * A * Z   (upper quasitriangular)                (3)

     E_s = Q**T * E * Z   (upper triangular).                    (4)

  If FACT = 'F', this step is omitted. Assuming SCALE = 1 and
  defining

           ( Z**T * Y * Z   :   TRANS = 'N'
     Y_s = <
           ( Q**T * Y * Q   :   TRANS = 'T'

           ( Q**T * X * Q    if TRANS = 'N'
     X_s = <                                                     (5)
           ( Z**T * X * Z    if TRANS = 'T'

  leads to the reduced Lyapunov equation

            T                      T
     op(A_s)  X_s op(E_s) + op(E_s)  X_s op(A_s) = Y_s,          (6)

  or
            T                      T
     op(A_s)  X_s op(A_s) - op(E_s)  X_s op(E_s) = Y_s,          (7)

  which are equivalent to (1) or (2), respectively. The solution X_s
  of (6) or (7) is computed via block back substitution (if TRANS =
  'N') or block forward substitution (if TRANS = 'T'), where the
  block order is at most 2. (See [1] and [3] for details.)
  Equation (5) yields the solution matrix X.

  For fast computation the estimates of the separation and the
  forward error are gained from (6) or (7) rather than (1) or
  (2), respectively. We consider (6) and (7) as special cases of the
  generalized Sylvester equation

     R * X * S + U * X * V = Y,                                  (8)

  whose separation is defined as follows

     sep = sep(R,S,U,V) =   min   || R * X * S + U * X * V || .
                         ||X|| = 1                           F
                              F

  Equation (8) is equivalent to the system of linear equations

     K * vec(X) = (kron(S**T,R) + kron(V**T,U)) * vec(X) = vec(Y),

  where kron is the Kronecker product of two matrices and vec
  is the mapping that stacks the columns of a matrix. If K is
  nonsingular then

     sep = 1 / ||K**(-1)|| .
                          2

  We estimate ||K**(-1)|| by a method devised by Higham [2]. Note
  that this method yields an estimation for the 1-norm but we use it
  as an approximation for the 2-norm. Estimates for the forward
  error norm are provided by

     FERR = 2 * EPS * ||A_s||  * ||E_s||  / sep
                             F          F

  in the continuous-time case (1) and

     FERR = EPS * ( ||A_s|| **2 + ||E_s|| **2 ) / sep
                           F             F

  in the discrete-time case (2).
  The reciprocal condition number, RCOND, of the Lyapunov equation
  can be estimated by FERR/EPS.
References 
  [1] Bartels, R.H., Stewart, G.W.
      Solution of the equation A X + X B = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Higham, N.J.
      FORTRAN codes for estimating the one-norm of a real or complex
      matrix, with applications to condition estimation.
      A.C.M. Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, 1988.

  [3] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Numerical Aspects 
  The number of flops required by the routine is given by the
  following table. Note that we count a single floating point
  arithmetic operation as one flop. c is an integer number of modest
  size (say 4 or 5).

                |  FACT = 'F'            FACT = 'N'
     -----------+------------------------------------------
     JOB = 'B'  |  (26+8*c)/3 * N**3     (224+8*c)/3 * N**3
     JOB = 'S'  |  8*c/3 * N**3          (198+8*c)/3 * N**3
     JOB = 'X'  |  26/3 * N**3           224/3 * N**3

  The algorithm is backward stable if the eigenvalues of the pencil
  A - lambda * E are real. Otherwise, linear systems of order at
  most 4 are involved into the computation. These systems are solved
  by Gauss elimination with complete pivoting. The loss of stability
  of the Gauss elimination with complete pivoting is rarely
  encountered in practice.

  The Lyapunov equation may be very ill-conditioned. In particular,
  if DICO = 'D' and the pencil A - lambda * E has a pair of almost
  reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost
  degenerate pair of eigenvalues, then the Lyapunov equation will be
  ill-conditioned. Perturbed values were used to solve the equation.
  Ill-conditioning can be detected by a very small value of the
  reciprocal condition number RCOND.
Further Comments 
  None
Example

Program Text 

*     SG03AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           NMAX
      PARAMETER         ( NMAX = 20 )
      INTEGER           LDA, LDE, LDQ, LDX, LDZ
      PARAMETER         ( LDA = NMAX, LDE = NMAX, LDQ = NMAX,
     $                    LDX = NMAX, LDZ = NMAX )
      INTEGER           LIWORK, LDWORK
      PARAMETER         ( LIWORK = NMAX**2,
     $                    LDWORK = MAX( 2*NMAX**2, 4*NMAX ) )
*     .. Local Scalars ..
      CHARACTER*1       DICO, FACT, JOB, TRANS, UPLO
      DOUBLE PRECISION  FERR, SCALE, SEP
      INTEGER           I, INFO, J, N
*     .. Local Arrays ..
      INTEGER           IWORK(LIWORK)
      DOUBLE PRECISION  A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX),
     $                  BETA(NMAX), DWORK(LDWORK), E(LDE,NMAX),
     $                  Q(LDQ,NMAX), X(LDX,NMAX), Z(LDZ,NMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          SG03AD
*     .. Intrinsic Functions ..
      INTRINSIC         MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, DICO, FACT, TRANS, UPLO
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME ( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N )
         END IF
         IF ( .NOT.LSAME ( JOB, 'S' ) )
     $      READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X and the scalar SEP.
         CALL 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 )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME ( JOB, 'B' ) .OR. LSAME ( JOB, 'S' ) ) THEN
               WRITE ( NOUT, FMT = 99997 ) SEP
               WRITE ( NOUT, FMT = 99996 ) FERR
            END IF
            IF ( LSAME ( JOB, 'B' ) .OR. LSAME ( JOB, 'X' ) ) THEN
               WRITE ( NOUT, FMT = 99995 ) SCALE
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N )
   20          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SG03AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SG03AD = ',I2)
99997 FORMAT (' SEP =   ',D8.2)
99996 FORMAT (' FERR =  ',D8.2)
99995 FORMAT (' SCALE = ',D8.2,//' The solution matrix X is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END
Program Data 
 SG03AD EXAMPLE PROGRAM DATA
  3       B       C       N       N       U
  3.0     1.0     1.0
  1.0     3.0     0.0
  1.0     0.0     2.0
  1.0     3.0     0.0
  3.0     2.0     1.0
  1.0     0.0     1.0
-64.0   -73.0   -28.0
  0.0   -70.0   -25.0
  0.0     0.0   -18.0
Program Results 
 SG03AD EXAMPLE PROGRAM RESULTS

 SEP =   0.29D+00
 FERR =  0.40D-13
 SCALE = 0.10D+01

 The solution matrix X is 
  -2.0000  -1.0000   0.0000
  -1.0000  -3.0000  -1.0000
   0.0000  -1.0000  -3.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SG03AX.html000077500000000000000000000114441201767322700161150ustar00rootroot00000000000000 SG03AX - SLICOT Library Routine Documentation

SG03AX

Solving a discrete-time generalized Lyapunov equation with matrix A quasi-triangular and matrix E upper triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the reduced generalized discrete-time
  Lyapunov equation

      T            T
     A  * X * A - E  * X * E  =  SCALE * Y                       (1)

  or

              T            T
     A * X * A  - E * X * E   =  SCALE * Y                       (2)

  where the right hand side Y is symmetric. A, E, Y, and the
  solution X are N-by-N matrices. The pencil A - lambda * E must be
  in generalized Schur form (A upper quasitriangular, E upper
  triangular). SCALE is an output scale factor, set to avoid
  overflow in X.
Specification 
      SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO )
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,*)
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies whether the transposed equation is to be solved
          or not:
          = 'N':  Solve equation (1);
          = 'T':  Solve equation (2).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the quasitriangular matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N upper triangular part of this array
          must contain the matrix E.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,N).

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, the leading N-by-N part of this array must
          contain the right hand side matrix Y of the equation. Only
          the upper triangular part of this matrix need be given.
          On exit, the leading N-by-N part of this array contains
          the solution matrix X of the equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in X.
          (0 < SCALE <= 1)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  equation is (almost) singular to working precision;
                perturbed values were used to solve the equation
                (but the matrices A and E are unchanged).
Method 
  The solution X of (1) or (2) is computed via block back
  substitution or block forward substitution, respectively. (See
  [1] and [2] for details.)
References 
  [1] Bartels, R.H., Stewart, G.W.
      Solution of the equation A X + X B = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Numerical Aspects 
  8/3 * N**3 flops are required by the routine. Note that we count a
  single floating point arithmetic operation as one flop.

  The algorithm is backward stable if the eigenvalues of the pencil
  A - lambda * E are real. Otherwise, linear systems of order at
  most 4 are involved into the computation. These systems are solved
  by Gauss elimination with complete pivoting. The loss of stability
  of the Gauss elimination with complete pivoting is rarely
  encountered in practice.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SG03AY.html000077500000000000000000000114501201767322700161130ustar00rootroot00000000000000 SG03AY - SLICOT Library Routine Documentation

SG03AY

Solving a continuous-time generalized Lyapunov equation with matrix A quasi-triangular and matrix E upper triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X either the reduced generalized continuous-time
  Lyapunov equation

      T            T
     A  * X * E + E  * X * A  =  SCALE * Y                       (1)

  or

              T            T
     A * X * E  + E * X * A   =  SCALE * Y                       (2)

  where the right hand side Y is symmetric. A, E, Y, and the
  solution X are N-by-N matrices. The pencil A - lambda * E must be
  in generalized Schur form (A upper quasitriangular, E upper
  triangular). SCALE is an output scale factor, set to avoid
  overflow in X.
Specification 
      SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO )
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,*)
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies whether the transposed equation is to be solved
          or not:
          = 'N':  Solve equation (1);
          = 'T':  Solve equation (2).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the quasitriangular matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N upper triangular part of this array
          must contain the matrix E.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,N).

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, the leading N-by-N part of this array must
          contain the right hand side matrix Y of the equation. Only
          the upper triangular part of this matrix need be given.
          On exit, the leading N-by-N part of this array contains
          the solution matrix X of the equation.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in X.
          (0 < SCALE <= 1)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  equation is (almost) singular to working precision;
                perturbed values were used to solve the equation
                (but the matrices A and E are unchanged).
Method 
  The solution X of (1) or (2) is computed via block back
  substitution or block forward substitution, respectively. (See
  [1] and [2] for details.)
References 
  [1] Bartels, R.H., Stewart, G.W.
      Solution of the equation A X + X B = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Numerical Aspects 
  8/3 * N**3 flops are required by the routine. Note that we count a
  single floating point arithmetic operation as one flop.

  The algorithm is backward stable if the eigenvalues of the pencil
  A - lambda * E are real. Otherwise, linear systems of order at
  most 4 are involved into the computation. These systems are solved
  by Gauss elimination with complete pivoting. The loss of stability
  of the Gauss elimination with complete pivoting is rarely
  encountered in practice.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SG03BD.html000077500000000000000000000472371201767322700161030ustar00rootroot00000000000000 SG03BD - SLICOT Library Routine Documentation

SG03BD

Solving (for Cholesky factor) generalized stable continuous- or discrete-time Lyapunov equations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Cholesky factor U of the matrix X,

              T
     X = op(U)  * op(U),

  which is the solution of either the generalized
  c-stable continuous-time Lyapunov equation

          T                    T
     op(A)  * X * op(E) + op(E)  * X * op(A)

              2        T
     = - SCALE  * op(B)  * op(B),                                (1)

  or the generalized d-stable discrete-time Lyapunov equation

          T                    T
     op(A)  * X * op(A) - op(E)  * X * op(E)

              2        T
     = - SCALE  * op(B)  * op(B),                                (2)

  without first finding X and without the need to form the matrix
  op(B)**T * op(B).

  op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N
  matrices, op(B) is an M-by-N matrix. The resulting matrix U is an
  N-by-N upper triangular matrix with non-negative entries on its
  main diagonal. SCALE is an output scale factor set to avoid
  overflow in U.

  In the continuous-time case (1) the pencil A - lambda * E must be
  c-stable (that is, all eigenvalues must have negative real parts).
  In the discrete-time case (2) the pencil A - lambda * E must be
  d-stable (that is, the moduli of all eigenvalues must be smaller
  than one).
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies which type of the equation is considered:
          = 'C':  Continuous-time equation (1);
          = 'D':  Discrete-time equation (2).

  FACT    CHARACTER*1
          Specifies whether the generalized real Schur
          factorization of the pencil A - lambda * E is supplied
          on entry or not:
          = 'N':  Factorization is not supplied;
          = 'F':  Factorization is supplied.

  TRANS   CHARACTER*1
          Specifies whether the transposed equation is to be solved
          or not:
          = 'N':  op(A) = A,    op(E) = E;
          = 'T':  op(A) = A**T, op(E) = E**T.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of rows in the matrix op(B).  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, if FACT = 'F', then the leading N-by-N upper
          Hessenberg part of this array must contain the
          generalized Schur factor A_s of the matrix A (see
          definition (3) in section METHOD). A_s must be an upper
          quasitriangular matrix. The elements below the upper
          Hessenberg part of the array A are not referenced.
          If FACT = 'N', then the leading N-by-N part of this
          array must contain the matrix A.
          On exit, the leading N-by-N part of this array contains
          the generalized Schur factor A_s of the matrix A. (A_s is
          an upper quasitriangular matrix.)

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, if FACT = 'F', then the leading N-by-N upper
          triangular part of this array must contain the
          generalized Schur factor E_s of the matrix E (see
          definition (4) in section METHOD). The elements below the
          upper triangular part of the array E are not referenced.
          If FACT = 'N', then the leading N-by-N part of this
          array must contain the coefficient matrix E of the
          equation.
          On exit, the leading N-by-N part of this array contains
          the generalized Schur factor E_s of the matrix E. (E_s is
          an upper triangular matrix.)

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,N).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          On entry, if FACT = 'F', then the leading N-by-N part of
          this array must contain the orthogonal matrix Q from
          the generalized Schur factorization (see definitions (3)
          and (4) in section METHOD).
          If FACT = 'N', Q need not be set on entry.
          On exit, the leading N-by-N part of this array contains
          the orthogonal matrix Q from the generalized Schur
          factorization.

  LDQ     INTEGER
          The leading dimension of the array Q.  LDQ >= MAX(1,N).

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          On entry, if FACT = 'F', then the leading N-by-N part of
          this array must contain the orthogonal matrix Z from
          the generalized Schur factorization (see definitions (3)
          and (4) in section METHOD).
          If FACT = 'N', Z need not be set on entry.
          On exit, the leading N-by-N part of this array contains
          the orthogonal matrix Z from the generalized Schur
          factorization.

  LDZ     INTEGER
          The leading dimension of the array Z.  LDZ >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N1)
          On entry, if TRANS = 'T', the leading N-by-M part of this
          array must contain the matrix B and N1 >= MAX(M,N).
          If TRANS = 'N', the leading M-by-N part of this array
          must contain the matrix B and N1 >= N.
          On exit, the leading N-by-N part of this array contains
          the Cholesky factor U of the solution matrix X of the
          problem, X = op(U)**T * op(U).
          If M = 0 and N > 0, then U is set to zero.

  LDB     INTEGER
          The leading dimension of the array B.
          If TRANS = 'T', LDB >= MAX(1,N).
          If TRANS = 'N', LDB >= MAX(1,M,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in U.
          0 < SCALE <= 1.

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
  BETA    (output) DOUBLE PRECISION array, dimension (N)
          If INFO = 0, 3, 5, 6, or 7, then
          (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the
          eigenvalues of the matrix pencil A - lambda * E.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= MAX(1,4*N,6*N-6),  if FACT = 'N';
          LDWORK >= MAX(1,2*N,6*N-6),  if FACT = 'F'.
          For good performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the pencil A - lambda * E is (nearly) singular;
                perturbed values were used to solve the equation
                (but the reduced (quasi)triangular matrices A and E
                are unchanged);
          = 2:  FACT = 'F' and the matrix contained in the upper
                Hessenberg part of the array A is not in upper
                quasitriangular form;
          = 3:  FACT = 'F' and there is a 2-by-2 block on the main
                diagonal of the pencil A_s - lambda * E_s whose
                eigenvalues are not conjugate complex;
          = 4:  FACT = 'N' and the pencil A - lambda * E cannot be
                reduced to generalized Schur form: LAPACK routine
                DGEGS has failed to converge;
          = 5:  DICO = 'C' and the pencil A - lambda * E is not
                c-stable;
          = 6:  DICO = 'D' and the pencil A - lambda * E is not
                d-stable;
          = 7:  the LAPACK routine DSYEVX utilized to factorize M3
                failed to converge in the discrete-time case (see
                section METHOD for SLICOT Library routine SG03BU).
                This error is unlikely to occur.
Method 
  An extension [2] of Hammarling's method [1] to generalized
  Lyapunov equations is utilized to solve (1) or (2).

  First the pencil A - lambda * E is reduced to real generalized
  Schur form A_s - lambda * E_s by means of orthogonal
  transformations (QZ-algorithm):

     A_s = Q**T * A * Z   (upper quasitriangular)                (3)

     E_s = Q**T * E * Z   (upper triangular).                    (4)

  If the pencil A - lambda * E has already been factorized prior to
  calling the routine however, then the factors A_s, E_s, Q and Z
  may be supplied and the initial factorization omitted.

  Depending on the parameters TRANS and M the N-by-N upper
  triangular matrix B_s is defined as follows. In any case Q_B is
  an M-by-M orthogonal matrix, which need not be accumulated.

  1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix
     from the QR-factorization

        ( Q_B  O )           ( B * Z )
        (        ) * B_s  =  (       ),
        (  O   I )           (   O   )

     where the O's are zero matrices of proper size and I is the
     identity matrix of order N-M.

  2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix
     from the (rectangular) QR-factorization

              ( B_s )
        Q_B * (     )  =  B * Z,
              (  O  )

     where O is the (M-N)-by-N zero matrix.

  3. If TRANS = 'T' and M < N, B_s is the upper triangular matrix
     from the RQ-factorization

                    ( Q_B  O )
        (B_s  O ) * (        )  =  ( Q**T * B   O ).
                    (  O   I )

  4. If TRANS = 'T' and M >= N, B_s is the upper triangular matrix
     from the (rectangular) RQ-factorization

        ( B_s   O ) * Q_B  =  Q**T * B,

     where O is the N-by-(M-N) zero matrix.

  Assuming SCALE = 1, the transformation of A, E and B described
  above leads to the reduced continuous-time equation

              T        T
       op(A_s)  op(U_s)  op(U_s) op(E_s)

              T        T
     + op(E_s)  op(U_s)  op(U_s) op(A_s)

                 T
     =  - op(B_s)  op(B_s)                                       (5)

  or to the reduced discrete-time equation

              T        T
       op(A_s)  op(U_s)  op(U_s) op(A_s)

              T        T
     - op(E_s)  op(U_s)  op(U_s) op(E_s)

                 T
     =  - op(B_s)  op(B_s).                                      (6)

  For brevity we restrict ourself to equation (5) and the case
  TRANS = 'N'. The other three cases can be treated in a similar
  fashion.

  We use the following partitioning for the matrices A_s, E_s, B_s
  and U_s

              ( A11   A12 )          ( E11   E12 )
        A_s = (           ),   E_s = (           ),
              (   0   A22 )          (   0   E22 )

              ( B11   B12 )          ( U11   U12 )
        B_s = (           ),   U_s = (           ).              (7)
              (   0   B22 )          (   0   U22 )

  The size of the (1,1)-blocks is 1-by-1 (iff A_s(2,1) = 0.0) or
  2-by-2.

  We compute U11 and U12**T in three steps.

  Step I:

     From (5) and (7) we get the 1-by-1 or 2-by-2 equation

             T      T                   T      T
          A11  * U11  * U11 * E11  + E11  * U11  * U11 * A11

                 T
          = - B11  * B11.

     For brevity, details are omitted here. See [2]. The technique
     for computing U11 is similar to those applied to standard
     Lyapunov equations in Hammarling's algorithm ([1], section 6).

     Furthermore, the auxiliary matrices M1 and M2 defined as
     follows

                            -1      -1
        M1 = U11 * A11 * E11   * U11

                      -1      -1
        M2 = B11 * E11   * U11

     are computed in a numerically reliable way.

  Step II:

     The generalized Sylvester equation

           T      T      T      T
        A22  * U12  + E22  * U12  * M1  =

             T           T      T      T      T
        - B12  * M2 - A12  * U11  - E12  * U11  * M1

     is solved for U12**T.

  Step III:

     It can be shown that

           T      T                  T      T
        A22  * U22  * U22 * E22 + E22  * U22  * U22 * A22  =

             T              T
        - B22  * B22 - y * y                                     (8)

     holds, where y is defined as

               T        T      T      T      T       T
        y = B12  - ( E12  * U11  + E22  * U12  ) * M2 .

     If B22_tilde is the square triangular matrix arising from the
     (rectangular) QR-factorization

                    ( B22_tilde )     ( B22  )
        Q_B_tilde * (           )  =  (      ),
                    (     O     )     ( y**T )

     where Q_B_tilde is an orthogonal matrix of order N, then

             T              T                T
        - B22  * B22 - y * y   =  - B22_tilde  * B22_tilde.

     Replacing the right hand side in (8) by the term
     - B22_tilde**T * B22_tilde leads to a reduced generalized
     Lyapunov equation of lower dimension compared to (5).

  The recursive application of the steps I to III yields the
  solution U_s of the equation (5).

  It remains to compute the solution matrix U of the original
  problem (1) or (2) from the matrix U_s. To this end we transform
  the solution back (with respect to the transformation that led
  from (1) to (5) (from (2) to (6)) and apply the QR-factorization
  (RQ-factorization). The upper triangular solution matrix U is
  obtained by

     Q_U * U  =  U_s * Q**T     (if TRANS = 'N')

  or

     U * Q_U  =  Z * U_s        (if TRANS = 'T')

  where Q_U is an N-by-N orthogonal matrix. Again, the orthogonal
  matrix Q_U need not be accumulated.
References 
  [1] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-323, 1982.

  [2] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Numerical Aspects 
  The number of flops required by the routine is given by the
  following table. Note that we count a single floating point
  arithmetic operation as one flop.

              |           FACT = 'F'                  FACT = 'N'
     ---------+--------------------------------------------------
      M <= N  |     (13*N**3+6*M*N**2         (211*N**3+6*M*N**2
              |   +6*M**2*N-2*M**3)/3        +6*M**2*N-2*M**3)/3
              |
       M > N  | (11*N**3+12*M*N**2)/3     (209*N**3+12*M*N**2)/3
Further Comments 
  The Lyapunov equation may be very ill-conditioned. In particular,
  if DICO = 'D' and the pencil A - lambda * E has a pair of almost
  reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost
  degenerate pair of eigenvalues, then the Lyapunov equation will be
  ill-conditioned. Perturbed values were used to solve the equation.
  A condition estimate can be obtained from the routine SG03AD.
  When setting the error indicator INFO, the routine does not test
  for near instability in the equation but only for exact
  instability.
Example

Program Text 

*     SG03BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           NMAX
      PARAMETER         ( NMAX = 20 )
      INTEGER           LDA, LDB, LDE, LDQ, LDZ
      PARAMETER         ( LDA = NMAX, LDB = NMAX, LDE = NMAX,
     $                    LDQ = NMAX, LDZ = NMAX )
      INTEGER           LDWORK
      PARAMETER         ( LDWORK = MAX( 1, 4*NMAX, 6*NMAX-6 ) )
*     .. Local Scalars ..
      CHARACTER*1       DICO, FACT, TRANS
      DOUBLE PRECISION  SCALE
      INTEGER           I, INFO, J, N, M
*     .. Local Arrays ..
      DOUBLE PRECISION  A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX),
     $                  B(LDB,NMAX), BETA(NMAX), DWORK(LDWORK),
     $                  E(LDE,NMAX), Q(LDQ,NMAX), Z(LDZ,NMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          SG03BD
*     .. Intrinsic Functions ..
      INTRINSIC         MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) M
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N )
         END IF
         IF ( LSAME( FACT, 'T' ) ) THEN
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M )
         END IF
*        Find the Cholesky factor U of the solution matrix.
         CALL SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, LDQ,
     $                Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, BETA,
     $                DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) SCALE
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N )
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' SG03BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SG03BD = ',I2)
99997 FORMAT (' SCALE = ',F8.4,//' The Cholesky factor U of the solution
     $ matrix is')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 SG03BD EXAMPLE PROGRAM DATA
   3      1      C      N      N
  -1.0    3.0   -4.0
   0.0    5.0   -2.0
  -4.0    4.0    1.0
   2.0    1.0    3.0
   2.0    0.0    1.0
   4.0    5.0    1.0
   2.0   -1.0    7.0
Program Results 
 SG03BD EXAMPLE PROGRAM RESULTS

 SCALE =   1.0000

 The Cholesky factor U of the solution matrix is
   1.6003  -0.4418  -0.1523
   0.0000   0.6795  -0.2499
   0.0000   0.0000   0.2041

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/SG03BU.html000077500000000000000000000220761201767322700161160ustar00rootroot00000000000000 SG03BU - SLICOT Library Routine Documentation

SG03BU

Solving (for Cholesky factor) generalized stable discrete-time Lyapunov equations, with A quasi-triangular, and E, B upper triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Cholesky factor U of the matrix X, X = U**T * U or
  X = U * U**T, which is the solution of the generalized d-stable
  discrete-time Lyapunov equation

      T            T                  2    T
     A  * X * A - E  * X * E = - SCALE  * B  * B,                (1)

  or the transposed equation

              T            T          2        T
     A * X * A  - E * X * E  = - SCALE  * B * B ,                (2)

  respectively, where A, E, B, and U are real N-by-N matrices. The
  Cholesky factor U of the solution is computed without first
  finding X. The pencil A - lambda * E must be in generalized Schur
  form ( A upper quasitriangular, E upper triangular ). Moreover, it
  must be d-stable, i.e. the moduli of its eigenvalues must be less
  than one. B must be an upper triangular matrix with non-negative
  entries on its main diagonal.

  The resulting matrix U is upper triangular. The entries on its
  main diagonal are non-negative. SCALE is an output scale factor
  set to avoid overflow in U.
Specification 
      SUBROUTINE SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE,
     $                   DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies whether equation (1) or equation (2) is to be
          solved:
          = 'N':  Solve equation (1);
          = 'T':  Solve equation (2).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the quasitriangular matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N upper triangular part of this array
          must contain the matrix E.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the matrix B.
          On exit, the leading N-by-N upper triangular part of this
          array contains the solution matrix U.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in U.
          0 < SCALE <= 1.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (6*N-6)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the generalized Sylvester equation to be solved in
                step II (see METHOD) is (nearly) singular to working
                precision;  perturbed values were used to solve the
                equation (but the matrices A and E are unchanged);
          = 2:  the generalized Schur form of the pencil
                A - lambda * E contains a 2-by-2 main diagonal block
                whose eigenvalues are not a pair of conjugate
                complex numbers;
          = 3:  the pencil A - lambda * E is not d-stable, i.e.
                there are eigenvalues outside the open unit circle;
          = 4:  the LAPACK routine DSYEVX utilized to factorize M3
                failed to converge. This error is unlikely to occur.
Method 
  The method [2] used by the routine is an extension of Hammarling's
  algorithm [1] to generalized Lyapunov equations.

  We present the method for solving equation (1). Equation (2) can
  be treated in a similar fashion. For simplicity, assume SCALE = 1.

  The matrix A is an upper quasitriangular matrix, i.e. it is a
  block triangular matrix with square blocks on the main diagonal
  and the block order at most 2. We use the following partitioning
  for the matrices A, E, B and the solution matrix U

            ( A11   A12 )        ( E11   E12 )
        A = (           ),   E = (           ),
            (   0   A22 )        (   0   E22 )

            ( B11   B12 )        ( U11   U12 )
        B = (           ),   U = (           ).                  (3)
            (   0   B22 )        (   0   U22 )

  The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or
  2-by-2.

  We compute U11 and U12**T in three steps.

  Step I:

     From (1) and (3) we get the 1-by-1 or 2-by-2 equation

             T      T                   T      T
          A11  * U11  * U11 * A11  - E11  * U11  * U11 * E11

                 T
          = - B11  * B11.

     For brevity, details are omitted here. The technique for
     computing U11 is similar to those applied to standard Lyapunov
     equations in Hammarling's algorithm ([1], section 6).

     Furthermore, the auxiliary matrices M1 and M2 defined as
     follows

                            -1      -1
        M1 = U11 * A11 * E11   * U11

                      -1      -1
        M2 = B11 * E11   * U11

     are computed in a numerically reliable way.

  Step II:

     We solve for U12**T the generalized Sylvester equation

           T      T           T      T
        A22  * U12  * M1 - E22  * U12

               T           T      T      T      T
        = - B12  * M2 + E12  * U11  - A12  * U11  * M1.

  Step III:

     One can show that

           T      T                  T      T
        A22  * U22  * U22 * A22 - E22  * U22  * U22 * E22  =

             T              T
        - B22  * B22 - y * y                                     (4)

     holds, where y is defined as follows

               T      T      T      T
        w = A12  * U11  + A22  * U12

                 T
        y = ( B12   w ) * M3EV,

     where M3EV is a matrix which fulfils

             ( I-M2*M2**T   -M2*M1**T )              T
        M3 = (                        ) = M3EV * M3EV .
             (  -M1*M2**T  I-M1*M1**T )

     M3 is positive semidefinite and its rank is equal to the size
     of U11. Therefore, a matrix M3EV can be found by solving the
     symmetric eigenvalue problem for M3 such that y consists of
     either 1 or 2 rows.

     If B22_tilde is the square triangular matrix arising from the
     QR-factorization

            ( B22_tilde )     ( B22  )
        Q * (           )  =  (      ),
            (     0     )     ( y**T )

     then

             T              T                T
        - B22  * B22 - y * y   =  - B22_tilde  * B22_tilde.

     Replacing the right hand side in (4) by the term
     - B22_tilde**T * B22_tilde leads to a generalized Lyapunov
     equation of lower dimension compared to (1).

  The solution U of the equation (1) can be obtained by recursive
  application of the steps I to III.
References 
  [1] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-323, 1982.

  [2] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Numerical Aspects 
  The routine requires 2*N**3 flops. Note that we count a single
  floating point arithmetic operation as one flop.
Further Comments 
  The Lyapunov equation may be very ill-conditioned. In particular,
  if the pencil A - lambda * E has a pair of almost reciprocal
  eigenvalues, then the Lyapunov equation will be ill-conditioned.
  Perturbed values were used to solve the equation.
  A condition estimate can be obtained from the routine SG03AD.
  When setting the error indicator INFO, the routine does not test
  for near instability in the equation but only for exact
  instability.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SG03BV.html000077500000000000000000000210151201767322700161070ustar00rootroot00000000000000 SG03BV - SLICOT Library Routine Documentation

SG03BV

Solving (for Cholesky factor) generalized stable continuous-time Lyapunov equations, with A quasi-triangular, and E, B upper triangular

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the Cholesky factor U of the matrix X, X = U**T * U or
  X = U * U**T, which is the solution of the generalized c-stable
  continuous-time Lyapunov equation

      T            T                  2    T
     A  * X * E + E  * X * A = - SCALE  * B  * B,                (1)

  or the transposed equation

              T            T          2        T
     A * X * E  + E * X * A  = - SCALE  * B * B ,                (2)

  respectively, where A, E, B, and U are real N-by-N matrices. The
  Cholesky factor U of the solution is computed without first
  finding X. The pencil A - lambda * E must be in generalized Schur
  form ( A upper quasitriangular, E upper triangular ). Moreover, it
  must be c-stable, i.e. its eigenvalues must have negative real
  parts. B must be an upper triangular matrix with non-negative
  entries on its main diagonal.

  The resulting matrix U is upper triangular. The entries on its
  main diagonal are non-negative. SCALE is an output scale factor
  set to avoid overflow in U.
Specification 
      SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE,
     $                   DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies whether equation (1) or equation (2) is to be
          solved:
          = 'N':  Solve equation (1);
          = 'T':  Solve equation (2).
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N upper Hessenberg part of this array
          must contain the quasitriangular matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,N)
          The leading N-by-N upper triangular part of this array
          must contain the matrix E.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
          On entry, the leading N-by-N upper triangular part of this
          array must contain the matrix B.
          On exit, the leading N-by-N upper triangular part of this
          array contains the solution matrix U.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= MAX(1,N).

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in U.
          0 < SCALE <= 1.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (6*N-6)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the generalized Sylvester equation to be solved in
                step II (see METHOD) is (nearly) singular to working
                precision;  perturbed values were used to solve the
                equation (but the matrices A and E are unchanged);
          = 2:  the generalized Schur form of the pencil
                A - lambda * E contains a 2-by-2 main diagonal block
                whose eigenvalues are not a pair of conjugate
                complex numbers;
          = 3:  the pencil A - lambda * E is not stable, i.e. there
                is an eigenvalue without a negative real part.
Method 
  The method [2] used by the routine is an extension of Hammarling's
  algorithm [1] to generalized Lyapunov equations.

  We present the method for solving equation (1). Equation (2) can
  be treated in a similar fashion. For simplicity, assume SCALE = 1.

  The matrix A is an upper quasitriangular matrix, i.e. it is a
  block triangular matrix with square blocks on the main diagonal
  and the block order at most 2. We use the following partitioning
  for the matrices A, E, B and the solution matrix U

            ( A11   A12 )        ( E11   E12 )
        A = (           ),   E = (           ),
            (   0   A22 )        (   0   E22 )

            ( B11   B12 )        ( U11   U12 )
        B = (           ),   U = (           ).                  (3)
            (   0   B22 )        (   0   U22 )

  The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or
  2-by-2.

  We compute U11 and U12**T in three steps.

  Step I:

     From (1) and (3) we get the 1-by-1 or 2-by-2 equation

             T      T                  T      T
          A11  * U11  * U11 * E11 + E11  * U11  * U11 * A11

                 T
          = - B11  * B11.

     For brevity, details are omitted here. The technique for
     computing U11 is similar to those applied to standard Lyapunov
     equations in Hammarling's algorithm ([1], section 6).

     Furthermore, the auxiliary matrices M1 and M2 defined as
     follows

                            -1      -1
        M1 = U11 * A11 * E11   * U11

                      -1      -1
        M2 = B11 * E11   * U11

     are computed in a numerically reliable way.

  Step II:

     We solve for U12**T the generalized Sylvester equation

           T      T      T      T
        A22  * U12  + E22  * U12  * M1

               T           T      T      T      T
        = - B12  * M2 - A12  * U11  - E12  * U11  * M1.

  Step III:

     One can show that

           T      T                  T      T
        A22  * U22  * U22 * E22 + E22  * U22  * U22 * A22  =

             T              T
        - B22  * B22 - y * y                                     (4)

     holds, where y is defined as follows

               T      T      T      T
        w = E12  * U11  + E22  * U12
               T         T
        y = B12  - w * M2 .

     If B22_tilde is the square triangular matrix arising from the
     QR-factorization

            ( B22_tilde )     ( B22  )
        Q * (           )  =  (      ),
            (     0     )     ( y**T )

     then

             T              T                T
        - B22  * B22 - y * y   =  - B22_tilde  * B22_tilde.

     Replacing the right hand side in (4) by the term
     - B22_tilde**T * B22_tilde leads to a generalized Lyapunov
     equation of lower dimension compared to (1).

  The solution U of the equation (1) can be obtained by recursive
  application of the steps I to III.
References 
  [1] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-323, 1982.

  [2] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Numerical Aspects 
  The routine requires 2*N**3 flops. Note that we count a single
  floating point arithmetic operation as one flop.
Further Comments 
  The Lyapunov equation may be very ill-conditioned. In particular,
  if the pencil A - lambda * E has a pair of almost degenerate
  eigenvalues, then the Lyapunov equation will be ill-conditioned.
  Perturbed values were used to solve the equation.
  A condition estimate can be obtained from the routine SG03AD.
  When setting the error indicator INFO, the routine does not test
  for near instability in the equation but only for exact
  instability.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SG03BW.html000077500000000000000000000135511201767322700161160ustar00rootroot00000000000000 SG03BW - SLICOT Library Routine Documentation

SG03BW

Solving a generalized Sylvester equation, with A quasi-triangular, and E upper triangular, for an m-by-n matrix X, 1 <= n <= 2

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X the generalized Sylvester equation

      T            T
     A  * X * C + E  * X * D  =  SCALE * Y,                      (1)

  or the transposed equation

              T            T
     A * X * C  + E * X * D   =  SCALE * Y,                      (2)

  where A and E are real M-by-M matrices, C and D are real N-by-N
  matrices, X and Y are real M-by-N matrices. N is either 1 or 2.
  The pencil A - lambda * E must be in generalized real Schur form
  (A upper quasitriangular, E upper triangular). SCALE is an output
  scale factor, set to avoid overflow in X.
Specification 
      SUBROUTINE SG03BW( TRANS, M, N, A, LDA, C, LDC, E, LDE, D, LDD, X,
     $                   LDX, SCALE, INFO )
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,*)
Arguments

Mode Parameters 

  TRANS   CHARACTER*1
          Specifies whether the transposed equation is to be solved
          or not:
          = 'N':  Solve equation (1);
          = 'T':  Solve equation (2).
Input/Output Parameters 
  M       (input) INTEGER
          The order of the matrices A and E.  M >= 0.

  N       (input) INTEGER
          The order of the matrices C and D.  N = 1 or N = 2.

  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
          The leading M-by-M part of this array must contain the
          upper quasitriangular matrix A. The elements below the
          upper Hessenberg part are not referenced.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,M).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading N-by-N part of this array must contain the
          matrix C.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,N).

  E       (input) DOUBLE PRECISION array, dimension (LDE,M)
          The leading M-by-M part of this array must contain the
          upper triangular matrix E. The elements below the main
          diagonal are not referenced.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= MAX(1,M).

  D       (input) DOUBLE PRECISION array, dimension (LDD,N)
          The leading N-by-N part of this array must contain the
          matrix D.

  LDD     INTEGER
          The leading dimension of the array D.  LDD >= MAX(1,N).

  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
          On entry, the leading M-by-N part of this array must
          contain the right hand side matrix Y.
          On exit, the leading M-by-N part of this array contains
          the solution matrix X.

  LDX     INTEGER
          The leading dimension of the array X.  LDX >= MAX(1,M).

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in X.
          0 < SCALE <= 1.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the generalized Sylvester equation is (nearly)
                singular to working precision;  perturbed values
                were used to solve the equation (but the matrices
                A, C, D, and E are unchanged).
Method 
  The method used by the routine is based on a generalization of the
  algorithm due to Bartels and Stewart [1]. See also [2] and [3] for
  details.
References 
  [1] Bartels, R.H., Stewart, G.W.
      Solution of the equation A X + X B = C.
      Comm. A.C.M., 15, pp. 820-826, 1972.

  [2] Gardiner, J.D., Laub, A.J., Amato, J.J., Moler, C.B.
      Solution of the Sylvester Matrix Equation
      A X B**T + C X D**T = E.
      A.C.M. Trans. Math. Soft., vol. 18, no. 2, pp. 223-231, 1992.

  [3] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Numerical Aspects 
  The routine requires about 2 * N * M**2 flops. Note that we count
  a single floating point arithmetic operation as one flop.

  The algorithm is backward stable if the eigenvalues of the pencil
  A - lambda * E are real. Otherwise, linear systems of order at
  most 4 are involved into the computation. These systems are solved
  by Gauss elimination with complete pivoting. The loss of stability
  of the Gauss elimination with complete pivoting is rarely
  encountered in practice.
Further Comments 
  When near singularity is detected, perturbed values are used
  to solve the equation (but the given matrices are unchanged).
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SG03BX.html000077500000000000000000000140461201767322700161170ustar00rootroot00000000000000 SG03BX - SLICOT Library Routine Documentation

SG03BX

Solving (for Cholesky factor) generalized stable 2-by-2 continuous- or discrete-time Lyapunov equations, with pencil A - lambda E having complex conjugate eigenvalues (E upper triangular)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To solve for X = op(U)**T * op(U) either the generalized c-stable
  continuous-time Lyapunov equation

          T                    T
     op(A)  * X * op(E) + op(E)  * X * op(A)

              2        T
     = - SCALE  * op(B)  * op(B),                                (1)

  or the generalized d-stable discrete-time Lyapunov equation

          T                    T
     op(A)  * X * op(A) - op(E)  * X * op(E)

              2        T
     = - SCALE  * op(B)  * op(B),                                (2)

  where op(K) is either K or K**T for K = A, B, E, U. The Cholesky
  factor U of the solution is computed without first finding X.

  Furthermore, the auxiliary matrices

                                -1        -1
     M1 := op(U) * op(A) * op(E)   * op(U)

                        -1        -1
     M2 := op(B) * op(E)   * op(U)

  are computed in a numerically reliable way.

  The matrices A, B, E, M1, M2, and U are real 2-by-2 matrices. The
  pencil A - lambda * E must have a pair of complex conjugate
  eigenvalues. The eigenvalues must be in the open right half plane
  (in the continuous-time case) or inside the unit circle (in the
  discrete-time case).

  The resulting matrix U is upper triangular. The entries on its
  main diagonal are non-negative. SCALE is an output scale factor
  set to avoid overflow in U.
Specification 
      SUBROUTINE SG03BX( DICO, TRANS, A, LDA, E, LDE, B, LDB, U, LDU,
     $                   SCALE, M1, LDM1, M2, LDM2, INFO )
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,*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies whether the continuous-time or the discrete-time
          equation is to be solved:
          = 'C':  Solve continuous-time equation (1);
          = 'D':  Solve discrete-time equation (2).

  TRANS   CHARACTER*1
          Specifies whether the transposed equation is to be solved
          or not:
          = 'N':  op(K) = K,     K = A, B, E, U;
          = 'T':  op(K) = K**T,  K = A, B, E, U.
Input/Output Parameters 
  A       (input) DOUBLE PRECISION array, dimension (LDA,2)
          The leading 2-by-2 part of this array must contain the
          matrix A.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= 2.

  E       (input) DOUBLE PRECISION array, dimension (LDE,2)
          The leading 2-by-2 upper triangular part of this array
          must contain the matrix E.

  LDE     INTEGER
          The leading dimension of the array E.  LDE >= 2.

  B       (input) DOUBLE PRECISION array, dimension (LDB,2)
          The leading 2-by-2 upper triangular part of this array
          must contain the matrix B.

  LDB     INTEGER
          The leading dimension of the array B.  LDB >= 2.

  U       (output) DOUBLE PRECISION array, dimension (LDU,2)
          The leading 2-by-2 part of this array contains the upper
          triangular matrix U.

  LDU     INTEGER
          The leading dimension of the array U.  LDU >= 2.

  SCALE   (output) DOUBLE PRECISION
          The scale factor set to avoid overflow in U.
          0 < SCALE <= 1.

  M1      (output) DOUBLE PRECISION array, dimension (LDM1,2)
          The leading 2-by-2 part of this array contains the
          matrix M1.

  LDM1    INTEGER
          The leading dimension of the array M1.  LDM1 >= 2.

  M2      (output) DOUBLE PRECISION array, dimension (LDM2,2)
          The leading 2-by-2 part of this array contains the
          matrix M2.

  LDM2    INTEGER
          The leading dimension of the array M2.  LDM2 >= 2.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          = 2:  the eigenvalues of the pencil A - lambda * E are not
                a pair of complex conjugate numbers;
          = 3:  the eigenvalues of the pencil A - lambda * E are
                not in the open right half plane (in the continuous-
                time case) or inside the unit circle (in the
                discrete-time case).
Method 
  The method used by the routine is based on a generalization of the
  method due to Hammarling ([1], section 6) for Lyapunov equations
  of order 2. A more detailed description is given in [2].
References 
  [1] Hammarling, S.J.
      Numerical solution of the stable, non-negative definite
      Lyapunov equation.
      IMA J. Num. Anal., 2, pp. 303-323, 1982.

  [2] Penzl, T.
      Numerical solution of generalized Lyapunov equations.
      Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
Further Comments 
  If the solution matrix U is singular, the matrices M1 and M2 are
  properly set (see [1], equation (6.21)).
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/SG03BY.html000077500000000000000000000041311201767322700161120ustar00rootroot00000000000000 SG03BY - SLICOT Library Routine Documentation

SG03BY

Compute a complex Givens rotation in real arithmetic

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the parameters for the complex Givens rotation

     (  CR-CI*I   SR-SI*I )   ( XR+XI*I )   ( Z )
     (                    ) * (         ) = (   ),
     ( -SR-SI*I   CR+CI*I )   ( YR+YI*I )   ( 0 )

  where CR, CI, SR, SI, XR, XI, YR, YI are real numbers and I is the
  imaginary unit, I = SQRT(-1). Z is a non-negative real number.
Specification 
      SUBROUTINE SG03BY( XR, XI, YR, YI, CR, CI, SR, SI, Z )
C     .. Scalar Arguments ..
       DOUBLE PRECISION  CI, CR, SI, SR, XI, XR, YI, YR, Z
Arguments

Input/Output Parameters 

  XR, XI, (input) DOUBLE PRECISION
  YR, YI  (input) DOUBLE PRECISION
          The given real scalars XR, XI, YR, YI.

  CR, CI, (output) DOUBLE PRECISION
  SR, SI, (output) DOUBLE PRECISION
  Z       (output) DOUBLE PRECISION
          The computed real scalars CR, CI, SR, SI, Z, defining the
          complex Givens rotation and Z.
Numerical Aspects 
  The subroutine avoids unnecessary overflow.
Further Comments 
  In the interest of speed, this routine does not check the input
  for errors.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB01ID.html000077500000000000000000000257321201767322700161000ustar00rootroot00000000000000 TB01ID - SLICOT Library Routine Documentation

TB01ID

Balancing a system matrix corresponding to a triplet (A,B,C)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the 1-norm of a system matrix

          S =  ( A  B )
               ( C  0 )

  corresponding to the triple (A,B,C), by balancing. This involves
  a diagonal similarity transformation inv(D)*A*D applied
  iteratively to A to make the rows and columns of
                        -1
               diag(D,I)  * S * diag(D,I)

  as close in norm as possible.

  The balancing can be performed optionally on the following
  particular system matrices

           S = A,    S = ( A  B )    or    S = ( A )
                                               ( C )
Specification 
      SUBROUTINE TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                   SCALE, INFO )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            INFO, LDA, LDB, LDC, M, N, P
      DOUBLE PRECISION   MAXRED
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   SCALE( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates which matrices are involved in balancing, as
          follows:
          = 'A':  All matrices are involved in balancing;
          = 'B':  B and A matrices are involved in balancing;
          = 'C':  C and A matrices are involved in balancing;
          = 'N':  B and C matrices are not involved in balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A, the number of rows of matrix B
          and the number of columns of matrix C.
          N represents the dimension of the state vector.  N >= 0.

  M       (input) INTEGER.
          The number of columns of matrix B.
          M represents the dimension of input vector.  M >= 0.

  P       (input) INTEGER.
          The number of rows of matrix C.
          P represents the dimension of output vector.  P >= 0.

  MAXRED  (input/output) DOUBLE PRECISION
          On entry, the maximum allowed reduction in the 1-norm of
          S (in an iteration) if zero rows or columns are
          encountered.
          If MAXRED > 0.0, MAXRED must be larger than one (to enable
          the norm reduction).
          If MAXRED <= 0.0, then the value 10.0 for MAXRED is
          used.
          On exit, if the 1-norm of the given matrix S is non-zero,
          the ratio between the 1-norm of the given matrix and the
          1-norm of the balanced matrix.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state matrix A.
          On exit, the leading N-by-N part of this array contains
          the balanced matrix inv(D)*A*D.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, if M > 0, the leading N-by-M part of this array
          must contain the system input matrix B.
          On exit, if M > 0, the leading N-by-M part of this array
          contains the balanced matrix inv(D)*B.
          The array B is not referenced if M = 0.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N) if M > 0.
          LDB >= 1        if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, if P > 0, the leading P-by-N part of this array
          must contain the system output matrix C.
          On exit, if P > 0, the leading P-by-N part of this array
          contains the balanced matrix C*D.
          The array C is not referenced if P = 0.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,P).

  SCALE   (output) DOUBLE PRECISION array, dimension (N)
          The scaling factors applied to S.  If D(j) is the scaling
          factor applied to row and column j, then SCALE(j) = D(j),
          for j = 1,...,N.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Balancing consists of applying a diagonal similarity
  transformation
                        -1
               diag(D,I)  * S * diag(D,I)

  to make the 1-norms of each row of the first N rows of S and its
  corresponding column nearly equal.

  Information about the diagonal matrix D is returned in the vector
  SCALE.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     TB01ID EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOB
      INTEGER          I, INFO, J, M, N, P
      DOUBLE PRECISION MAXRED
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 SCALE(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01ID, UD01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOB, MAXRED
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Balance system matrix S.
               CALL TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C,
     $                      LDC, SCALE, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  CALL UD01MD( N, N, 5, NOUT, A, LDA,
     $                        'The balanced matrix A', INFO )
                  IF ( M.GT.0 )
     $               CALL UD01MD( N, M, 5, NOUT, B, LDB,
     $                            'The balanced matrix B', INFO )
                  IF ( P.GT.0 )
     $               CALL UD01MD( P, N, 5, NOUT, C, LDC,
     $                            'The balanced matrix C', INFO )
                  CALL UD01MD( 1, N, 5, NOUT, SCALE, 1,
     $                        'The scaling vector SCALE', INFO )
                  WRITE ( NOUT, FMT = 99994 ) MAXRED
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01ID EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01ID = ',I2)
99994 FORMAT (/' MAXRED is ',E13.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB01ID EXAMPLE PROGRAM DATA
   5     2     5       A    0.0
          0.0  1.0000e+000          0.0          0.0          0.0
 -1.5800e+006 -1.2570e+003          0.0          0.0          0.0
  3.5410e+014          0.0 -1.4340e+003          0.0 -5.3300e+011
          0.0          0.0          0.0          0.0  1.0000e+000
          0.0          0.0          0.0 -1.8630e+004 -1.4820e+000
          0.0          0.0
  1.1030e+002          0.0
          0.0          0.0
          0.0          0.0
          0.0  8.3330e-003
  1.0000e+000          0.0          0.0          0.0          0.0
          0.0          0.0  1.0000e+000          0.0          0.0
          0.0          0.0          0.0  1.0000e+000          0.0
  6.6640e-001          0.0 -6.2000e-013          0.0          0.0
          0.0          0.0 -1.0000e-003  1.8960e+006  1.5080e+002
Program Results 
 TB01ID EXAMPLE PROGRAM RESULTS

 The balanced matrix A ( 5X 5)

            1              2              3              4              5
  1    0.0000000D+00  0.1000000D+05  0.0000000D+00  0.0000000D+00  0.0000000D+00
  2   -0.1580000D+03 -0.1257000D+04  0.0000000D+00  0.0000000D+00  0.0000000D+00
  3    0.3541000D+05  0.0000000D+00 -0.1434000D+04  0.0000000D+00 -0.5330000D+03
  4    0.0000000D+00  0.0000000D+00  0.0000000D+00  0.0000000D+00  0.1000000D+03
  5    0.0000000D+00  0.0000000D+00  0.0000000D+00 -0.1863000D+03 -0.1482000D+01
 
 The balanced matrix B ( 5X 2)

            1              2
  1    0.0000000D+00  0.0000000D+00
  2    0.1103000D+04  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00
  4    0.0000000D+00  0.0000000D+00
  5    0.0000000D+00  0.8333000D+02
 
 The balanced matrix C ( 5X 5)

            1              2              3              4              5
  1    0.1000000D-04  0.0000000D+00  0.0000000D+00  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.0000000D+00  0.1000000D+06  0.0000000D+00  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00  0.0000000D+00  0.1000000D-05  0.0000000D+00
  4    0.6664000D-05  0.0000000D+00 -0.6200000D-07  0.0000000D+00  0.0000000D+00
  5    0.0000000D+00  0.0000000D+00 -0.1000000D+03  0.1896000D+01  0.1508000D-01
 
 The scaling vector SCALE ( 1X 5)

            1              2              3              4              5
  1    0.1000000D-04  0.1000000D+00  0.1000000D+06  0.1000000D-05  0.1000000D-03
 

 MAXRED is    0.3488E+10

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01IZ.html000077500000000000000000000304471201767322700161250ustar00rootroot00000000000000 TB01IZ - SLICOT Library Routine Documentation

TB01IZ

Balancing a system matrix corresponding to a triplet (A,B,C) (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the 1-norm of a system matrix

          S =  ( A  B )
               ( C  0 )

  corresponding to the triple (A,B,C), by balancing. This involves
  a diagonal similarity transformation inv(D)*A*D applied
  iteratively to A to make the rows and columns of
                        -1
               diag(D,I)  * S * diag(D,I)

  as close in norm as possible.

  The balancing can be performed optionally on the following
  particular system matrices

           S = A,    S = ( A  B )    or    S = ( A )
                                               ( C )
Specification 
      SUBROUTINE TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                   SCALE, INFO )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            INFO, LDA, LDB, LDC, M, N, P
      DOUBLE PRECISION   MAXRED
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
      DOUBLE PRECISION   SCALE( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates which matrices are involved in balancing, as
          follows:
          = 'A':  All matrices are involved in balancing;
          = 'B':  B and A matrices are involved in balancing;
          = 'C':  C and A matrices are involved in balancing;
          = 'N':  B and C matrices are not involved in balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A, the number of rows of matrix B
          and the number of columns of matrix C.
          N represents the dimension of the state vector.  N >= 0.

  M       (input) INTEGER.
          The number of columns of matrix B.
          M represents the dimension of input vector.  M >= 0.

  P       (input) INTEGER.
          The number of rows of matrix C.
          P represents the dimension of output vector.  P >= 0.

  MAXRED  (input/output) DOUBLE PRECISION
          On entry, the maximum allowed reduction in the 1-norm of
          S (in an iteration) if zero rows or columns are
          encountered.
          If MAXRED > 0.0, MAXRED must be larger than one (to enable
          the norm reduction).
          If MAXRED <= 0.0, then the value 10.0 for MAXRED is
          used.
          On exit, if the 1-norm of the given matrix S is non-zero,
          the ratio between the 1-norm of the given matrix and the
          1-norm of the balanced matrix.

  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state matrix A.
          On exit, the leading N-by-N part of this array contains
          the balanced matrix inv(D)*A*D.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= max(1,N).

  B       (input/output) COMPLEX*16 array, dimension (LDB,M)
          On entry, if M > 0, the leading N-by-M part of this array
          must contain the system input matrix B.
          On exit, if M > 0, the leading N-by-M part of this array
          contains the balanced matrix inv(D)*B.
          The array B is not referenced if M = 0.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N) if M > 0.
          LDB >= 1        if M = 0.

  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
          On entry, if P > 0, the leading P-by-N part of this array
          must contain the system output matrix C.
          On exit, if P > 0, the leading P-by-N part of this array
          contains the balanced matrix C*D.
          The array C is not referenced if P = 0.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,P).

  SCALE   (output) DOUBLE PRECISION array, dimension (N)
          The scaling factors applied to S.  If D(j) is the scaling
          factor applied to row and column j, then SCALE(j) = D(j),
          for j = 1,...,N.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Balancing consists of applying a diagonal similarity
  transformation
                        -1
               diag(D,I)  * S * diag(D,I)

  to make the 1-norms of each row of the first N rows of S and its
  corresponding column nearly equal.

  Information about the diagonal matrix D is returned in the vector
  SCALE.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     TB01IZ EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOB
      INTEGER          I, INFO, J, M, N, P
      DOUBLE PRECISION MAXRED
*     .. Local Arrays ..
      COMPLEX*16       A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX)
      DOUBLE PRECISION SCALE(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01IZ, UD01MD, UD01MZ
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOB, MAXRED
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Balance system matrix S.
               CALL TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C,
     $                      LDC, SCALE, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  CALL UD01MZ( N, N, 3, NOUT, A, LDA,
     $                        'The balanced matrix A', INFO )
                  IF ( M.GT.0 )
     $               CALL UD01MZ( N, M, 3, NOUT, B, LDB,
     $                            'The balanced matrix B', INFO )
                  IF ( P.GT.0 )
     $               CALL UD01MZ( P, N, 3, NOUT, C, LDC,
     $                            'The balanced matrix C', INFO )
                  CALL UD01MD( 1, N, 5, NOUT, SCALE, 1,
     $                        'The scaling vector SCALE', INFO )
                  WRITE ( NOUT, FMT = 99994 ) MAXRED
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01IZ EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01IZ = ',I2)
99994 FORMAT (/' MAXRED is ',E13.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB01IZ EXAMPLE PROGRAM DATA
   5     2     5       A    0.0
          0.0  1.0000e+000          0.0          0.0          0.0
 -1.5800e+006 -1.2570e+003          0.0          0.0          0.0
  3.5410e+014          0.0 -1.4340e+003          0.0 -5.3300e+011
          0.0          0.0          0.0          0.0  1.0000e+000
          0.0          0.0          0.0 -1.8630e+004 -1.4820e+000
          0.0          0.0
  1.1030e+002          0.0
          0.0          0.0
          0.0          0.0
          0.0  8.3330e-003
  1.0000e+000          0.0          0.0          0.0          0.0
          0.0          0.0  1.0000e+000          0.0          0.0
          0.0          0.0          0.0  1.0000e+000          0.0
  6.6640e-001          0.0 -6.2000e-013          0.0          0.0
          0.0          0.0 -1.0000e-003  1.8960e+006  1.5080e+002
Program Results 
 TB01IZ EXAMPLE PROGRAM RESULTS

 The balanced matrix A (    5X    5)

                        1                               2                               3
     1    0.0000000D+00 +0.0000000D+00i   0.1000000D+05 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     2   -0.1580000D+03 +0.0000000D+00i  -0.1257000D+04 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     3    0.3541000D+05 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i  -0.1434000D+04 +0.0000000D+00i 
     4    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     5    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
 
                        4                               5
     1    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     2    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     3    0.0000000D+00 +0.0000000D+00i  -0.5330000D+03 +0.0000000D+00i 
     4    0.0000000D+00 +0.0000000D+00i   0.1000000D+03 +0.0000000D+00i 
     5   -0.1863000D+03 +0.0000000D+00i  -0.1482000D+01 +0.0000000D+00i 
 
 The balanced matrix B (    5X    2)

                        1                               2
     1    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     2    0.1103000D+04 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     3    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     4    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     5    0.0000000D+00 +0.0000000D+00i   0.8333000D+02 +0.0000000D+00i 
 
 The balanced matrix C (    5X    5)

                        1                               2                               3
     1    0.1000000D-04 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     2    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i   0.1000000D+06 +0.0000000D+00i 
     3    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     4    0.6664000D-05 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i  -0.6200000D-07 +0.0000000D+00i 
     5    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i  -0.1000000D+03 +0.0000000D+00i 
 
                        4                               5
     1    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     2    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     3    0.1000000D-05 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     4    0.0000000D+00 +0.0000000D+00i   0.0000000D+00 +0.0000000D+00i 
     5    0.1896000D+01 +0.0000000D+00i   0.1508000D-01 +0.0000000D+00i 
 
 The scaling vector SCALE ( 1X 5)

            1              2              3              4              5
  1    0.1000000D-04  0.1000000D+00  0.1000000D+06  0.1000000D-05  0.1000000D-03
 

 MAXRED is    0.3488E+10

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01KD.html000077500000000000000000000333341201767322700160770ustar00rootroot00000000000000 TB01KD - SLICOT Library Routine Documentation

TB01KD

Similarity reduction of system state-matrix to block-diagonal form with two blocks so that the leading block has eigenvalues in a specified domain

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute an additive spectral decomposition of the transfer-
  function matrix of the system (A,B,C) by reducing the system
  state-matrix A to a block-diagonal form.
  The system matrices are transformed as
  A <-- inv(U)*A*U, B <--inv(U)*B and C <-- C*U.
  The leading diagonal block of the resulting A has eigenvalues
  in a suitably defined domain of interest.
Specification 
      SUBROUTINE TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B,
     $                   LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK,
     $                   LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  STDOM   CHARACTER*1
          Specifies whether the domain of interest is of stability
          type (left part of complex plane or inside of a circle)
          or of instability type (right part of complex plane or
          outside of a circle) as follows:
          = 'S':  stability type domain;
          = 'U':  instability type domain.

  JOBA    CHARACTER*1
          Specifies the shape of the state dynamics matrix on entry
          as follows:
          = 'S':  A is in an upper real Schur form;
          = 'G':  A is a general square dense matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation,
          i.e. the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs, or of columns of B.  M >= 0.

  P       (input) INTEGER
          The number of system outputs, or of rows of C.  P >= 0.

  ALPHA   (input) DOUBLE PRECISION.
          Specifies the boundary of the domain of interest for the
          eigenvalues of A. For a continuous-time system
          (DICO = 'C'), ALPHA is the boundary value for the real
          parts of eigenvalues, while for a discrete-time system
          (DICO = 'D'), ALPHA >= 0 represents the boundary value for
          the moduli of eigenvalues.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the unreduced state dynamics matrix A.
          If JOBA = 'S' then A must be a matrix in real Schur form.
          On exit, the leading N-by-N part of this array contains a
          block diagonal matrix inv(U) * A * U with two diagonal
          blocks in real Schur form with the elements below the
          first subdiagonal set to zero.
          The leading NDIM-by-NDIM block of A has eigenvalues in the
          domain of interest and the trailing (N-NDIM)-by-(N-NDIM)
          block has eigenvalues outside the domain of interest.
          The domain of interest for lambda(A), the eigenvalues
          of A, is defined by the parameters ALPHA, DICO and STDOM
          as follows:
          For a continuous-time system (DICO = 'C'):
            Real(lambda(A)) < ALPHA if STDOM = 'S';
            Real(lambda(A)) > ALPHA if STDOM = 'U';
          For a discrete-time system (DICO = 'D'):
            Abs(lambda(A)) < ALPHA if STDOM = 'S';
            Abs(lambda(A)) > ALPHA if STDOM = 'U'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed input matrix inv(U) * B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed output matrix C * U.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  NDIM    (output) INTEGER
          The number of eigenvalues of A lying inside the domain of
          interest for eigenvalues.

  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array contains the
          transformation matrix used to reduce A to the block-
          diagonal form. The first NDIM columns of U span the
          invariant subspace of A corresponding to the eigenvalues
          of its leading diagonal block. The last N-NDIM columns
          of U span the reducing subspace of A corresponding to
          the eigenvalues of the trailing diagonal block of A.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= max(1,N).

  WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
          WR and WI contain the real and imaginary parts,
          respectively, of the computed eigenvalues of A. The
          eigenvalues will be in the same order that they appear on
          the diagonal of the output real Schur form of A. Complex
          conjugate pairs of eigenvalues will appear consecutively
          with the eigenvalue having the positive imaginary part
          first.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LDWORK >= MAX(1,N)   if JOBA = 'S';
          LDWORK >= MAX(1,3*N) if JOBA = 'G'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0: successful exit;
          < 0: if INFO = -i, the i-th argument had an illegal
               value;
          = 1: the QR algorithm failed to compute all the
               eigenvalues of A;
          = 2: a failure occured during the ordering of the real
               Schur form of A;
          = 3: the separation of the two diagonal blocks failed
               because of very close eigenvalues.
Method 
  A similarity transformation U is determined that reduces the
  system state-matrix A to a block-diagonal form (with two diagonal
  blocks), so that the leading diagonal block of the resulting A has
  eigenvalues in a specified domain of the complex plane. The
  determined transformation is applied to the system (A,B,C) as
    A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U.
References 
  [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N.
      Synthesis of positive real multivariable feedback systems.
      Int. J. Control, pp. 817-842, 1987.
Numerical Aspects 
                                  3
  The algorithm requires about 14N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TB01KD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDU
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      DICO, JOBA, STDOM
      INTEGER          I, INFO, J, M, N, NDIM, P
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01KD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, STDOM, JOBA
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed ssr for (A,B,C).
               CALL TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA,
     $                      B, LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK,
     $                      LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99987 ) NDIM
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I)
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01KD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01KD = ',I2)
99997 FORMAT (/' The eigenvalues of state dynamics matrix A are ')
99996 FORMAT (/' The transformed state dynamics matrix inv(U)*A*U is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT ( ' (',F8.4,', ',F8.4,' )')
99993 FORMAT (/' The transformed input/state matrix inv(U)*B is ')
99992 FORMAT (/' The transformed state/output matrix C*U is ')
99991 FORMAT (/' The similarity transformation matrix U is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (' The number of eigenvalues in the domain of interest =',
     $        I5 )
      END
Program Data 
 TB01KD EXAMPLE PROGRAM DATA (Continuous system)
  5     2     3    -1.0      C     U     G
  -0.04165    4.9200   -4.9200         0         0
 -1.387944   -3.3300         0         0         0
    0.5450         0         0   -0.5450         0
         0         0    4.9200  -0.04165    4.9200
         0         0         0 -1.387944   -3.3300
         0         0
    3.3300         0
         0         0
         0         0
         0    3.3300
     1     0     0     0     0
     0     0     1     0     0
     0     0     0     1     0
Program Results 
 TB01KD EXAMPLE PROGRAM RESULTS

 The number of eigenvalues in the domain of interest =    2

 The eigenvalues of state dynamics matrix A are 
 ( -0.7483,   2.9940 )
 ( -0.7483,  -2.9940 )
 ( -1.6858,   2.0311 )
 ( -1.6858,  -2.0311 )
 ( -1.8751,   0.0000 )

 The transformed state dynamics matrix inv(U)*A*U is 
  -0.7483  -8.6406   0.0000   0.0000   0.0000
   1.0374  -0.7483   0.0000   0.0000   0.0000
   0.0000   0.0000  -1.6858   5.5669   0.0000
   0.0000   0.0000  -0.7411  -1.6858   0.0000
   0.0000   0.0000   0.0000   0.0000  -1.8751

 The transformed input/state matrix inv(U)*B is 
   2.0240  -2.0240
  -1.1309   1.1309
  -0.8621  -0.8621
   2.1912   2.1912
  -1.5555   1.5555

 The transformed state/output matrix C*U is 
   0.6864  -0.0987   0.6580   0.2589   0.9650
  -0.0471   0.6873   0.0000   0.0000  -0.5609
  -0.6864   0.0987   0.6580   0.2589  -0.9650

 The similarity transformation matrix U is 
   0.6864  -0.0987   0.6580   0.2589   0.9650
  -0.1665  -0.5041  -0.2589   0.6580  -0.9205
  -0.0471   0.6873   0.0000   0.0000  -0.5609
  -0.6864   0.0987   0.6580   0.2589  -0.9650
   0.1665   0.5041  -0.2589   0.6580   0.9205

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01LD.html000077500000000000000000000321761201767322700161030ustar00rootroot00000000000000 TB01LD - SLICOT Library Routine Documentation

TB01LD

Orthogonal similarity reduction so that the leading part of system state-matrix has eigenvalues in a specified domain

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the system state matrix A to an ordered upper real
  Schur form by using an orthogonal similarity transformation
  A <-- U'*A*U and to apply the transformation to the matrices
  B and C: B <-- U'*B and C <-- C*U.
  The leading block of the resulting A has eigenvalues in a
  suitably defined domain of interest.
Specification 
      SUBROUTINE TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B,
     $                   LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK,
     $                   LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  DICO    CHARACTER*1
          Specifies the type of the system as follows:
          = 'C':  continuous-time system;
          = 'D':  discrete-time system.

  STDOM   CHARACTER*1
          Specifies whether the domain of interest is of stability
          type (left part of complex plane or inside of a circle)
          or of instability type (right part of complex plane or
          outside of a circle) as follows:
          = 'S':  stability type domain;
          = 'U':  instability type domain.

  JOBA    CHARACTER*1
          Specifies the shape of the state dynamics matrix on entry
          as follows:
          = 'S':  A is in an upper real Schur form;
          = 'G':  A is a general square dense matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation,
          i.e. the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs, or of columns of B.  M >= 0.

  P       (input) INTEGER
          The number of system outputs, or of rows of C.  P >= 0.

  ALPHA   (input) DOUBLE PRECISION.
          Specifies the boundary of the domain of interest for the
          eigenvalues of A. For a continuous-time system
          (DICO = 'C'), ALPHA is the boundary value for the real
          parts of eigenvalues, while for a discrete-time system
          (DICO = 'D'), ALPHA >= 0 represents the boundary value
          for the moduli of eigenvalues.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the unreduced state dynamics matrix A.
          If JOBA = 'S' then A must be a matrix in real Schur form.
          On exit, the leading N-by-N part of this array contains
          the ordered real Schur matrix U' * A * U with the elements
          below the first subdiagonal set to zero.
          The leading NDIM-by-NDIM part of A has eigenvalues in the
          domain of interest and the trailing (N-NDIM)-by-(N-NDIM)
          part has eigenvalues outside the domain of interest.
          The domain of interest for lambda(A), the eigenvalues
          of A, is defined by the parameters ALPHA, DICO and STDOM
          as follows:
          For a continuous-time system (DICO = 'C'):
            Real(lambda(A)) < ALPHA if STDOM = 'S';
            Real(lambda(A)) > ALPHA if STDOM = 'U';
          For a discrete-time system (DICO = 'D'):
            Abs(lambda(A)) < ALPHA if STDOM = 'S';
            Abs(lambda(A)) > ALPHA if STDOM = 'U'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed input matrix U' * B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed output matrix C * U.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  NDIM    (output) INTEGER
          The number of eigenvalues of A lying inside the domain of
          interest for eigenvalues.

  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array contains the
          orthogonal transformation matrix used to reduce A to the
          real Schur form and/or to reorder the diagonal blocks of
          real Schur form of A. The first NDIM columns of U form
          an orthogonal basis for the invariant subspace of A
          corresponding to the first NDIM eigenvalues.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= max(1,N).

  WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
          WR and WI contain the real and imaginary parts,
          respectively, of the computed eigenvalues of A. The
          eigenvalues will be in the same order that they appear on
          the diagonal of the output real Schur form of A. Complex
          conjugate pairs of eigenvalues will appear consecutively
          with the eigenvalue having the positive imaginary part
          first.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.
          LDWORK >= MAX(1,N)   if JOBA = 'S';
          LDWORK >= MAX(1,3*N) if JOBA = 'G'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0: successful exit;
          < 0: if INFO = -i, the i-th argument had an illegal
               value;
          = 1: the QR algorithm failed to compute all the
               eigenvalues of A;
          = 2: a failure occured during the ordering of the real
               Schur form of A.
Method 
  Matrix A is reduced to an ordered upper real Schur form using an
  orthogonal similarity transformation A <-- U'*A*U. This
  transformation is determined so that the leading block of the
  resulting A has eigenvalues in a suitably defined domain of
  interest. Then, the transformation is applied to the matrices B
  and C: B <-- U'*B and C <-- C*U.
Numerical Aspects 
                                  3
  The algorithm requires about 14N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TB01LD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDU
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      DICO, JOBA, STDOM
      INTEGER          I, INFO, J, M, N, NDIM, P
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01LD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, STDOM, JOBA
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed ssr for (A,B,C).
               CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA,
     $                      A, LDA, B, LDB, C, LDC, NDIM, U, LDU,
     $                      WR, WI, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99987 ) NDIM
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I)
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01LD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01LD = ',I2)
99997 FORMAT (/' The eigenvalues of state dynamics matrix A are ')
99996 FORMAT (/' The transformed state dynamics matrix U''*A*U is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT ( ' (',F8.4,', ',F8.4,' )')
99993 FORMAT (/' The transformed input/state matrix U''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*U is ')
99991 FORMAT (/' The similarity transformation matrix U is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The number of eigenvalues in the domain of interest =',
     $        I5 )
      END
Program Data 
 TB01LD EXAMPLE PROGRAM DATA (Continuous system)
  5     2     3    -1.0      C     U     G
  -0.04165    4.9200   -4.9200         0         0
 -1.387944   -3.3300         0         0         0
    0.5450         0         0   -0.5450         0
         0         0    4.9200  -0.04165    4.9200
         0         0         0 -1.387944   -3.3300
         0         0
    3.3300         0
         0         0
         0         0
         0    3.3300
     1     0     0     0     0
     0     0     1     0     0
     0     0     0     1     0
Program Results 
 TB01LD EXAMPLE PROGRAM RESULTS


 The number of eigenvalues in the domain of interest =    2

 The eigenvalues of state dynamics matrix A are 
 ( -0.7483,   2.9940 )
 ( -0.7483,  -2.9940 )
 ( -1.6858,   2.0311 )
 ( -1.6858,  -2.0311 )
 ( -1.8751,   0.0000 )

 The transformed state dynamics matrix U'*A*U is 
  -0.7483  -8.6406   0.0000   0.0000   1.1745
   1.0374  -0.7483   0.0000   0.0000  -2.1164
   0.0000   0.0000  -1.6858   5.5669   0.0000
   0.0000   0.0000  -0.7411  -1.6858   0.0000
   0.0000   0.0000   0.0000   0.0000  -1.8751

 The transformed input/state matrix U'*B is 
  -0.5543   0.5543
  -1.6786   1.6786
  -0.8621  -0.8621
   2.1912   2.1912
  -1.5555   1.5555

 The transformed state/output matrix C*U is 
   0.6864  -0.0987   0.6580   0.2589  -0.1381
  -0.0471   0.6873   0.0000   0.0000  -0.7249
  -0.6864   0.0987   0.6580   0.2589   0.1381

 The similarity transformation matrix U is 
   0.6864  -0.0987   0.6580   0.2589  -0.1381
  -0.1665  -0.5041  -0.2589   0.6580  -0.4671
  -0.0471   0.6873   0.0000   0.0000  -0.7249
  -0.6864   0.0987   0.6580   0.2589   0.1381
   0.1665   0.5041  -0.2589   0.6580   0.4671

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01MD.html000077500000000000000000000247341201767322700161050ustar00rootroot00000000000000 TB01MD - SLICOT Library Routine Documentation

TB01MD

Upper/lower controller Hessenberg form using unitary state-space transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the pair (B,A) to upper or lower controller Hessenberg
  form using (and optionally accumulating) unitary state-space
  transformations.
Specification 
      SUBROUTINE TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU,
     $                   DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOBU    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix U the unitary state-space transformations for
          reducing the system, as follows:
          = 'N':  Do not form U;
          = 'I':  U is initialized to the unit matrix and the
                  unitary transformation matrix U is returned;
          = 'U':  The given matrix U is updated by the unitary
                  transformations used in the reduction.

  UPLO    CHARACTER*1
          Indicates whether the user wishes the pair (B,A) to be
          reduced to upper or lower controller Hessenberg form as
          follows:
          = 'U':  Upper controller Hessenberg form;
          = 'L':  Lower controller Hessenberg form.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e. the order of the
          matrix A.  N >= 0.

  M       (input) INTEGER
          The actual input dimension, i.e. the number of columns of
          the matrix B.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state transition matrix A to be transformed.
          On exit, the leading N-by-N part of this array contains
          the transformed state transition matrix U' * A * U.
          The annihilated elements are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B to be transformed.
          On exit, the leading N-by-M part of this array contains
          the transformed input matrix U' * B.
          The annihilated elements are set to zero.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,*)
          On entry, if JOBU = 'U', then the leading N-by-N part of
          this array must contain a given matrix U (e.g. from a
          previous call to another SLICOT routine), and on exit, the
          leading N-by-N part of this array contains the product of
          the input matrix U and the state-space transformation
          matrix which reduces the given pair to controller
          Hessenberg form.
          On exit, if JOBU = 'I', then the leading N-by-N part of
          this array contains the matrix of accumulated unitary
          similarity transformations which reduces the given pair
          to controller Hessenberg form.
          If JOBU = 'N', the array U is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDU = 1 and
          declare this array to be U(1,1) in the calling program).

  LDU     INTEGER
          The leading dimension of array U. If JOBU = 'U' or
          JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (MAX(N,M-1))
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a unitary state-space transformation U, which
  reduces the pair (B,A) to one of the following controller
  Hessenberg forms:

                 |*  . . .  *|*  . . . . . .  *|
                 |   .      .|.               .|
                 |     .    .|.               .|
                 |       .  .|.               .|
    [U'B|U'AU] = |          *|.               .| N
                 |           |*               .|
                 |           |   .            .|
                 |           |     .          .|
                 |           |       .        .|
                 |           |         * . .  *|
                      M               N

  if UPLO = 'U', or

                 |*  . . *         |           |
                 |.        .       |           |
                 |.          .     |           |
                 |.            .   |           |
    [U'AU|U'B] = |.               *|           | N
                 |.               .|*          |
                 |.               .|.  .       |
                 |.               .|.    .     |
                 |.               .|.      .   |
                 |*  . . . . . .  *|*  . . .  *|
                         N               M
  if UPLO = 'L'.

  IF M >= N, then the matrix U'B is trapezoidal and U'AU is full.
References 
  [1] Van Dooren, P. and Verhaegen, M.H.G.
      On the use of unitary state-space transformations.
      In : Contemporary Mathematics on Linear Algebra and its Role
      in Systems Theory, 47, AMS, Providence, 1985.
Numerical Aspects 
  The algorithm requires O((N + M) x N**2) operations and is
  backward stable (see [1]).
Further Comments 
  None
Example

Program Text 

*     TB01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDU, LDWORK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDU = NMAX,
     $                   LDWORK = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
      CHARACTER*1      JOBU, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), U(LDU,NMAX),
     $                 DWORK(LDWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, JOBU, UPLO
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( LSAME( JOBU, 'U' ) )
     $         READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N )
*           Reduce the pair (B,A) to controller Hessenberg form.
            CALL TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU,
     $                   DWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 60 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   60          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 80 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   80          CONTINUE
               IF ( LSAME( JOBU, 'I' ).OR.LSAME( JOBU, 'U' ) ) THEN
                  WRITE ( NOUT, FMT = 99994 )
                  DO 100 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,N )
  100             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01MD = ',I2)
99997 FORMAT (' The transformed state transition matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The transformed input matrix is ')
99994 FORMAT (/' The transformation matrix that reduces (B,A) to contr',
     $       'oller Hessenberg form is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 TB01MD EXAMPLE PROGRAM DATA
   6     3     N     U
  35.0   1.0   6.0  26.0  19.0  24.0
   3.0  32.0   7.0  21.0  23.0  25.0
  31.0   9.0   2.0  22.0  27.0  20.0
   8.0  28.0  33.0  17.0  10.0  15.0
  30.0   5.0  34.0  12.0  14.0  16.0
   4.0  36.0  29.0  13.0  18.0  11.0
   1.0   5.0  11.0
  -1.0   4.0  11.0
  -5.0   1.0   9.0
 -11.0  -4.0   5.0
 -19.0 -11.0  -1.0
 -29.0 -20.0  -9.0
Program Results 
 TB01MD EXAMPLE PROGRAM RESULTS

 The transformed state transition matrix is 
  60.3649  58.8853   5.0480  -5.4406   2.1382  -7.3870
  54.5832  33.1865  36.5234   6.3272  -3.1377   8.8154
  17.6406  21.4501 -13.5942   0.5417   1.6926   0.0786
  -9.0567  10.7202   0.3531   1.5444  -1.2846  24.6407
   0.0000   6.8796 -20.1372  -2.6440   2.4983 -21.8071
   0.0000   0.0000   0.0000   0.0000   0.0000  27.0000

 The transformed input matrix is 
 -16.8819  -8.8260  13.9202
   0.0000  13.8240  39.9205
   0.0000   0.0000   4.1928
   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01ND.html000077500000000000000000000244201201767322700160760ustar00rootroot00000000000000 TB01ND - SLICOT Library Routine Documentation

TB01ND

Upper/lower observer Hessenberg form using unitary state-space transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the pair (A,C) to lower or upper observer Hessenberg
  form using (and optionally accumulating) unitary state-space
  transformations.
Specification 
      SUBROUTINE TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU,
     $                   DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOBU    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix U the unitary state-space transformations for
          reducing the system, as follows:
          = 'N':  Do not form U;
          = 'I':  U is initialized to the unit matrix and the
                  unitary transformation matrix U is returned;
          = 'U':  The given matrix U is updated by the unitary
                  transformations used in the reduction.

  UPLO    CHARACTER*1
          Indicates whether the user wishes the pair (A,C) to be
          reduced to upper or lower observer Hessenberg form as
          follows:
          = 'U':  Upper observer Hessenberg form;
          = 'L':  Lower observer Hessenberg form.
Input/Output Parameters 
  N       (input) INTEGER
          The actual state dimension, i.e. the order of the
          matrix A.  N >= 0.

  P       (input) INTEGER
          The actual output dimension, i.e. the number of rows of
          the matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state transition matrix A to be transformed.
          On exit, the leading N-by-N part of this array contains
          the transformed state transition matrix U' * A * U.
          The annihilated elements are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C to be transformed.
          On exit, the leading P-by-N part of this array contains
          the transformed output matrix C * U.
          The annihilated elements are set to zero.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  U       (input/output) DOUBLE PRECISION array, dimension (LDU,*)
          On entry, if JOBU = 'U', then the leading N-by-N part of
          this array must contain a given matrix U (e.g. from a
          previous call to another SLICOT routine), and on exit, the
          leading N-by-N part of this array contains the product of
          the input matrix U and the state-space transformation
          matrix which reduces the given pair to observer Hessenberg
          form.
          On exit, if JOBU = 'I', then the leading N-by-N part of
          this array contains the matrix of accumulated unitary
          similarity transformations which reduces the given pair
          to observer Hessenberg form.
          If JOBU = 'N', the array U is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDU = 1 and
          declare this array to be U(1,1) in the calling program).

  LDU     INTEGER
          The leading dimension of array U. If JOBU = 'U' or
          JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (MAX(N,P-1))
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a unitary state-space transformation U, which
  reduces the pair (A,C) to one of the following observer Hessenberg
  forms:

                             N
                    |*  . . . . . .  *|
                    |.               .|
                    |.               .|
                    |.               .| N
                    |*               .|
         |U'AU|     |   .            .|
         |----|  =  |     .          .|
         |CU  |     |       * . . .  *|
                    -------------------
                    |         * . .  *|
                    |           .    .| P
                    |             .  .|
                    |                *|

      if UPLO = 'U', or

                            N
                   |*                |
                   |.  .             |
                   |.    .           | P
                   |*  . . *         |
         |CU  |    -------------------
         |----|  = |*  . . . *       |
         |U'AU|    |.          .     |
                   |.            .   |
                   |.               *|
                   |.               .| N
                   |.               .|
                   |.               .|
                   |*  . . . . . .  *|

  if UPLO = 'L'.

  If P >= N, then the matrix CU is trapezoidal and U'AU is full.
References 
  [1] Van Dooren, P. and Verhaegen, M.H.G.
      On the use of unitary state-space transformations.
      In : Contemporary Mathematics on Linear Algebra and its Role
      in Systems Theory, 47, AMS, Providence, 1985.
Numerical Aspects 
  The algorithm requires O((N + P) x N**2) operations and is
  backward stable (see [1]).
Further Comments 
  None
Example

Program Text 

*     TB01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, PMAX
      PARAMETER        ( NMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDC, LDU, LDWORK
      PARAMETER        ( LDA = NMAX, LDC = PMAX, LDU = NMAX,
     $                   LDWORK = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N, P
      CHARACTER*1      JOBU, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), U(LDU,NMAX),
     $                 DWORK(LDWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, P, JOBU, UPLO
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) P
         ELSE
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
            IF ( LSAME( JOBU, 'U' ) )
     $         READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N )
*           Reduce the pair (A,C) to observer Hessenberg form.
            CALL TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU,
     $                   DWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 60 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   60          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 80 I = 1, P
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   80          CONTINUE
               IF ( LSAME( JOBU, 'I' ).OR.LSAME( JOBU, 'U' ) ) THEN
                  WRITE ( NOUT, FMT = 99994 )
                  DO 100 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,N )
  100             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01ND = ',I2)
99997 FORMAT (' The transformed state transition matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The transformed output matrix is ')
99994 FORMAT (/' The transformation matrix that reduces (A,C) to obser',
     $       'ver Hessenberg form is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB01ND EXAMPLE PROGRAM DATA
   5     3     N     U
  15.0  21.0  -3.0   3.0   9.0
  20.0   1.0   2.0   8.0   9.0
   4.0   1.0   7.0  13.0  14.0
   5.0   6.0  12.0  13.0  -6.0
   5.0  11.0  17.0  -7.0  -1.0
   7.0  -1.0   3.0  -6.0  -3.0
   4.0   5.0   6.0  -2.0  -3.0
   9.0   8.0   5.0   2.0   1.0
Program Results 
 TB01ND EXAMPLE PROGRAM RESULTS

 The transformed state transition matrix is 
   7.1637  -0.9691 -16.5046   0.2869   0.9205
  -2.3285  11.5431  -8.7471   3.4122  -3.7118
 -10.5440  -7.6032  -0.3215   3.6571  -0.4335
  -3.6845   5.6449   0.5906 -15.6996  17.4267
   0.0000  -6.4260   1.5591  14.4317  32.3143

 The transformed output matrix is 
   0.0000   0.0000   7.6585   5.2973  -4.1576
   0.0000   0.0000   0.0000   5.8305  -7.4837
   0.0000   0.0000   0.0000   0.0000 -13.2288

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01PD.html000077500000000000000000000275541201767322700161130ustar00rootroot00000000000000 TB01PD - SLICOT Library Routine Documentation

TB01PD

Minimal, controllable or observable block Hessenberg realization for a given state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a reduced (controllable, observable, or minimal) state-
  space representation (Ar,Br,Cr) for any original state-space
  representation (A,B,C). The matrix Ar is in upper block
  Hessenberg form.
Specification 
      SUBROUTINE TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC,
     $                   NR, TOL, IWORK, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates whether the user wishes to remove the
          uncontrollable and/or unobservable parts as follows:
          = 'M':  Remove both the uncontrollable and unobservable
                  parts to get a minimal state-space representation;
          = 'C':  Remove the uncontrollable part only to get a
                  controllable state-space representation;
          = 'O':  Remove the unobservable part only to get an
                  observable state-space representation.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily balance
          the triplet (A,B,C) as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation, i.e.
          the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.   P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading NR-by-NR part of this array contains
          the upper block Hessenberg state dynamics matrix Ar of a
          minimal, controllable, or observable realization for the
          original system, depending on the value of JOB, JOB = 'M',
          JOB = 'C', or JOB = 'O', respectively.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M),
          if JOB = 'C', or (LDB,MAX(M,P)), otherwise.
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B; if JOB = 'M',
          or JOB = 'O', the remainder of the leading N-by-MAX(M,P)
          part is used as internal workspace.
          On exit, the leading NR-by-M part of this array contains
          the transformed input/state matrix Br of a minimal,
          controllable, or observable realization for the original
          system, depending on the value of JOB, JOB = 'M',
          JOB = 'C', or JOB = 'O', respectively.
          If JOB = 'C', only the first IWORK(1) rows of B are
          nonzero.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C; if JOB = 'M',
          or JOB = 'O', the remainder of the leading MAX(M,P)-by-N
          part is used as internal workspace.
          On exit, the leading P-by-NR part of this array contains
          the transformed state/output matrix Cr of a minimal,
          controllable, or observable realization for the original
          system, depending on the value of JOB, JOB = 'M',
          JOB = 'C', or JOB = 'O', respectively.
          If JOB = 'M', or JOB = 'O', only the last IWORK(1) columns
          (in the first NR columns) of C are nonzero.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,M,P) if N > 0.
          LDC >= 1          if N = 0.

  NR      (output) INTEGER
          The order of the reduced state-space representation
          (Ar,Br,Cr) of a minimal, controllable, or observable
          realization for the original system, depending on
          JOB = 'M', JOB = 'C', or JOB = 'O'.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B, C). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance
          (determined by the SLICOT routine TB01UD) is used instead.
Workspace 
  IWORK   INTEGER array, dimension (N+MAX(M,P))
          On exit, if INFO = 0, the first nonzero elements of
          IWORK(1:N) return the orders of the diagonal blocks of A.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  If JOB = 'M', the matrices A and B are operated on by orthogonal
  similarity transformations (made up of products of Householder
  transformations) so as to produce an upper block Hessenberg matrix
  A1 and a matrix B1 with all but its first rank(B) rows zero; this
  separates out the controllable part of the original system.
  Applying the same algorithm to the dual of this subsystem,
  therefore separates out the controllable and observable (i.e.
  minimal) part of the original system representation, with the
  final Ar upper block Hessenberg (after using pertransposition).
  If JOB = 'C', or JOB = 'O', only the corresponding part of the
  above procedure is applied.
References 
  [1] Van Dooren, P.
      The Generalized Eigenstructure Problem in Linear System
      Theory. (Algorithm 1)
      IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  None
Example

Program Text 

*     TB01PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MAXMP )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX+MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX+MAX( NMAX, 3*MAXMP ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, NR, P
      CHARACTER        JOB, EQUIL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 DWORK(LDWORK)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         TB01PD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOB, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find a minimal ssr for (A,B,C).
               CALL TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC,
     $                      NR, TOL, IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01PD = ',I2)
99997 FORMAT (' The order of the minimal realization = ',I2)
99996 FORMAT (/' The transformed state dynamics matrix of a minimal re',
     $       'alization is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The transformed input/state matrix of a minimal reali',
     $       'zation is ')
99992 FORMAT (/' The transformed state/output matrix of a minimal real',
     $       'ization is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB01PD EXAMPLE PROGRAM DATA
   3     1     2     0.0     M     N
   1.0   2.0   0.0
   4.0  -1.0   0.0
   0.0   0.0   1.0
   1.0   0.0   1.0
   0.0   1.0  -1.0
   0.0   0.0   1.0
Program Results 
 TB01PD EXAMPLE PROGRAM RESULTS

 The order of the minimal realization =  3

 The transformed state dynamics matrix of a minimal realization is 
   1.0000  -1.4142   1.4142
  -2.8284   0.0000   1.0000
   2.8284   1.0000   0.0000

 The transformed input/state matrix of a minimal realization is 
  -1.0000
   0.7071
   0.7071

 The transformed state/output matrix of a minimal realization is 
   0.0000   0.0000  -1.4142
   0.0000   0.7071   0.7071

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01TD.html000077500000000000000000000266101201767322700161070ustar00rootroot00000000000000 TB01TD - SLICOT Library Routine Documentation

TB01TD

Balancing state-space representation by permutations and scalings

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce a given state-space representation (A,B,C,D) to
  balanced form by means of state permutations and state, input and
  output scalings.
Specification 
      SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW,
     $                   IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the state-space representation, i.e. the
          order of the original state dynamics matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading N-by-N part of this array contains
          the balanced state dynamics matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, the leading N-by-M part of this array contains
          the balanced input/state matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the balanced state/output matrix C.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
          On entry, the leading P-by-M part of this array must
          contain the original direct transmission matrix D.
          On exit, the leading P-by-M part of this array contains
          the scaled direct transmission matrix D.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  LOW     (output) INTEGER
          The index of the lower end of the balanced submatrix of A.

  IGH     (output) INTEGER
          The index of the upper end of the balanced submatrix of A.

  SCSTAT  (output) DOUBLE PRECISION array, dimension (N)
          This array contains the information defining the
          similarity transformations used to permute and balance
          the state dynamics matrix A, as returned from the LAPACK
          library routine DGEBAL.

  SCIN    (output) DOUBLE PRECISION array, dimension (M)
          Contains the scalars used to scale the system inputs so
          that the columns of the final matrix B have norms roughly
          equal to the column sums of the balanced matrix A
          (see FURTHER COMMENTS).
          The j-th input of the balanced state-space representation
          is SCIN(j)*(j-th column of the permuted and balanced
          input/state matrix B).

  SCOUT   (output) DOUBLE PRECISION array, dimension (P)
          Contains the scalars used to scale the system outputs so
          that the rows of the final matrix C have norms roughly
          equal to the row sum of the balanced matrix A.
          The i-th output of the balanced state-space representation
          is SCOUT(i)*(i-th row of the permuted and balanced
          state/ouput matrix C).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Similarity transformations are used to permute the system states
  and balance the corresponding row and column sum norms of a
  submatrix of the state dynamics matrix A. These operations are
  also applied to the input/state matrix B and the system inputs
  are then scaled (see parameter SCIN) so that the columns of the
  final matrix B have norms roughly equal to the column sum norm of
  the balanced matrix A (see FURTHER COMMENTS).
  The above operations are also applied to the matrix C, and the
  system outputs are then scaled (see parameter SCOUT) so that the
  rows of the final matrix C have norms roughly equal to the row sum
  norm of the balanced matrix A (see FURTHER COMMENTS).
  Finally, the (I,J)-th element of the direct transmission matrix D
  is scaled as
       D(I,J) = D(I,J)*(1.0/SCIN(J))*SCOUT(I), where I = 1,2,...,P
  and J = 1,2,...,M.

  Scaling performed to balance the row/column sum norms is by
  integer powers of the machine base so as to avoid introducing
  rounding errors.
References 
  [1] Wilkinson, J.H. and Reinsch, C.
      Handbook for Automatic Computation, (Vol II, Linear Algebra).
      Springer-Verlag, 1971, (contribution II/11).
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  The columns (rows) of the final matrix B (matrix C) have norms
  'roughly' equal to the column (row) sum norm of the balanced
  matrix A, i.e.
     size/BASE < abssum <= size
  where
     BASE   = the base of the arithmetic used on the computer, which
              can be obtained from the LAPACK Library routine
              DLAMCH;

     size   = column or row sum norm of the balanced matrix A;
     abssum = column sum norm of the balanced matrix B or row sum
              norm of the balanced matrix C.

  The routine is BASE dependent.
Example

Program Text 

*     TB01TD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, IGH, J, LOW, M, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(NMAX), SCIN(MMAX),
     $                 SCOUT(PMAX), SCSTAT(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01TD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99990 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99989 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Balance the state-space representation (A,B,C,D).
               CALL TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                      LOW, IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) LOW, IGH
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
   80             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01TD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01TD = ',I2)
99997 FORMAT (' LOW = ',I2,'   IGH = ',I2,/)
99996 FORMAT (' The balanced state dynamics matrix A is ')
99995 FORMAT (20(1X,F9.4))
99994 FORMAT (/' The balanced input/state matrix B is ')
99993 FORMAT (/' The balanced state/output matrix C is ')
99992 FORMAT (/' The scaled direct transmission matrix D is ')
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' M is out of range.',/' M = ',I5)
99989 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB01TD EXAMPLE PROGRAM DATA
   5     2     2
   0.0   0.0   1.0   4.0   5.0
  50.0  10.0   1.0   0.0   0.0
   0.0   0.0  90.0  10.0   0.0
   0.0   1.0   1.0   1.0   1.0
 100.0   0.0   0.0   0.0  70.0
   0.0   2.0   0.0   1.0   2.0
   0.0  20.0 100.0   1.0   0.0
   1.0   0.0   0.0   1.0   0.0
   1.0   1.0   0.0   2.0   1.0
   1.0   1.0   1.0   1.0
Program Results 
 TB01TD EXAMPLE PROGRAM RESULTS

 LOW =  1   IGH =  5

 The balanced state dynamics matrix A is 
    0.0000    0.0000    1.0000    4.0000   40.0000
    6.2500   10.0000    0.1250    0.0000    0.0000
    0.0000    0.0000   90.0000   10.0000    0.0000
    0.0000    8.0000    1.0000    1.0000    8.0000
   12.5000    0.0000    0.0000    0.0000   70.0000

 The balanced input/state matrix B is 
    0.0000    0.0000
   16.0000    2.5000
    0.0000  100.0000
   64.0000    1.0000
   16.0000    0.0000

 The balanced state/output matrix C is 
   32.0000    0.0000    0.0000   32.0000    0.0000
    4.0000   32.0000    0.0000    8.0000   32.0000

 The scaled direct transmission matrix D is 
 2048.0000   32.0000
  256.0000    4.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01UD.html000077500000000000000000000363631201767322700161160ustar00rootroot00000000000000 TB01UD - SLICOT Library Routine Documentation

TB01UD

Controllable block Hessenberg realization for a given state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a controllable realization for the linear time-invariant
  multi-input system

          dX/dt = A * X + B * U,
             Y  = C * X,

  where A, B, and C are N-by-N, N-by-M, and P-by-N matrices,
  respectively, and A and B are reduced by this routine to
  orthogonal canonical form using (and optionally accumulating)
  orthogonal similarity transformations, which are also applied
  to C.  Specifically, the system (A, B, C) is reduced to the
  triplet (Ac, Bc, Cc), where Ac = Z' * A * Z, Bc = Z' * B,
  Cc = C * Z,  with

          [ Acont     *    ]         [ Bcont ]
     Ac = [                ],   Bc = [       ],
          [   0    Auncont ]         [   0   ]

     and

             [ A11 A12  . . .  A1,p-1 A1p ]         [ B1 ]
             [ A21 A22  . . .  A2,p-1 A2p ]         [ 0  ]
             [  0  A32  . . .  A3,p-1 A3p ]         [ 0  ]
     Acont = [  .   .   . . .    .     .  ],   Bc = [ .  ],
             [  .   .     . .    .     .  ]         [ .  ]
             [  .   .       .    .     .  ]         [ .  ]
             [  0   0   . . .  Ap,p-1 App ]         [ 0  ]

  where the blocks  B1, A21, ..., Ap,p-1  have full row ranks and
  p is the controllability index of the pair.  The size of the
  block  Auncont is equal to the dimension of the uncontrollable
  subspace of the pair (A, B).
Specification 
      SUBROUTINE TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, NCONT,
     $                   INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  JOBZ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Z the orthogonal similarity transformations for
          reducing the system, as follows:
          = 'N':  Do not form Z and do not store the orthogonal
                  transformations;
          = 'F':  Do not form Z, but store the orthogonal
                  transformations in the factored form;
          = 'I':  Z is initialized to the unit matrix and the
                  orthogonal transformation matrix Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e. the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs, or of columns of B.  M >= 0.

  P       (input) INTEGER
          The number of system outputs, or of rows of C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading NCONT-by-NCONT part contains the
          upper block Hessenberg state dynamics matrix Acont in Ac,
          given by Z' * A * Z, of a controllable realization for
          the original system. The elements below the first block-
          subdiagonal are set to zero. The leading N-by-N part
          contains the matrix Ac.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the leading NCONT-by-M part of this array
          contains the transformed input matrix Bcont in Bc, given
          by Z' * B, with all elements but the first block set to
          zero. The leading N-by-M part contains the matrix Bc.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed output matrix Cc, given by C * Z.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  NCONT   (output) INTEGER
          The order of the controllable state-space representation.

  INDCON  (output) INTEGER
          The controllability index of the controllable part of the
          system representation.

  NBLK    (output) INTEGER array, dimension (N)
          The leading INDCON elements of this array contain the
          the orders of the diagonal blocks of Acont.

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          If JOBZ = 'I', then the leading N-by-N part of this
          array contains the matrix of accumulated orthogonal
          similarity transformations which reduces the given system
          to orthogonal canonical form.
          If JOBZ = 'F', the elements below the diagonal, with the
          array TAU, represent the orthogonal transformation matrix
          as a product of elementary reflectors. The transformation
          matrix can then be obtained by calling the LAPACK Library
          routine DORGQR.
          If JOBZ = 'N', the array Z is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDZ = 1 and
          declare this array to be Z(1,1) in the calling program).

  LDZ     INTEGER
          The leading dimension of array Z. If JOBZ = 'I' or
          JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The elements of TAU contain the scalar factors of the
          elementary reflectors used in the reduction of B and A.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
          is the machine precision (see LAPACK Library routine
          DLAMCH).
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N, 3*M, P).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Matrix B is first QR-decomposed and the appropriate orthogonal
  similarity transformation applied to the matrix A. Leaving the
  first rank(B) states unchanged, the remaining lower left block
  of A is then QR-decomposed and the new orthogonal matrix, Q1,
  is also applied to the right of A to complete the similarity
  transformation. By continuing in this manner, a completely
  controllable state-space pair (Acont, Bcont) is found for the
  given (A, B), where Acont is upper block Hessenberg with each
  subdiagonal block of full row rank, and Bcont is zero apart from
  its (independent) first rank(B) rows.
  All orthogonal transformations determined in this process are also
  applied to the matrix C, from the right.
  NOTE that the system controllability indices are easily
  calculated from the dimensions of the blocks of Acont.
References 
  [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D.
      Orthogonal Invariants and Canonical Forms for Linear
      Controllable Systems.
      Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981.

  [2] Paige, C.C.
      Properties of numerical algorithms related to computing
      controllablity.
      IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981.

  [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and
      Postlethwaite, I.
      Optimal Pole Assignment Design of Linear Multi-Input Systems.
      Leicester University, Report 99-11, May 1996.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  If the system matrices A and B are badly scaled, it would be
  useful to scale them with SLICOT routine TB01ID, before calling
  the routine.
Example

Program Text 

*     TB01UD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDZ = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX, 3*MMAX, PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, INDCON, J, M, N, NCONT, P
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), TAU(NMAX), Z(LDZ,NMAX)
      INTEGER          IWORK(LIWORK), NBLK(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB01UD, DORGQR
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBZ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find a controllable ssr for the given system.
               CALL TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC,
     $                      NCONT, INDCON, NBLK, Z, LDZ, TAU, TOL,
     $                      IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NCONT
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NCONT
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCONT )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99994 ) ( NBLK(I), I = 1,INDCON )
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NCONT
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99987 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NCONT )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99992 ) INDCON
                  IF ( LSAME( JOBZ, 'F' ) )
     $               CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK,
     $                            INFO )
                  IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN
                     WRITE ( NOUT, FMT = 99991 )
                     DO 80 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   80                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01UD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01UD = ',I2)
99997 FORMAT (' The order of the controllable state-space representati',
     $       'on = ',I2)
99996 FORMAT (/' The transformed state dynamics matrix of a controllab',
     $       'le realization is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' and the dimensions of its diagonal blocks are ',
     $       /20(1X,I2))
99993 FORMAT (/' The transformed input/state matrix B of a controllabl',
     $       'e realization is ')
99992 FORMAT (/' The controllability index of the transformed system r',
     $       'epresentation = ',I2)
99991 FORMAT (/' The similarity transformation matrix Z is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The transformed output/state matrix C of a controlla',
     $       'ble realization is ')
      END
Program Data 
 TB01UD EXAMPLE PROGRAM DATA
   3     2     2     0.0     I
  -1.0   0.0   0.0
  -2.0  -2.0  -2.0
  -1.0   0.0  -3.0
   1.0   0.0   0.0
   0.0   2.0   1.0
   0.0   2.0   1.0
   1.0   0.0   0.0
Program Results 
 TB01UD EXAMPLE PROGRAM RESULTS

 The order of the controllable state-space representation =  2

 The transformed state dynamics matrix of a controllable realization is 
  -3.0000   2.2361
   0.0000  -1.0000

 and the dimensions of its diagonal blocks are 
  2

 The transformed input/state matrix B of a controllable realization is 
   0.0000  -2.2361
   1.0000   0.0000

 The transformed output/state matrix C of a controllable realization is 
  -2.2361   0.0000
   0.0000   1.0000

 The controllability index of the transformed system representation =  1

 The similarity transformation matrix Z is 
   0.0000   1.0000   0.0000
  -0.8944   0.0000  -0.4472
  -0.4472   0.0000   0.8944

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01VD.html000077500000000000000000000161431201767322700161110ustar00rootroot00000000000000 TB01VD - SLICOT Library Routine Documentation

TB01VD

Conversion of a linear discrete-time system into the output normal form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To convert the linear discrete-time system given as (A, B, C, D),
  with initial state x0, into the output normal form [1], with
  parameter vector THETA. The matrix A is assumed to be stable.
  The matrices A, B, C, D and the vector x0 are converted, so that
  on exit they correspond to the system defined by THETA.
Specification 
      SUBROUTINE TB01VD( APPLY, N, M, L, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   X0, THETA, LTHETA, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  APPLY   CHARACTER*1
          Specifies whether or not the parameter vector should be
          transformed using a bijective mapping, as follows:
          = 'A' : apply the bijective mapping to the N vectors in
                  THETA corresponding to the matrices A and C;
          = 'N' : do not apply the bijective mapping.
          The transformation performed when APPLY = 'A' allows
          to get rid of the constraints norm(THETAi) < 1, i = 1:N.
          A call of the SLICOT Library routine TB01VY associated to
          a call of TB01VD must use the same value of APPLY.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state matrix A, assumed to be stable.
          On exit, the leading N-by-N part of this array contains
          the transformed system state matrix corresponding to the
          output normal form with parameter vector THETA.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the system input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed system input matrix corresponding to the
          output normal form with parameter vector THETA.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading L-by-N part of this array must
          contain the system output matrix C.
          On exit, the leading L-by-N part of this array contains
          the transformed system output matrix corresponding to the
          output normal form with parameter vector THETA.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,L).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading L-by-M part of this array must contain the
          system input/output matrix D.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,L).

  X0      (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the initial state of the
          system, x0.
          On exit, this array contains the transformed initial state
          of the system, corresponding to the output normal form
          with parameter vector THETA.

  THETA   (output) DOUBLE PRECISION array, dimension (LTHETA)
          The leading N*(L+M+1)+L*M part of this array contains the
          parameter vector that defines a system (A, B, C, D, x0)
          which is equivalent up to a similarity transformation to
          the system given on entry. The parameters are:

          THETA(1:N*L)                      : parameters for A, C;
          THETA(N*L+1:N*(L+M))              : parameters for B;
          THETA(N*(L+M)+1:N*(L+M)+L*M)      : parameters for D;
          THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0.

  LTHETA  INTEGER
          The length of array THETA.  LTHETA >= N*(L+M+1)+L*M.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N*N*L + N*L + N,
                        N*N + MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L),
                                  N*M)).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the Lyapunov equation A'*Q*A - Q = -scale^2*C'*C
                could only be solved with scale = 0;
          = 2:  if matrix A is not discrete-time stable;
          = 3:  if the QR algorithm failed to converge for
                matrix A.
Method 
  The matrices A and C are converted to output normal form.
  First, the Lyapunov equation

     A'*Q*A - Q = -scale^2*C'*C,

  is solved in the Cholesky factor T, T'*T = Q, and then T is used
  to get the transformation matrix.

  The matrix B and the initial state x0 are transformed accordingly.

  Then, the QR factorization of the transposed observability matrix
  is computed, and the matrix Q is used to further transform the
  system matrices. The parameters characterizing A and C are finally
  obtained by applying a set of N orthogonal transformations.
References 
  [1] Peeters, R.L.M., Hanzon, B., and Olivi, M.
      Balanced realizations of discrete-time stable all-pass
      systems and the tangential Schur algorithm.
      Proceedings of the European Control Conference,
      31 August - 3 September 1999, Karlsruhe, Germany.
      Session CP-6, Discrete-time Systems, 1999.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB01VY.html000077500000000000000000000121761201767322700161400ustar00rootroot00000000000000 TB01VY - SLICOT Library Routine Documentation

TB01VY

Conversion of the output normal form to a state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To convert the linear discrete-time system given as its output
  normal form [1], with parameter vector THETA, into the state-space
  representation (A, B, C, D), with the initial state x0.
Specification 
      SUBROUTINE TB01VY( APPLY, N, M, L, THETA, LTHETA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, X0, DWORK, LDWORK, INFO )
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(*)
Arguments

Mode Parameters 

  APPLY   CHARACTER*1
          Specifies whether or not the parameter vector should be
          transformed using a bijective mapping, as follows:
          = 'A' : apply the bijective mapping to the N vectors in
                  THETA corresponding to the matrices A and C;
          = 'N' : do not apply the bijective mapping.
          The transformation performed when APPLY = 'A' allows
          to get rid of the constraints norm(THETAi) < 1, i = 1:N.
          A call of the SLICOT Library routine TB01VD associated to
          a call of TB01VY must use the same value of APPLY.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  L       (input) INTEGER
          The number of system outputs.  L >= 0.

  THETA   (input) DOUBLE PRECISION array, dimension (LTHETA)
          The leading N*(L+M+1)+L*M part of this array must contain
          the parameter vector that defines a system (A, B, C, D),
          with the initial state x0. The parameters are:

          THETA(1:N*L)                      : parameters for A, C;
          THETA(N*L+1:N*(L+M))              : parameters for B;
          THETA(N*(L+M)+1:N*(L+M)+L*M)      : parameters for D;
          THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0.

  LTHETA  INTEGER
          The length of array THETA.  LTHETA >= N*(L+M+1)+L*M.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the system
          state matrix corresponding to the output normal form with
          parameter vector THETA.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (output) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array contains the system
          input matrix corresponding to the output normal form with
          parameter vector THETA.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          The leading L-by-N part of this array contains the system
          output matrix corresponding to the output normal form with
          parameter vector THETA.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,L).

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          The leading L-by-M part of this array contains the system
          input/output matrix corresponding to the output normal
          form with parameter vector THETA.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,L).

  X0      (output) DOUBLE PRECISION array, dimension (N)
          This array contains the initial state of the system, x0,
          corresponding to the output normal form with parameter
          vector THETA.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= N*(N+L+1).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The parameters characterizing A and C are used to build N
  orthogonal transformations, which are then applied to recover
  these matrices.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB01WD.html000077500000000000000000000251151201767322700161110ustar00rootroot00000000000000 TB01WD - SLICOT Library Routine Documentation

TB01WD

Orthogonal similarity transformation of system state-matrix to real Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the system state matrix A to an upper real Schur form
  by using an orthogonal similarity transformation A <-- U'*A*U and
  to apply the transformation to the matrices B and C: B <-- U'*B
  and C <-- C*U.
Specification 
      SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU,
     $                   WR, WI, DWORK, LDWORK, INFO )
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(*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the original state-space representation,
          i.e. the order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs, or of columns of B.  M >= 0.

  P       (input) INTEGER
          The number of system outputs, or of rows of C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading N-by-N part of this array contains
          the matrix U' * A * U in real Schur form. The elements
          below the first subdiagonal are set to zero.
          Note:  A matrix is in real Schur form if it is upper
                 quasi-triangular with 1-by-1 and 2-by-2 blocks.
                 2-by-2 blocks are standardized in the form
                          [  a  b  ]
                          [  c  a  ]
                 where b*c < 0. The eigenvalues of such a block
                 are a +- sqrt(bc).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed input matrix U' * B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed output matrix C * U.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
          The leading N-by-N part of this array contains the
          orthogonal transformation matrix used to reduce A to the
          real Schur form. The columns of U are the Schur vectors of
          matrix A.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= max(1,N).

  WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
          WR and WI contain the real and imaginary parts,
          respectively, of the computed eigenvalues of A. The
          eigenvalues will be in the same order that they appear on
          the diagonal of the output real Schur form of A. Complex
          conjugate pairs of eigenvalues will appear consecutively
          with the eigenvalue having the positive imaginary part
          first.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.  LWORK >= 3*N.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, the QR algorithm failed to compute
                all the eigenvalues; elements i+1:N of WR and WI
                contain those eigenvalues which have converged;
                U contains the matrix which reduces A to its
                partially converged Schur form.
Method 
  Matrix A is reduced to a real Schur form using an orthogonal
  similarity transformation A <- U'*A*U. Then, the transformation
  is applied to the matrices B and C: B <-- U'*B and C <-- C*U.
Numerical Aspects 
                                  3
  The algorithm requires about 10N  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TB01WD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDU
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX)
*     .. External Subroutines ..
      EXTERNAL         TB01WD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed ssr for (A,B,C).
               CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU,
     $                      WR, WI, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I)
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N )
   70             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01WD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01WD = ',I2)
99997 FORMAT (' The eigenvalues of state dynamics matrix A are ')
99996 FORMAT (/' The transformed state dynamics matrix U''*A*U is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT ( ' (',F8.4,', ',F8.4,' )')
99993 FORMAT (/' The transformed input/state matrix U''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*U is ')
99991 FORMAT (/' The similarity transformation matrix U is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB01WD EXAMPLE PROGRAM DATA (Continuous system)
  5  2   3    
  -0.04165    4.9200   -4.9200         0         0
 -1.387944   -3.3300         0         0         0
    0.5450         0         0   -0.5450         0
         0         0    4.9200  -0.04165    4.9200
         0         0         0 -1.387944   -3.3300
         0         0
    3.3300         0
         0         0
         0         0
         0    3.3300
     1     0     0     0     0
     0     0     1     0     0
     0     0     0     1     0
Program Results 
 TB01WD EXAMPLE PROGRAM RESULTS

 The eigenvalues of state dynamics matrix A are 
 ( -0.7483,   2.9940 )
 ( -0.7483,  -2.9940 )
 ( -1.6858,   2.0311 )
 ( -1.6858,  -2.0311 )
 ( -1.8751,   0.0000 )

 The transformed state dynamics matrix U'*A*U is 
  -0.7483  -8.6406   0.0000   0.0000   1.1745
   1.0374  -0.7483   0.0000   0.0000  -2.1164
   0.0000   0.0000  -1.6858   5.5669   0.0000
   0.0000   0.0000  -0.7411  -1.6858   0.0000
   0.0000   0.0000   0.0000   0.0000  -1.8751

 The transformed input/state matrix U'*B is 
  -0.5543   0.5543
  -1.6786   1.6786
  -0.8621  -0.8621
   2.1912   2.1912
  -1.5555   1.5555

 The transformed state/output matrix C*U is 
   0.6864  -0.0987   0.6580   0.2589  -0.1381
  -0.0471   0.6873   0.0000   0.0000  -0.7249
  -0.6864   0.0987   0.6580   0.2589   0.1381

 The similarity transformation matrix U is 
   0.6864  -0.0987   0.6580   0.2589  -0.1381
  -0.1665  -0.5041  -0.2589   0.6580  -0.4671
  -0.0471   0.6873   0.0000   0.0000  -0.7249
  -0.6864   0.0987   0.6580   0.2589   0.1381
   0.1665   0.5041  -0.2589   0.6580   0.4671

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB01XD.html000077500000000000000000000122071201767322700161100ustar00rootroot00000000000000 TB01XD - SLICOT Library Routine Documentation

TB01XD

Special similarity transformation of the dual state-space system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply a special transformation to a system given as a triple
  (A,B,C),

     A <-- P * A' * P,  B <-- P * C',  C <-- B' * P,

  where P is a matrix with 1 on the secondary diagonal, and with 0
  in the other entries. Matrix A can be specified as a band matrix.
  Optionally, matrix D of the system can be transposed. This
  transformation is actually a special similarity transformation of
  the dual system.
Specification 
      SUBROUTINE TB01XD( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, INFO )
C     .. Scalar Arguments ..
      CHARACTER          JOBD
      INTEGER            INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * )
Arguments

Mode Parameters 

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A, the number of rows of matrix B
          and the number of columns of matrix C.
          N represents the dimension of the state vector.  N >= 0.

  M       (input) INTEGER.
          The number of columns of matrix B.
          M represents the dimension of input vector.  M >= 0.

  P       (input) INTEGER.
          The number of rows of matrix C.
          P represents the dimension of output vector.  P >= 0.

  KL      (input) INTEGER
          The number of subdiagonals of A to be transformed.
          MAX( 0, N-1 ) >= KL >= 0.

  KU      (input) INTEGER
          The number of superdiagonals of A to be transformed.
          MAX( 0, N-1 ) >= KU >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state matrix A.
          On exit, the leading N-by-N part of this array contains
          the transformed (pertransposed) matrix P*A'*P.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,MAX(M,P))
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, the leading N-by-P part of this array contains
          the dual input/state matrix P*C'.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N) if M > 0 or  P > 0.
          LDB >= 1        if M = 0 and P = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, the leading M-by-N part of this array contains
          the dual state/output matrix B'*P.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,M,P) if N > 0.
          LDC >= 1          if N = 0.

  D       (input/output) DOUBLE PRECISION array, dimension
          (LDD,MAX(M,P))
          On entry, if JOBD = 'D', the leading P-by-M part of this
          array must contain the original direct transmission
          matrix D.
          On exit, if JOBD = 'D', the leading M-by-P part of this
          array contains the transposed direct transmission matrix
          D'. The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,M,P) if JOBD = 'D'.
          LDD >= 1          if JOBD = 'Z'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The rows and/or columns of the matrices of the triplet (A,B,C)
  and, optionally, of the matrix D are swapped in a special way.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB01XZ.html000077500000000000000000000121521201767322700161350ustar00rootroot00000000000000 TB01XZ - SLICOT Library Routine Documentation

TB01XZ

Special similarity transformation of the dual state-space system (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply a special transformation to a system given as a triple
  (A,B,C),

     A <-- P * A' * P,  B <-- P * C',  C <-- B' * P,

  where P is a matrix with 1 on the secondary diagonal, and with 0
  in the other entries. Matrix A can be specified as a band matrix.
  Optionally, matrix D of the system can be transposed. This
  transformation is actually a special similarity transformation of
  the dual system.
Specification 
      SUBROUTINE TB01XZ( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, INFO )
C     .. Scalar Arguments ..
      CHARACTER          JOBD
      INTEGER            INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * )
Arguments

Mode Parameters 

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state space model:
          = 'D':  D is present;
          = 'Z':  D is assumed a zero matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A, the number of rows of matrix B
          and the number of columns of matrix C.
          N represents the dimension of the state vector.  N >= 0.

  M       (input) INTEGER.
          The number of columns of matrix B.
          M represents the dimension of input vector.  M >= 0.

  P       (input) INTEGER.
          The number of rows of matrix C.
          P represents the dimension of output vector.  P >= 0.

  KL      (input) INTEGER
          The number of subdiagonals of A to be transformed.
          MAX( 0, N-1 ) >= KL >= 0.

  KU      (input) INTEGER
          The number of superdiagonals of A to be transformed.
          MAX( 0, N-1 ) >= KU >= 0.

  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state matrix A.
          On exit, the leading N-by-N part of this array contains
          the transformed (pertransposed) matrix P*A'*P.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) COMPLEX*16 array, dimension (LDB,MAX(M,P))
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B.
          On exit, the leading N-by-P part of this array contains
          the dual input/state matrix P*C'.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N) if M > 0 or  P > 0.
          LDB >= 1        if M = 0 and P = 0.

  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C.
          On exit, the leading M-by-N part of this array contains
          the dual state/output matrix B'*P.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,M,P) if N > 0.
          LDC >= 1          if N = 0.

  D       (input/output) COMPLEX*16 array, dimension (LDD,MAX(M,P))
          On entry, if JOBD = 'D', the leading P-by-M part of this
          array must contain the original direct transmission
          matrix D.
          On exit, if JOBD = 'D', the leading M-by-P part of this
          array contains the transposed direct transmission matrix
          D'. The array D is not referenced if JOBD = 'Z'.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,M,P) if JOBD = 'D'.
          LDD >= 1          if JOBD = 'Z'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The rows and/or columns of the matrices of the triplet (A,B,C)
  and, optionally, of the matrix D are swapped in a special way.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB01YD.html000077500000000000000000000071371201767322700161170ustar00rootroot00000000000000 TB01YD - SLICOT Library Routine Documentation

TB01YD

Special similarity transformation of a state-space system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To apply a special similarity transformation to a system given as
  a triple (A,B,C),

     A <-- P * A * P,  B <-- P * B,  C <-- C * P,

  where P is a matrix with 1 on the secondary diagonal, and with 0
  in the other entries.
Specification 
      SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A, the number of rows of matrix B
          and the number of columns of matrix C.
          N represents the dimension of the state vector.  N >= 0.

  M       (input) INTEGER.
          The number of columns of matrix B.
          M represents the dimension of input vector.  M >= 0.

  P       (input) INTEGER.
          The number of rows of matrix C.
          P represents the dimension of output vector.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the system state matrix A.
          On exit, the leading N-by-N part of this array contains
          the transformed matrix P*A*P.

  LDA     INTEGER
          The leading dimension of the array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the system input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed matrix P*B.

  LDB     INTEGER
          The leading dimension of the array B.
          LDB >= MAX(1,N) if M > 0.
          LDB >= 1        if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the system output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix C*P.

  LDC     INTEGER
          The leading dimension of the array C.  LDC >= MAX(1,P).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The rows and/or columns of the matrices of the triplet (A,B,C)
  are swapped in a special way.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB01ZD.html000077500000000000000000000302231201767322700161100ustar00rootroot00000000000000 TB01ZD - SLICOT Library Routine Documentation

TB01ZD

Controllable realization for single-input systems using orthogonal state and input transformations

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a controllable realization for the linear time-invariant
  single-input system

          dX/dt = A * X + B * U,
             Y  = C * X,

  where A is an N-by-N matrix, B is an N element vector, C is an
  P-by-N matrix, and A and B are reduced by this routine to
  orthogonal canonical form using (and optionally accumulating)
  orthogonal similarity transformations, which are also applied
  to C.
Specification 
      SUBROUTINE TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ,
     $                   TAU, TOL, DWORK, LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOBZ    CHARACTER*1
          Indicates whether the user wishes to accumulate in a
          matrix Z the orthogonal similarity transformations for
          reducing the system, as follows:
          = 'N':  Do not form Z and do not store the orthogonal
                  transformations;
          = 'F':  Do not form Z, but store the orthogonal
                  transformations in the factored form;
          = 'I':  Z is initialized to the unit matrix and the
                  orthogonal transformation matrix Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the original state-space representation,
          i.e. the order of the matrix A.  N >= 0.

  P       (input) INTEGER
          The number of system outputs, or of rows of C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading NCONT-by-NCONT upper Hessenberg
          part of this array contains the canonical form of the
          state dynamics matrix, given by Z' * A * Z, of a
          controllable realization for the original system. The
          elements below the first subdiagonal are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, the original input/state vector B.
          On exit, the leading NCONT elements of this array contain
          canonical form of the input/state vector, given by Z' * B,
          with all elements but B(1) set to zero.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output/state matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed output/state matrix, given by C * Z, and
          the leading P-by-NCONT part contains the output/state
          matrix of the controllable realization.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  NCONT   (output) INTEGER
          The order of the controllable state-space representation.

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          If JOBZ = 'I', then the leading N-by-N part of this array
          contains the matrix of accumulated orthogonal similarity
          transformations which reduces the given system to
          orthogonal canonical form.
          If JOBZ = 'F', the elements below the diagonal, with the
          array TAU, represent the orthogonal transformation matrix
          as a product of elementary reflectors. The transformation
          matrix can then be obtained by calling the LAPACK Library
          routine DORGQR.
          If JOBZ = 'N', the array Z is not referenced and can be
          supplied as a dummy array (i.e. set parameter LDZ = 1 and
          declare this array to be Z(1,1) in the calling program).

  LDZ     INTEGER
          The leading dimension of array Z. If JOBZ = 'I' or
          JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.

  TAU     (output) DOUBLE PRECISION array, dimension (N)
          The elements of TAU contain the scalar factors of the
          elementary reflectors used in the reduction of B and A.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the
          controllability of (A,B). If the user sets TOL > 0, then
          the given value of TOL is used as an absolute tolerance;
          elements with absolute value less than TOL are considered
          neglijible. If the user sets TOL <= 0, then an implicitly
          computed, default tolerance, defined by
          TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead,
          where EPS is the machine precision (see LAPACK Library
          routine DLAMCH).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK. LDWORK >= MAX(1,N,P).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The Householder matrix which reduces all but the first element
  of vector B to zero is found and this orthogonal similarity
  transformation is applied to the matrix A. The resulting A is then
  reduced to upper Hessenberg form by a sequence of Householder
  transformations. Finally, the order of the controllable state-
  space representation (NCONT) is determined by finding the position
  of the first sub-diagonal element of A which is below an
  appropriate zero threshold, either TOL or TOLDEF (see parameter
  TOL); if NORM(B) is smaller than this threshold, NCONT is set to
  zero, and no computations for reducing the system to orthogonal
  canonical form are performed.
  All orthogonal transformations determined in this process are also
  applied to the matrix C, from the right.
References 
  [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D.
      Orthogonal Invariants and Canonical Forms for Linear
      Controllable Systems.
      Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981.

  [2] Hammarling, S.J.
      Notes on the use of orthogonal similarity transformations in
      control.
      NPL Report DITC 8/82, August 1982.

  [3] Paige, C.C
      Properties of numerical algorithms related to computing
      controllability.
      IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations and is backward stable.
Further Comments 
  None
Example

Program Text 

*     TB01ZD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, PMAX
      PARAMETER        ( NMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDC, LDZ
      PARAMETER        ( LDA = NMAX, LDC = PMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX, PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, N, NCONT, P
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 TAU(NMAX), Z(LDZ,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB01ZD, DORGQR
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, P, TOL, JOBZ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( B(I), I = 1,N )
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) P
         ELSE
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*           Find a controllable realization for the given system.
            CALL TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ,
     $                   TAU, TOL, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) NCONT
               DO 20 I = 1, NCONT
                  WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT )
               WRITE ( NOUT, FMT = 99991 )
               DO 30 I = 1, P
                  WRITE ( NOUT, FMT = 99994 ) ( C(I,J), J = 1,NCONT )
   30          CONTINUE
               IF ( LSAME( JOBZ, 'F' ) )
     $            CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK,
     $                         INFO )
               IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN
                  WRITE ( NOUT, FMT = 99995 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N )
   40             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01ZD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01ZD = ',I2)
99997 FORMAT (' The order of the controllable state-space representati',
     $       'on = ',I2,//' The state dynamics matrix A of a controlla',
     $       'ble realization is ')
99996 FORMAT (/' The input/state vector B of a controllable realizatio',
     $       'n is ',/(1X,F8.4))
99995 FORMAT (/' The similarity transformation matrix Z is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
99991 FORMAT (/' The output/state matrix C of a controllable realizati',
     $       'on is ')
      END
Program Data 
 TB01ZD EXAMPLE PROGRAM DATA
   3     2     0.0     I
   1.0   2.0   0.0
   4.0  -1.0   0.0
   0.0   0.0   1.0
   1.0   0.0   1.0
   0.0   2.0   1.0
   1.0   0.0   0.0
Program Results 
 TB01ZD EXAMPLE PROGRAM RESULTS

 The order of the controllable state-space representation =  3

 The state dynamics matrix A of a controllable realization is 
   1.0000   1.4142   0.0000
   2.8284  -1.0000   2.8284
   0.0000   1.4142   1.0000

 The input/state vector B of a controllable realization is 
  -1.4142
   0.0000
   0.0000

 The output/state matrix C of a controllable realization is 
  -0.7071  -2.0000   0.7071
  -0.7071   0.0000  -0.7071

 The similarity transformation matrix Z is 
  -0.7071   0.0000  -0.7071
   0.0000  -1.0000   0.0000
  -0.7071   0.0000   0.7071

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB03AD.html000077500000000000000000000456541201767322700160770ustar00rootroot00000000000000 TB03AD - SLICOT Library Routine Documentation

TB03AD

Left/right polynomial matrix representation of a given state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a relatively prime left polynomial matrix representation
  inv(P(s))*Q(s) or right polynomial matrix representation
  Q(s)*inv(P(s)) with the same transfer matrix T(s) as that of a
  given state-space representation, i.e.

     inv(P(s))*Q(s) = Q(s)*inv(P(s)) = T(s) = C*inv(s*I-A)*B + D.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  LERI    CHARACTER*1
          Indicates whether the left polynomial matrix
          representation or the right polynomial matrix
          representation is required as follows:
          = 'L':  A left matrix fraction is required;
          = 'R':  A right matrix fraction is required.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the triplet
          (A,B,C), before computing a minimal state-space
          representation, as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation, i.e. the
          order of the original state dynamics matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading NR-by-NR part of this array contains
          the upper block Hessenberg state dynamics matrix Amin of a
          minimal realization for the original system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,MAX(M,P))
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B; the remainder
          of the leading N-by-MAX(M,P) part is used as internal
          workspace.
          On exit, the leading NR-by-M part of this array contains
          the transformed input/state matrix Bmin.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C; the remainder
          of the leading MAX(M,P)-by-N part is used as internal
          workspace.
          On exit, the leading P-by-NR part of this array contains
          the transformed state/output matrix Cmin.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
          The leading P-by-M part of this array must contain the
          original direct transmission matrix D; the remainder of
          the leading MAX(M,P)-by-MAX(M,P) part is used as internal
          workspace.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,M,P).

  NR      (output) INTEGER
          The order of the minimal state-space representation
          (Amin,Bmin,Cmin).

  INDEX   (output) INTEGER array, dimension (P), if LERI = 'L', or
                                  dimension (M), if LERI = 'R'.
          If LERI = 'L', INDEX(I), I = 1,2,...,P, contains the
          maximum degree of the polynomials in the I-th row of the
          denominator matrix P(s) of the left polynomial matrix
          representation.
          These elements are ordered so that
          INDEX(1) >= INDEX(2) >= ... >= INDEX(P).
          If LERI = 'R', INDEX(I), I = 1,2,...,M, contains the
          maximum degree of the polynomials in the I-th column of
          the denominator matrix P(s) of the right polynomial
          matrix representation.
          These elements are ordered so that
          INDEX(1) >= INDEX(2) >= ... >= INDEX(M).

  PCOEFF  (output) DOUBLE PRECISION array, dimension
          (LDPCO1,LDPCO2,N+1)
          If LERI = 'L' then porm = P, otherwise porm = M.
          The leading porm-by-porm-by-kpcoef part of this array
          contains the coefficients of the denominator matrix P(s),
          where kpcoef = MAX(INDEX(I)) + 1.
          PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
          of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
          LERI = 'L' then iorj = I, otherwise iorj = J.
          Thus for LERI = 'L', P(s) =
          diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).

  LDPCO1  INTEGER
          The leading dimension of array PCOEFF.
          LDPCO1 >= MAX(1,P), if LERI = 'L';
          LDPCO1 >= MAX(1,M), if LERI = 'R'.

  LDPCO2  INTEGER
          The second dimension of array PCOEFF.
          LDPCO2 >= MAX(1,P), if LERI = 'L';
          LDPCO2 >= MAX(1,M), if LERI = 'R'.

  QCOEFF  (output) DOUBLE PRECISION array, dimension
          (LDQCO1,LDQCO2,N+1)
          If LERI = 'L' then porp = M, otherwise porp = P.
          If LERI = 'L', the leading porm-by-porp-by-kpcoef part
          of this array contains the coefficients of the numerator
          matrix Q(s).
          If LERI = 'R', the leading porp-by-porm-by-kpcoef part
          of this array contains the coefficients of the numerator
          matrix Q(s).
          QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).

  LDQCO1  INTEGER
          The leading dimension of array QCOEFF.
          LDQCO1 >= MAX(1,P),   if LERI = 'L';
          LDQCO1 >= MAX(1,M,P), if LERI = 'R'.

  LDQCO2  INTEGER
          The second dimension of array QCOEFF.
          LDQCO2 >= MAX(1,M),   if LERI = 'L';
          LDQCO2 >= MAX(1,M,P), if LERI = 'R'.

  VCOEFF  (output) DOUBLE PRECISION array, dimension
          (LDVCO1,LDVCO2,N+1)
          The leading porm-by-NR-by-kpcoef part of this array
          contains the coefficients of the intermediate matrix V(s).
          VCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).

  LDVCO1  INTEGER
          The leading dimension of array VCOEFF.
          LDVCO1 >= MAX(1,P), if LERI = 'L';
          LDVCO1 >= MAX(1,M), if LERI = 'R'.

  LDVCO2  INTEGER
          The second dimension of array VCOEFF.  LDVCO2 >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B, C). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance
          (determined by the SLICOT routine TB01UD) is used instead.
Workspace 
  IWORK   INTEGER array, dimension (N+MAX(M,P))
          On exit, if INFO = 0, the first nonzero elements of
          IWORK(1:N) return the orders of the diagonal blocks of A.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2))
          where  PM = P, if LERI = 'L';
                 PM = M, if LERI = 'R'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if a singular matrix was encountered during the
                computation of V(s);
          = 2:  if a singular matrix was encountered during the
                computation of P(s).
Method 
  The method for a left matrix fraction will be described here:
  right matrix fractions are dealt with by constructing a left
  fraction for the dual of the original system. The first step is to
  obtain, by means of orthogonal similarity transformations, a
  minimal state-space representation (Amin,Bmin,Cmin,D) for the
  original system (A,B,C,D), where Amin is lower block Hessenberg
  with all its superdiagonal blocks upper triangular and Cmin has
  all but its first rank(C) columns zero.  The number and dimensions
  of the blocks of Amin now immediately yield the row degrees of
  P(s) with P(s) row proper: furthermore, the P-by-NR polynomial
  matrix V(s) (playing a similar role to S(s) in Wolovich's
  Structure Theorem) can be calculated a column block at a time, in
  reverse order, from Amin. P(s) is then found as if it were the
  O-th column block of V(s) (using Cmin as well as Amin), while
  Q(s) = (V(s) * Bmin) + (P(s) * D). Finally, a special similarity
  transformation is used to put Amin in an upper block Hessenberg
  form.
References 
  [1] Williams, T.W.C.
      An Orthogonal Structure Theorem for Linear Systems.
      Kingston Polytechnic Control Systems Research Group,
      Internal Report 82/2, July 1982.

  [2] Patel, R.V.
      On Computing Matrix Fraction Descriptions and Canonical
      Forms of Linear Time-Invariant Systems.
      UMIST Control Systems Centre Report 489, 1980.
      (Algorithms 1 and 2, extensively modified).
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     TB03AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, LDQCO1,
     $                 LDQCO2, LDVCO1, LDVCO2, NMAXP1
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MAXMP,
     $                   LDD = MAXMP, LDPCO1 = MAXMP, LDPCO2 = MAXMP,
     $                   LDQCO1 = MAXMP, LDQCO2 = MAXMP, LDVCO1 = MAXMP,
     $                   LDVCO2 = NMAX, NMAXP1 = NMAX+1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX + MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX + MAX( NMAX, 3*MAXMP ),
     $                                 MAXMP*( MAXMP + 2 ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INDBLK, INFO, J, K, KPCOEF, M, N, NR, P, PORM,
     $                 PORP
      CHARACTER*1      EQUIL, LERI
      LOGICAL          LLERI
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP), DWORK(LDWORK),
     $                 PCOEFF(LDPCO1,LDPCO2,NMAXP1),
     $                 QCOEFF(LDQCO1,LDQCO2,NMAXP1),
     $                 VCOEFF(LDVCO1,LDVCO2,NMAXP1)
      INTEGER          INDEX(MAXMP), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB03AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, LERI, EQUIL
      LLERI = LSAME( LERI, 'L' )
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99986 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99985 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the right pmr which is equivalent to the ssr
*              C*inv(sI-A)*B+D.
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  INDBLK = 0
                  DO 40 I = 1, N
                     IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99995 ) ( IWORK(I), I = 1,INDBLK )
                  WRITE ( NOUT, FMT = 99994 )
                  DO 60 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR )
   80             CONTINUE
                  IF ( LLERI ) THEN
                     PORM = P
                     PORP = M
                     WRITE ( NOUT, FMT = 99992 ) INDBLK
                  ELSE
                     PORM = M
                     PORP = P
                     WRITE ( NOUT, FMT = 99991 ) INDBLK
                  END IF
                  WRITE ( NOUT, FMT = 99990 ) ( INDEX(I), I = 1,PORM )
                  KPCOEF = 0
                  DO 100 I = 1, PORM
                     KPCOEF = MAX( KPCOEF, INDEX(I) )
  100             CONTINUE
                  KPCOEF = KPCOEF + 1
                  WRITE ( NOUT, FMT = 99989 )
                  DO 140 I = 1, PORM
                     DO 120 J = 1, PORM
                        WRITE ( NOUT, FMT = 99996 )
     $                        ( PCOEFF(I,J,K), K = 1,KPCOEF )
  120                CONTINUE
  140             CONTINUE
                  WRITE ( NOUT, FMT = 99988 )
                  IF ( LLERI ) THEN
                     DO 180 I = 1, PORM
                        DO 160 J = 1, PORP
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( QCOEFF(I,J,K), K = 1,KPCOEF )
  160                   CONTINUE
  180                CONTINUE
                  ELSE
                     DO 220 I = 1, PORP
                        DO 200 J = 1, PORM
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( QCOEFF(I,J,K), K = 1,KPCOEF )
  200                   CONTINUE
  220                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB03AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB03AD = ',I2)
99997 FORMAT (' The order of the minimal state-space representation = ',
     $       I2,//' The transformed state dynamics matrix of a minimal',
     $       ' realization is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' and the dimensions of its diagonal blocks are ',/20(I5)
     $       )
99994 FORMAT (/' The transformed input/state matrix of a minimal reali',
     $       'zation is ')
99993 FORMAT (/' The transformed state/output matrix of a minimal real',
     $       'ization is ')
99992 FORMAT (/' The observability index of the transformed minimal sy',
     $       'stem representation = ',I2)
99991 FORMAT (/' The controllability index of the transformed minimal ',
     $       'system representation = ',I2)
99990 FORMAT (/' INDEX is ',/20(I5))
99989 FORMAT (/' The denominator matrix P(s) is ')
99988 FORMAT (/' The numerator matrix Q(s) is ')
99987 FORMAT (/' N is out of range.',/' N = ',I5)
99986 FORMAT (/' M is out of range.',/' M = ',I5)
99985 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB03AD EXAMPLE PROGRAM DATA
   3     1     2     0.0     R     N
   1.0   2.0   0.0
   4.0  -1.0   0.0
   0.0   0.0   1.0
   1.0   0.0   1.0
   0.0   1.0  -1.0
   0.0   0.0   1.0
   0.0   1.0
Program Results 
 TB03AD EXAMPLE PROGRAM RESULTS

 The order of the minimal state-space representation =  3

 The transformed state dynamics matrix of a minimal realization is 
   1.0000  -1.4142   0.0000
  -2.8284  -1.0000   2.8284
   0.0000   1.4142   1.0000

 and the dimensions of its diagonal blocks are 
    1    1    1

 The transformed input/state matrix of a minimal realization is 
  -1.4142
   0.0000
   0.0000

 The transformed state/output matrix of a minimal realization is 
   0.7071   1.0000   0.7071
  -0.7071   0.0000  -0.7071

 The controllability index of the transformed minimal system representation =  3

 INDEX is 
    3

 The denominator matrix P(s) is 
   0.1768  -0.1768  -1.5910   1.5910

 The numerator matrix Q(s) is 
   0.0000  -0.1768   0.7071   0.8839
   0.1768   0.0000  -1.5910   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB04AD.html000077500000000000000000000431751201767322700160740ustar00rootroot00000000000000 TB04AD - SLICOT Library Routine Documentation

TB04AD

Transfer matrix of a given state-space representation (A,B,C,D)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find the transfer matrix T(s) of a given state-space
  representation (A,B,C,D). T(s) is expressed as either row or
  column polynomial vectors over monic least common denominator
  polynomials.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  ROWCOL  CHARACTER*1
          Indicates whether the transfer matrix T(s) is required
          as rows or columns over common denominators as follows:
          = 'R':  T(s) is required as rows over common denominators;
          = 'C':  T(s) is required as columns over common
                  denominators.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the state-space representation, i.e. the
          order of the original state dynamics matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading NR-by-NR part of this array contains
          the upper block Hessenberg state dynamics matrix A of a
          transformed representation for the original system: this
          is completely controllable if ROWCOL = 'R', or completely
          observable if ROWCOL = 'C'.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M),
          if ROWCOL = 'R', and (LDB,MAX(M,P)) if ROWCOL = 'C'.
          On entry, the leading N-by-M part of this array must
          contain the original input/state matrix B; if
          ROWCOL = 'C', the remainder of the leading N-by-MAX(M,P)
          part is used as internal workspace.
          On exit, the leading NR-by-M part of this array contains
          the transformed input/state matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original state/output matrix C; if
          ROWCOL = 'C', the remainder of the leading MAX(M,P)-by-N
          part is used as internal workspace.
          On exit, the leading P-by-NR part of this array contains
          the transformed state/output matrix C.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,P)   if ROWCOL = 'R';
          LDC >= MAX(1,M,P) if ROWCOL = 'C'.

  D       (input) DOUBLE PRECISION array, dimension (LDD,M),
          if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'.
          The leading P-by-M part of this array must contain the
          original direct transmission matrix D; if ROWCOL = 'C',
          this array is modified internally, but restored on exit,
          and the remainder of the leading MAX(M,P)-by-MAX(M,P)
          part is used as internal workspace.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P)   if ROWCOL = 'R';
          LDD >= MAX(1,M,P) if ROWCOL = 'C'.

  NR      (output) INTEGER
          The order of the transformed state-space representation.

  INDEX   (output) INTEGER array, dimension (porm), where porm = P,
          if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'.
          The degrees of the denominator polynomials.

  DCOEFF  (output) DOUBLE PRECISION array, dimension (LDDCOE,N+1)
          The leading porm-by-kdcoef part of this array contains
          the coefficients of each denominator polynomial, where
          kdcoef = MAX(INDEX(I)) + 1.
          DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of
          the I-th denominator polynomial, where K = 1,2,...,kdcoef.

  LDDCOE  INTEGER
          The leading dimension of array DCOEFF.
          LDDCOE >= MAX(1,P) if ROWCOL = 'R';
          LDDCOE >= MAX(1,M) if ROWCOL = 'C'.

  UCOEFF  (output) DOUBLE PRECISION array, dimension
          (LDUCO1,LDUCO2,N+1)
          If ROWCOL = 'R' then porp = M, otherwise porp = P.
          The leading porm-by-porp-by-kdcoef part of this array
          contains the coefficients of the numerator matrix U(s).
          UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
          of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef;
          if ROWCOL = 'R' then iorj = I, otherwise iorj = J.
          Thus for ROWCOL = 'R', U(s) =
          diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...).

  LDUCO1  INTEGER
          The leading dimension of array UCOEFF.
          LDUCO1 >= MAX(1,P) if ROWCOL = 'R';
          LDUCO1 >= MAX(1,M) if ROWCOL = 'C'.

  LDUCO2  INTEGER
          The second dimension of array UCOEFF.
          LDUCO2 >= MAX(1,M) if ROWCOL = 'R';
          LDUCO2 >= MAX(1,P) if ROWCOL = 'C'.
Tolerances 
  TOL1    DOUBLE PRECISION
          The tolerance to be used in determining the i-th row of
          T(s), where i = 1,2,...,porm. If the user sets TOL1 > 0,
          then the given value of TOL1 is used as an absolute
          tolerance; elements with absolute value less than TOL1 are
          considered neglijible. If the user sets TOL1 <= 0, then
          an implicitly computed, default tolerance, defined in
          the SLICOT Library routine TB01ZD, is used instead.

  TOL2    DOUBLE PRECISION
          The tolerance to be used to separate out a controllable
          subsystem of (A,B,C). If the user sets TOL2 > 0, then
          the given value of TOL2 is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL2 is considered to be of full rank.  If the user sets
          TOL2 <= 0, then an implicitly computed, default tolerance,
          defined in the SLICOT Library routine TB01UD, is used
          instead.
Workspace 
  IWORK   DOUBLE PRECISION array, dimension (N+MAX(M,P))
          On exit, if INFO = 0, the first nonzero elements of
          IWORK(1:N) return the orders of the diagonal blocks of A.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N*(N + 1) + MAX(N*MP + 2*N + MAX(N,MP),
                                    3*MP, PM)),
          where MP = M, PM = P, if ROWCOL = 'R';
                MP = P, PM = M, if ROWCOL = 'C'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The method for transfer matrices factorized by rows will be
  described here: T(s) factorized by columns is dealt with by
  operating on the dual of the original system.  Each row of
  T(s) is simply a single-output relatively left prime polynomial
  matrix representation, so can be calculated by applying a
  simplified version of the Orthogonal Structure Theorem to a
  minimal state-space representation for the corresponding row of
  the given system. A minimal state-space representation is obtained
  using the Orthogonal Canonical Form to first separate out a
  completely controllable one for the overall system and then, for
  each row in turn, applying it again to the resulting dual SIMO
  (single-input multi-output) system. Note that the elements of the
  transformed matrix A so calculated are individually scaled in a
  way which guarantees a monic denominator polynomial.
References 
  [1] Williams, T.W.C.
      An Orthogonal Structure Theorem for Linear Systems.
      Control Systems Research Group, Kingston Polytechnic,
      Internal Report 82/2, 1982.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     TB04AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, LDUCO2,
     $                 NMAXP1
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MAXMP,
     $                   LDD = MAXMP, LDDCOE = MAXMP, LDUCO1 = MAXMP,
     $                   LDUCO2 = MAXMP, NMAXP1 = NMAX+1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX + MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( NMAX + 1 ) +
     $                            MAX( NMAX*MAXMP + 2*NMAX +
     $                                 MAX( NMAX, MAXMP ), 3*MAXMP ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL1, TOL2
      INTEGER          I, II, IJ, INDBLK, INFO, J, JJ, KDCOEF, M, N,
     $                 NR, P, PORM, PORP
      CHARACTER*1      ROWCOL
      CHARACTER*132    ULINE
      LOGICAL          LROWCO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP), DCOEFF(LDDCOE,NMAXP1),
     $                 DWORK(LDWORK), UCOEFF(LDUCO1,LDUCO2,NMAXP1)
      INTEGER          INDEX(MAXMP), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB04AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL1, TOL2, ROWCOL
      LROWCO = LSAME( ROWCOL, 'R' )
      ULINE(1:20) = ' '
      DO 20 I = 21, 132
         ULINE(I:I) = '-'
   20 CONTINUE
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99986 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99985 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99984 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the transfer matrix T(s) of (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR )
   80             CONTINUE
                  INDBLK = 0
                  DO 100 I = 1, N
                     IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1
  100             CONTINUE
                  IF ( LROWCO ) THEN
                     PORM = P
                     PORP = M
                     WRITE ( NOUT, FMT = 99993 ) INDBLK,
     $                          ( IWORK(I), I = 1,INDBLK )
                  ELSE
                     PORM = M
                     PORP = P
                     WRITE ( NOUT, FMT = 99992 ) INDBLK,
     $                          ( IWORK(I), I = 1,INDBLK )
                  END IF
                  WRITE ( NOUT, FMT = 99991 ) ( INDEX(I), I = 1,PORM )
                  WRITE ( NOUT, FMT = 99990 )
                  KDCOEF = 0
                  DO 120 I = 1, PORM
                     KDCOEF = MAX( KDCOEF, INDEX(I) )
  120             CONTINUE
                  KDCOEF = KDCOEF + 1
                  DO 160 II = 1, PORM
                     DO 140 JJ = 1, PORP
                        WRITE ( NOUT, FMT = 99989 ) II, JJ,
     $                    ( UCOEFF(II,JJ,IJ), IJ = 1,KDCOEF )
                        WRITE ( NOUT, FMT = 99988 ) ULINE(1:7*KDCOEF+21)
                        WRITE ( NOUT, FMT = 99987 )
     $                        ( DCOEFF(II,IJ), IJ = 1,KDCOEF )
  140                CONTINUE
  160             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB04AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB04AD = ',I2)
99997 FORMAT (' The order of the transformed state-space representatio',
     $       'n = ',I2,//' The transformed state dynamics matrix A is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The transformed input/state matrix B is ')
99994 FORMAT (/' The transformed state/output matrix C is ')
99993 FORMAT (/' The controllability index of the transformed state-sp',
     $       'ace representation = ',I2,//' The dimensions of the diag',
     $       'onal blocks of the transformed A are ',/20(I5))
99992 FORMAT (/' The observability index of the transformed state-spac',
     $       'e representation = ',I2,//' The dimensions of the diagon',
     $       'al blocks of the transformed A are ',/20(I5))
99991 FORMAT (/' The degrees of the denominator polynomials are',/20(I5)
     $       )
99990 FORMAT (/' The coefficients of polynomials in the transfer matri',
     $       'x T(s) are ')
99989 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2))
99988 FORMAT (1X,A)
99987 FORMAT (20X,20(1X,F6.2))
99986 FORMAT (/' N is out of range.',/' N = ',I5)
99985 FORMAT (/' M is out of range.',/' M = ',I5)
99984 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB04AD EXAMPLE PROGRAM DATA
   3     2     2  0.0        0.0     R
  -1.0   0.0   0.0
   0.0  -2.0   0.0
   0.0   0.0  -3.0
   0.0   1.0  -1.0
   1.0   1.0   0.0
   0.0   1.0   1.0
   1.0   1.0   1.0
   1.0   0.0
   0.0   1.0
Program Results 
 TB04AD EXAMPLE PROGRAM RESULTS

 The order of the transformed state-space representation =  3

 The transformed state dynamics matrix A is 
  -2.5000  -0.2887  -0.4082
  -0.2887  -1.5000  -0.7071
  -0.4082  -0.7071  -2.0000

 The transformed input/state matrix B is 
  -1.4142  -0.7071
   0.0000   1.2247
   0.0000   0.0000

 The transformed state/output matrix C is 
   0.0000   0.8165   1.1547
   0.0000   1.6330   0.5774

 The controllability index of the transformed state-space representation =  2

 The dimensions of the diagonal blocks of the transformed A are 
    2    1

 The degrees of the denominator polynomials are
    2    3

 The coefficients of polynomials in the transfer matrix T(s) are 

 element ( 1, 1) is    1.00   5.00   7.00   0.00
                     -----------------------------
                       1.00   5.00   6.00   0.00

 element ( 1, 2) is    0.00   1.00   3.00   0.00
                     -----------------------------
                       1.00   5.00   6.00   0.00

 element ( 2, 1) is    0.00   0.00   1.00   1.00
                     -----------------------------
                       1.00   6.00  11.00   6.00

 element ( 2, 2) is    1.00   8.00  20.00  15.00
                     -----------------------------
                       1.00   6.00  11.00   6.00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB04BD.html000077500000000000000000000372561201767322700161000ustar00rootroot00000000000000 TB04BD - SLICOT Library Routine Documentation

TB04BD

Transfer matrix of a given state-space representation (A,B,C,D), using the pole-zeros method

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the transfer function matrix G of a state-space
  representation (A,B,C,D) of a linear time-invariant multivariable
  system, using the pole-zeros method. Each element of the transfer
  function matrix is returned in a cancelled, minimal form, with
  numerator and denominator polynomials stored either in increasing
  or decreasing order of the powers of the indeterminate.
Specification 
      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     .. 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(*)
Arguments

Mode Parameters 

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state-space model:
          = 'D':  D is present;
          = 'Z':  D is assumed to be a zero matrix.

  ORDER   CHARACTER*1
          Specifies the order in which the polynomial coefficients
          are stored, as follows:
          = 'I':  Increasing order of powers of the indeterminate;
          = 'D':  Decreasing order of powers of the indeterminate.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system (A,B,C,D).  N >= 0.

  M       (input) INTEGER
          The number of the system inputs.  M >= 0.

  P       (input) INTEGER
          The number of the system outputs.  P >= 0.

  MD      (input) INTEGER
          The maximum degree of the polynomials in G, plus 1. An
          upper bound for MD is N+1.  MD >= 1.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, if EQUIL = 'S', the leading N-by-N part of this
          array contains the balanced matrix inv(S)*A*S, as returned
          by SLICOT Library routine TB01ID.
          If EQUIL = 'N', this array is unchanged on exit.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the contents of B are destroyed: all elements but
          those in the first row are set to zero.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C.
          On exit, if EQUIL = 'S', the leading P-by-N part of this
          array contains the balanced matrix C*S, as returned by
          SLICOT Library routine TB01ID.
          If EQUIL = 'N', this array is unchanged on exit.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          If JOBD = 'D', the leading P-by-M part of this array must
          contain the matrix D.
          If JOBD = 'Z', the array D is not referenced.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P), if JOBD = 'D';
          LDD >= 1,        if JOBD = 'Z'.

  IGN     (output) INTEGER array, dimension (LDIGN,M)
          The leading P-by-M part of this array contains the degrees
          of the numerator polynomials in the transfer function
          matrix G. Specifically, the (i,j) element of IGN contains
          the degree of the numerator polynomial of the transfer
          function G(i,j) from the j-th input to the i-th output.

  LDIGN   INTEGER
          The leading dimension of array IGN.  LDIGN >= max(1,P).

  IGD     (output) INTEGER array, dimension (LDIGD,M)
          The leading P-by-M part of this array contains the degrees
          of the denominator polynomials in the transfer function
          matrix G. Specifically, the (i,j) element of IGD contains
          the degree of the denominator polynomial of the transfer
          function G(i,j).

  LDIGD   INTEGER
          The leading dimension of array IGD.  LDIGD >= max(1,P).

  GN      (output) DOUBLE PRECISION array, dimension (P*M*MD)
          This array contains the coefficients of the numerator
          polynomials, Num(i,j), of the transfer function matrix G.
          The polynomials are stored in a column-wise order, i.e.,
          Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2),
          ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M);
          MD memory locations are reserved for each polynomial,
          hence, the (i,j) polynomial is stored starting from the
          location ((j-1)*P+i-1)*MD+1. The coefficients appear in
          increasing or decreasing order of the powers of the
          indeterminate, according to ORDER.

  GD      (output) DOUBLE PRECISION array, dimension (P*M*MD)
          This array contains the coefficients of the denominator
          polynomials, Den(i,j), of the transfer function matrix G.
          The polynomials are stored in the same way as the
          numerator polynomials.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the
          controllability of a single-input system (A,b) or (A',c'),
          where b and c' are columns in B and C' (C transposed). If
          the user sets TOL > 0, then the given value of TOL is used
          as an absolute tolerance; elements with absolute value
          less than TOL are considered neglijible. If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used
          instead, where EPS is the machine precision (see LAPACK
          Library routine DLAMCH), and bc denotes the currently used
          column in B or C' (see METHOD).
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N*(N+P) +
                           MAX( N + MAX( N,P ), N*(2*N+5)))
          If N >= P, N >= 1, the formula above can be written as
          LDWORK >= N*(3*N + P + 5).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the QR algorithm failed to converge when trying to
                compute the zeros of a transfer function;
          = 2:  the QR algorithm failed to converge when trying to
                compute the poles of a transfer function.
                The errors INFO = 1 or 2 are unlikely to appear.
Method 
  The routine implements the pole-zero method proposed in [1].
  This method is based on an algorithm for computing the transfer
  function of a single-input single-output (SISO) system.
  Let (A,b,c,d) be a SISO system. Its transfer function is computed
  as follows:

  1) Find a controllable realization (Ac,bc,cc) of (A,b,c).
  2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc).
  3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)).
  4) Compute the zeros of (Ao,bo,co,d).
  5) Compute the gain of (Ao,bo,co,d).

  This algorithm can be implemented using only orthogonal
  transformations [1]. However, for better efficiency, the
  implementation in TB04BD uses one elementary transformation
  in Step 4 and r elementary transformations in Step 5 (to reduce
  an upper Hessenberg matrix to upper triangular form). These
  special elementary transformations are numerically stable
  in practice.

  In the multi-input multi-output (MIMO) case, the algorithm
  computes each element (i,j) of the transfer function matrix G,
  for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1
  is performed once for each value of j (each column of B). The
  matrices Ac and Ao result in Hessenberg form.
References 
  [1] Varga, A. and Sima, V.
      Numerically Stable Algorithm for Transfer Function Matrix
      Evaluation.
      Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981.
Numerical Aspects 
  The algorithm is numerically stable in practice and requires about
  20*N**3 floating point operations at most, but usually much less.
Further Comments 
  For maximum efficiency of index calculations, GN and GD are
  implemented as one-dimensional arrays.
Example

Program Text 

*     TB04BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX, MDMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20,
     $                   MDMAX = NMAX + 1 )
      INTEGER          PMNMAX
      PARAMETER        ( PMNMAX = PMAX*MMAX*MDMAX )
      INTEGER          LDA, LDB, LDC, LDD, LDIGD, LDIGN
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDIGD = PMAX, LDIGN = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( NMAX + PMAX ) +
     $                            MAX( NMAX + MAX( NMAX, PMAX ),
     $                                 NMAX*( 2*NMAX + 5 ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, IJ, INFO, J, K, M, MD, N, P
      CHARACTER*1      JOBD, ORDER, EQUIL
      CHARACTER*132    ULINE
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), GD(PMNMAX),
     $                 GN(PMNMAX)
      INTEGER          IGD(LDIGD,MMAX), IGN(LDIGN,MMAX), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB04BD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBD, ORDER, EQUIL
      MD = N + 1
      ULINE(1:20) = ' '
      DO 20 I = 21, 132
         ULINE(I:I) = '-'
   20 CONTINUE
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99990 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99989 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the transfer matrix T(s) of (A,B,C,D).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF ( LSAME( ORDER, 'I' ) ) THEN
                     WRITE ( NOUT, FMT = 99997 )
                  ELSE
                     WRITE ( NOUT, FMT = 99996 )
                  END IF
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 J = 1, M
                     DO 40 I = 1, P
                        IJ = ( (J-1)*P + I-1 )*MD + 1
                        WRITE ( NOUT, FMT = 99994 ) I, J,
     $                    ( GN(K), K = IJ,IJ+IGN(I,J) )
                        WRITE ( NOUT, FMT = 99993 )
     $                          ULINE(1:7*(IGD(I,J)+1)+21)
                        WRITE ( NOUT, FMT = 99992 )
     $                        ( GD(K), K = IJ,IJ+IGD(I,J) )
   40                CONTINUE
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB04BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB04BD = ',I2)
99997 FORMAT (/' The polynomial coefficients appear in increasing',
     $         ' order'/' of the powers of the indeterminate')
99996 FORMAT (/' The polynomial coefficients appear in decreasing',
     $         ' order'/' of the powers of the indeterminate')
99995 FORMAT (/' The coefficients of polynomials in the transfer matri',
     $       'x T(s) are ')
99994 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2))
99993 FORMAT (1X,A)
99992 FORMAT (20X,20(1X,F6.2))
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' M is out of range.',/' M = ',I5)
99989 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB04BD EXAMPLE PROGRAM DATA
   3     2     2  0.0         D     I     N
  -1.0   0.0   0.0
   0.0  -2.0   0.0
   0.0   0.0  -3.0
   0.0   1.0  -1.0
   1.0   1.0   0.0
   0.0   1.0   1.0
   1.0   1.0   1.0
   1.0   0.0
   0.0   1.0
Program Results 
 TB04BD EXAMPLE PROGRAM RESULTS


 The polynomial coefficients appear in increasing order
 of the powers of the indeterminate

 The coefficients of polynomials in the transfer matrix T(s) are 

 element ( 1, 1) is    7.00   5.00   1.00
                     ----------------------
                       6.00   5.00   1.00

 element ( 2, 1) is    1.00
                     ----------------------
                       6.00   5.00   1.00

 element ( 1, 2) is    1.00
                     ---------------
                       2.00   1.00

 element ( 2, 2) is    5.00   5.00   1.00
                     ----------------------
                       2.00   3.00   1.00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB04BV.html000077500000000000000000000137451201767322700161170ustar00rootroot00000000000000 TB04BV - SLICOT Library Routine Documentation

TB04BV

Strictly proper part of a proper transfer function matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To separate the strictly proper part G0 from the constant part D
  of an P-by-M proper transfer function matrix G.
Specification 
      SUBROUTINE TB04BV( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN,
     $                   GD, D, LDD, TOL, INFO )
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,*)
Arguments

Mode Parameters 

  ORDER   CHARACTER*1
          Specifies the order in which the polynomial coefficients
          of the transfer function matrix are stored, as follows:
          = 'I':  Increasing order of powers of the indeterminate;
          = 'D':  Decreasing order of powers of the indeterminate.
Input/Output Parameters 
  P       (input) INTEGER
          The number of the system outputs.  P >= 0.

  M       (input) INTEGER
          The number of the system inputs.  M >= 0.

  MD      (input) INTEGER
          The maximum degree of the polynomials in G, plus 1, i.e.,
          MD = MAX(IGD(I,J)) + 1.
               I,J

  IGN     (input/output) INTEGER array, dimension (LDIGN,M)
          On entry, the leading P-by-M part of this array must
          contain the degrees of the numerator polynomials in G:
          the (i,j) element of IGN must contain the degree of the
          numerator polynomial of the polynomial ratio G(i,j).
          On exit, the leading P-by-M part of this array contains
          the degrees of the numerator polynomials in G0.

  LDIGN   INTEGER
          The leading dimension of array IGN.  LDIGN >= max(1,P).

  IGD     (input) INTEGER array, dimension (LDIGD,M)
          The leading P-by-M part of this array must contain the
          degrees of the denominator polynomials in G (and G0):
          the (i,j) element of IGD contains the degree of the
          denominator polynomial of the polynomial ratio G(i,j).

  LDIGD   INTEGER
          The leading dimension of array IGD.  LDIGD >= max(1,P).

  GN      (input/output) DOUBLE PRECISION array, dimension (P*M*MD)
          On entry, this array must contain the coefficients of the
          numerator polynomials, Num(i,j), of the transfer function
          matrix G. The polynomials are stored in a column-wise
          order, i.e., Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2),
          Num(2,2), ..., Num(P,2), ..., Num(1,M), Num(2,M), ...,
          Num(P,M); MD memory locations are reserved for each
          polynomial, hence, the (i,j) polynomial is stored starting
          from the location ((j-1)*P+i-1)*MD+1. The coefficients
          appear in increasing or decreasing order of the powers
          of the indeterminate, according to ORDER.
          On exit, this array contains the coefficients of the
          numerator polynomials of the strictly proper part G0 of
          the transfer function matrix G, stored similarly.

  GD      (input) DOUBLE PRECISION array, dimension (P*M*MD)
          This array must contain the coefficients of the
          denominator polynomials, Den(i,j), of the transfer
          function matrix G. The polynomials are stored as for the
          numerator polynomials.

  D       (output) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array contains the
          matrix D.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= max(1,P).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the degrees of
          the numerators Num0(i,j) of the strictly proper part of
          the transfer function matrix G. If the user sets TOL > 0,
          then the given value of TOL is used as an absolute
          tolerance; the leading coefficients with absolute value
          less than TOL are considered neglijible. If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by TOLDEF = IGN(i,j)*EPS*NORM( Num(i,j) ) is used
          instead, where EPS is the machine precision (see LAPACK
          Library routine DLAMCH), and NORM denotes the infinity
          norm (the maximum coefficient in absolute value).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the transfer function matrix is not proper;
          = 2:  if a denominator polynomial is null.
Method 
  The (i,j) entry of the real matrix D is zero, if the degree of
  Num(i,j), IGN(i,j), is less than the degree of Den(i,j), IGD(i,j),
  and it is given by the ratio of the leading coefficients of
  Num(i,j) and Den(i,j), if IGN(i,j) is equal to IGD(i,j),
  for i = 1 : P, and for j = 1 : M.
Further Comments 
  For maximum efficiency of index calculations, GN and GD are
  implemented as one-dimensional arrays.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB04BW.html000077500000000000000000000124061201767322700161110ustar00rootroot00000000000000 TB04BW - SLICOT Library Routine Documentation

TB04BW

Sum of a rational matrix and a real matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the sum of an P-by-M rational matrix G and a real
  P-by-M matrix D.
Specification 
      SUBROUTINE TB04BW( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN,
     $                   GD, D, LDD, INFO )
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,*)
Arguments

Mode Parameters 

  ORDER   CHARACTER*1
          Specifies the order in which the polynomial coefficients
          of the rational matrix are stored, as follows:
          = 'I':  Increasing order of powers of the indeterminate;
          = 'D':  Decreasing order of powers of the indeterminate.
Input/Output Parameters 
  P       (input) INTEGER
          The number of the system outputs.  P >= 0.

  M       (input) INTEGER
          The number of the system inputs.  M >= 0.

  MD      (input) INTEGER
          The maximum degree of the polynomials in G, plus 1, i.e.,
          MD = MAX(IGN(I,J),IGD(I,J)) + 1.
               I,J

  IGN     (input/output) INTEGER array, dimension (LDIGN,M)
          On entry, the leading P-by-M part of this array must
          contain the degrees of the numerator polynomials in G:
          the (i,j) element of IGN must contain the degree of the
          numerator polynomial of the polynomial ratio G(i,j).
          On exit, the leading P-by-M part of this array contains
          the degrees of the numerator polynomials in G + D.

  LDIGN   INTEGER
          The leading dimension of array IGN.  LDIGN >= max(1,P).

  IGD     (input) INTEGER array, dimension (LDIGD,M)
          The leading P-by-M part of this array must contain the
          degrees of the denominator polynomials in G (and G + D):
          the (i,j) element of IGD contains the degree of the
          denominator polynomial of the polynomial ratio G(i,j).

  LDIGD   INTEGER
          The leading dimension of array IGD.  LDIGD >= max(1,P).

  GN      (input/output) DOUBLE PRECISION array, dimension (P*M*MD)
          On entry, this array must contain the coefficients of the
          numerator polynomials, Num(i,j), of the rational matrix G.
          The polynomials are stored in a column-wise order, i.e.,
          Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2),
          ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M);
          MD memory locations are reserved for each polynomial,
          hence, the (i,j) polynomial is stored starting from the
          location ((j-1)*P+i-1)*MD+1. The coefficients appear in
          increasing or decreasing order of the powers of the
          indeterminate, according to ORDER.
          On exit, this array contains the coefficients of the
          numerator polynomials of the rational matrix G + D,
          stored similarly.

  GD      (input) DOUBLE PRECISION array, dimension (P*M*MD)
          This array must contain the coefficients of the
          denominator polynomials, Den(i,j), of the rational
          matrix G. The polynomials are stored as for the
          numerator polynomials.

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          matrix D.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= max(1,P).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The (i,j) entry of the real matrix D is added to the (i,j) entry
  of the matrix G, g(i,j), which is a ratio of two polynomials,
  for i = 1 : P, and for j = 1 : M. If g(i,j) = 0, it is assumed
  that its denominator is 1.
Numerical Aspects 
  The algorithm is numerically stable.
Further Comments 
  Often, the rational matrix G is found from a state-space
  representation (A,B,C), and D corresponds to the direct
  feedthrough matrix of the system. The sum G + D gives the
  transfer function matrix of the system (A,B,C,D).
  For maximum efficiency of index calculations, GN and GD are
  implemented as one-dimensional arrays.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB04BX.html000077500000000000000000000120231201767322700161050ustar00rootroot00000000000000 TB04BX - SLICOT Library Routine Documentation

TB04BX

Gain of a SISO linear system, given its state-space representation, poles and zeros

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the gain of a single-input single-output linear system,
  given its state-space representation (A,b,c,d), and its poles and
  zeros. The matrix A is assumed to be in an upper Hessenberg form.
  The gain is computed using the formula

                       -1         IP              IZ
     g = (c*( S0*I - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) ,
                                  i=1             i=1            (1)

  where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros,
  respectively, and S0 is a real scalar different from all poles and
  zeros.
Specification 
      SUBROUTINE TB04BX( IP, IZ, A, LDA, B, C, D, PR, PI, ZR, ZI, GAIN,
     $                   IWORK )
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(*)
Arguments

Input/Output Parameters 

  IP      (input) INTEGER
          The number of the system poles.  IP >= 0.

  IZ      (input) INTEGER
          The number of the system zeros.  IZ >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,IP)
          On entry, the leading IP-by-IP part of this array must
          contain the state dynamics matrix A in an upper Hessenberg
          form. The elements below the second diagonal are not
          referenced.
          On exit, the leading IP-by-IP upper Hessenberg part of
          this array contains the LU factorization of the matrix
          A - S0*I, as computed by SLICOT Library routine MB02SD.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= max(1,IP).

  B       (input/output) DOUBLE PRECISION array, dimension (IP)
          On entry, this array must contain the system input
          vector b.
          On exit, this array contains the solution of the linear
          system ( A - S0*I )x = b .

  C       (input) DOUBLE PRECISION array, dimension (IP)
          This array must contain the system output vector c.

  D       (input) DOUBLE PRECISION
          The variable must contain the system feedthrough scalar d.

  PR      (input) DOUBLE PRECISION array, dimension (IP)
          This array must contain the real parts of the system
          poles. Pairs of complex conjugate poles must be stored in
          consecutive memory locations.

  PI      (input) DOUBLE PRECISION array, dimension (IP)
          This array must contain the imaginary parts of the system
          poles.

  ZR      (input) DOUBLE PRECISION array, dimension (IZ)
          This array must contain the real parts of the system
          zeros. Pairs of complex conjugate zeros must be stored in
          consecutive memory locations.

  ZI      (input) DOUBLE PRECISION array, dimension (IZ)
          This array must contain the imaginary parts of the system
          zeros.

  GAIN    (output) DOUBLE PRECISION
          The gain of the linear system (A,b,c,d), given by (1).
Workspace 
  IWORK   INTEGER array, dimension (IP)
          On exit, it contains the pivot indices; for 1 <= i <= IP,
          row i of the matrix A - S0*I was interchanged with
          row IWORK(i).
Method 
  The routine implements the method presented in [1]. A suitable
  value of S0 is chosen based on the system poles and zeros.
  Then, the LU factorization of the upper Hessenberg, nonsingular
  matrix A - S0*I is computed and used to solve the linear system
  in (1).
References 
  [1] Varga, A. and Sima, V.
      Numerically Stable Algorithm for Transfer Function Matrix
      Evaluation.
      Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981.
Numerical Aspects 
  The algorithm is numerically stable in practice and requires
  O(IP*IP) floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TB04CD.html000077500000000000000000000407601201767322700160730ustar00rootroot00000000000000 TB04CD - SLICOT Library Routine Documentation

TB04CD

Pole-zero-gain representation for a given state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the transfer function matrix G of a state-space
  representation (A,B,C,D) of a linear time-invariant multivariable
  system, using the pole-zeros method. The transfer function matrix
  is returned in a minimal pole-zero-gain form.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  JOBD    CHARACTER*1
          Specifies whether or not a non-zero matrix D appears in
          the given state-space model:
          = 'D':  D is present;
          = 'Z':  D is assumed to be a zero matrix.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily
          equilibrate the triplet (A,B,C) as follows:
          = 'S':  perform equilibration (scaling);
          = 'N':  do not perform equilibration.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the system (A,B,C,D).  N >= 0.

  M       (input) INTEGER
          The number of the system inputs.  M >= 0.

  P       (input) INTEGER
          The number of the system outputs.  P >= 0.

  NPZ     (input) INTEGER
          The maximum number of poles or zeros of the single-input
          single-output channels in the system. An upper bound
          for NPZ is N.  NPZ >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, if EQUIL = 'S', the leading N-by-N part of this
          array contains the balanced matrix inv(S)*A*S, as returned
          by SLICOT Library routine TB01ID.
          If EQUIL = 'N', this array is unchanged on exit.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the contents of B are destroyed: all elements but
          those in the first row are set to zero.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C.
          On exit, if EQUIL = 'S', the leading P-by-N part of this
          array contains the balanced matrix C*S, as returned by
          SLICOT Library routine TB01ID.
          If EQUIL = 'N', this array is unchanged on exit.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          If JOBD = 'D', the leading P-by-M part of this array must
          contain the matrix D.
          If JOBD = 'Z', the array D is not referenced.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P), if JOBD = 'D';
          LDD >= 1,        if JOBD = 'Z'.

  NZ      (output) INTEGER array, dimension (LDNZ,M)
          The leading P-by-M part of this array contains the numbers
          of zeros of the elements of the transfer function
          matrix G. Specifically, the (i,j) element of NZ contains
          the number of zeros of the transfer function G(i,j) from
          the j-th input to the i-th output.

  LDNZ    INTEGER
          The leading dimension of array NZ.  LDNZ >= max(1,P).

  NP      (output) INTEGER array, dimension (LDNP,M)
          The leading P-by-M part of this array contains the numbers
          of poles of the elements of the transfer function
          matrix G. Specifically, the (i,j) element of NP contains
          the number of poles of the transfer function G(i,j).

  LDNP    INTEGER
          The leading dimension of array NP.  LDNP >= max(1,P).

  ZEROSR  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
          This array contains the real parts of the zeros of the
          transfer function matrix G. The real parts of the zeros
          are stored in a column-wise order, i.e., for the transfer
          functions (1,1), (2,1), ..., (P,1), (1,2), (2,2), ...,
          (P,2), ..., (1,M), (2,M), ..., (P,M); NPZ memory locations
          are reserved for each transfer function, hence, the real
          parts of the zeros for the (i,j) transfer function
          are stored starting from the location ((j-1)*P+i-1)*NPZ+1.
          Pairs of complex conjugate zeros are stored in consecutive
          memory locations. Note that only the first NZ(i,j) entries
          are initialized for the (i,j) transfer function.

  ZEROSI  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
          This array contains the imaginary parts of the zeros of
          the transfer function matrix G, stored in a similar way
          as the real parts of the zeros.

  POLESR  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
          This array contains the real parts of the poles of the
          transfer function matrix G, stored in the same way as
          the zeros. Note that only the first NP(i,j) entries are
          initialized for the (i,j) transfer function.

  POLESI  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
          This array contains the imaginary parts of the poles of
          the transfer function matrix G, stored in the same way as
          the poles.

  GAINS   (output) DOUBLE PRECISION array, dimension (LDGAIN,M)
          The leading P-by-M part of this array contains the gains
          of the transfer function matrix G. Specifically,
          GAINS(i,j) contains the gain of the transfer function
          G(i,j).

  LDGAIN  INTEGER
          The leading dimension of array GAINS.  LDGAIN >= max(1,P).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the
          controllability of a single-input system (A,b) or (A',c'),
          where b and c' are columns in B and C' (C transposed). If
          the user sets TOL > 0, then the given value of TOL is used
          as an absolute tolerance; elements with absolute value
          less than TOL are considered neglijible. If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used
          instead, where EPS is the machine precision (see LAPACK
          Library routine DLAMCH), and bc denotes the currently used
          column in B or C' (see METHOD).
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N*(N+P) +
                           MAX( N + MAX( N,P ), N*(2*N+3)))
          If N >= P, N >= 1, the formula above can be written as
          LDWORK >= N*(3*N + P + 3).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  the QR algorithm failed to converge when trying to
                compute the zeros of a transfer function;
          = 2:  the QR algorithm failed to converge when trying to
                compute the poles of a transfer function.
                The errors INFO = 1 or 2 are unlikely to appear.
Method 
  The routine implements the pole-zero method proposed in [1].
  This method is based on an algorithm for computing the transfer
  function of a single-input single-output (SISO) system.
  Let (A,b,c,d) be a SISO system. Its transfer function is computed
  as follows:

  1) Find a controllable realization (Ac,bc,cc) of (A,b,c).
  2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc).
  3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)).
  4) Compute the zeros of (Ao,bo,co,d).
  5) Compute the gain of (Ao,bo,co,d).

  This algorithm can be implemented using only orthogonal
  transformations [1]. However, for better efficiency, the
  implementation in TB04CD uses one elementary transformation
  in Step 4 and r elementary transformations in Step 5 (to reduce
  an upper Hessenberg matrix to upper triangular form). These
  special elementary transformations are numerically stable
  in practice.

  In the multi-input multi-output (MIMO) case, the algorithm
  computes each element (i,j) of the transfer function matrix G,
  for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1
  is performed once for each value of j (each column of B). The
  matrices Ac and Ao result in Hessenberg form.
References 
  [1] Varga, A. and Sima, V.
      Numerically Stable Algorithm for Transfer Function Matrix
      Evaluation.
      Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981.
Numerical Aspects 
  The algorithm is numerically stable in practice and requires about
  20*N**3 floating point operations at most, but usually much less.
Further Comments 
  None
Example

Program Text 

*     TB04CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX, NPZMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20,
     $                   NPZMAX = NMAX )
      INTEGER          PMNMAX
      PARAMETER        ( PMNMAX = PMAX*MMAX*NPZMAX )
      INTEGER          LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDGAIN = PMAX, LDNP = PMAX,
     $                   LDNZ = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( NMAX + PMAX ) +
     $                            MAX( NMAX + MAX( NMAX, PMAX ),
     $                                 NMAX*( 2*NMAX + 3 ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, IJ, INFO, J, K, M, N, NPZ, P
      CHARACTER*1      JOBD, EQUIL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), GAINS(LDGAIN,MMAX),
     $                 POLESI(PMNMAX), POLESR(PMNMAX), ZEROSI(PMNMAX),
     $                 ZEROSR(PMNMAX)
      INTEGER          IWORK(LIWORK), NP(LDNP,MMAX), NZ(LDNZ,MMAX)
*     .. External Subroutines ..
      EXTERNAL         TB04CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBD, EQUIL
      NPZ = N
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the transfer matrix T(s) of (A,B,C,D) in the
*              pole-zero-gain form.
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 60 J = 1, M
                     DO 40 I = 1, P
                        IJ = ( (J-1)*P + I-1 )*NPZ + 1
                        IF ( NZ(I,J).EQ.0 ) THEN
                           WRITE ( NOUT, FMT = 99996 ) I, J
                        ELSE
                           WRITE ( NOUT, FMT = 99995 ) I, J,
     $                        ( ZEROSR(K), ZEROSI(K),
     $                                 K = IJ,IJ+NZ(I,J)-1 )
                        END IF
                        WRITE ( NOUT, FMT = 99994 ) I, J,
     $                     ( POLESR(K), POLESI(K), K = IJ,IJ+NP(I,J)-1 )
                        WRITE ( NOUT, FMT = 99993 ) I, J, ( GAINS(I,J) )
   40                CONTINUE
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB04CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB04CD = ',I2)
99997 FORMAT (/' The poles, zeros and gains of the transfer matrix',
     $         ' elements: ')
99996 FORMAT (/' no zeros for element (',I2,',',I2,')')
99995 FORMAT (/' zeros of element (',I2,',',I2,') are ',//
     $         '   real part     imag part '// (2X,F9.4,5X,F9.4))
99994 FORMAT (/' poles of element (',I2,',',I2,') are ',//
     $         '   real part     imag part '// (2X,F9.4,5X,F9.4))
99993 FORMAT (/' gain of element (',I2,',',I2,') is ', F9.4)
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB04CD EXAMPLE PROGRAM DATA
   3     2     2  0.0         D     N
  -1.0   0.0   0.0
   0.0  -2.0   0.0
   0.0   0.0  -3.0
   0.0   1.0  -1.0
   1.0   1.0   0.0
   0.0   1.0   1.0
   1.0   1.0   1.0
   1.0   0.0
   0.0   1.0
Program Results 
 TB04CD EXAMPLE PROGRAM RESULTS


 The poles, zeros and gains of the transfer matrix elements: 

 zeros of element ( 1, 1) are 

   real part     imag part 

    -2.5000        0.8660
    -2.5000       -0.8660

 poles of element ( 1, 1) are 

   real part     imag part 

    -2.0000        0.0000
    -3.0000        0.0000

 gain of element ( 1, 1) is    1.0000

 no zeros for element ( 2, 1)

 poles of element ( 2, 1) are 

   real part     imag part 

    -2.0000        0.0000
    -3.0000        0.0000

 gain of element ( 2, 1) is    1.0000

 no zeros for element ( 1, 2)

 poles of element ( 1, 2) are 

   real part     imag part 

    -2.0000        0.0000

 gain of element ( 1, 2) is    1.0000

 zeros of element ( 2, 2) are 

   real part     imag part 

    -3.6180        0.0000
    -1.3820        0.0000

 poles of element ( 2, 2) are 

   real part     imag part 

    -1.0000        0.0000
    -2.0000        0.0000

 gain of element ( 2, 2) is    1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TB05AD.html000077500000000000000000000330411201767322700160640ustar00rootroot00000000000000 TB05AD - SLICOT Library Routine Documentation

TB05AD

Frequency response matrix of a given state-space representation (A,B,C)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find the complex frequency response matrix (transfer matrix)
  G(freq) of the state-space representation (A,B,C) given by
                                -1
     G(freq) = C * ((freq*I - A)  ) * B

  where A, B and C are real N-by-N, N-by-M and P-by-N matrices
  respectively and freq is a complex scalar.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  BALEIG  CHARACTER*1
          Determines whether the user wishes to balance matrix A
          and/or compute its eigenvalues and/or estimate the
          condition number of the problem as follows:
          = 'N':  The matrix A should not be balanced and neither
                  the eigenvalues of A nor the condition number
                  estimate of the problem are to be calculated;
          = 'C':  The matrix A should not be balanced and only an
                  estimate of the condition number of the problem
                  is to be calculated;
          = 'B' or 'E' and INITA = 'G':  The matrix A is to be
                  balanced and its eigenvalues calculated;
          = 'A' and INITA = 'G':  The matrix A is to be balanced,
                  and its eigenvalues and an estimate of the
                  condition number of the problem are to be
                  calculated.

  INITA   CHARACTER*1
          Specifies whether or not the matrix A is already in upper
          Hessenberg form as follows:
          = 'G':  The matrix A is a general matrix;
          = 'H':  The matrix A is in upper Hessenberg form and
                  neither balancing nor the eigenvalues of A are
                  required.
          INITA must be set to 'G' for the first call to the
          routine, unless the matrix A is already in upper
          Hessenberg form and neither balancing nor the eigenvalues
          of A are required. Thereafter, it must be set to 'H' for
          all subsequent calls.
Input/Output Parameters 
  N       (input) INTEGER
          The number of states, i.e. the order of the state
          transition matrix A.  N >= 0.

  M       (input) INTEGER
          The number of inputs, i.e. the number of columns in the
          matrix B.  M >= 0.

  P       (input) INTEGER
          The number of outputs, i.e. the number of rows in the
          matrix C.  P >= 0.

  FREQ    (input) COMPLEX*16
          The frequency freq at which the frequency response matrix
          (transfer matrix) is to be evaluated.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state transition matrix A.
          If INITA = 'G', then, on exit, the leading N-by-N part of
          this array contains an upper Hessenberg matrix similar to
          (via an orthogonal matrix consisting of a sequence of
          Householder transformations) the original state transition
          matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix B.
          If INITA = 'G', then, on exit, the leading N-by-M part of
          this array contains the product of the transpose of the
          orthogonal transformation matrix used to reduce A to upper
          Hessenberg form and the original input/state matrix B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          If INITA = 'G', then, on exit, the leading P-by-N part of
          this array contains the product of the original output/
          state matrix C and the orthogonal transformation matrix
          used to reduce A to upper Hessenberg form.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  RCOND   (output) DOUBLE PRECISION
          If BALEIG = 'C' or BALEIG = 'A', then RCOND contains an
          estimate of the reciprocal of the condition number of
          matrix H with respect to inversion (see METHOD).

  G       (output) COMPLEX*16 array, dimension (LDG,M)
          The leading P-by-M part of this array contains the
          frequency response matrix G(freq).

  LDG     INTEGER
          The leading dimension of array G.  LDG >= MAX(1,P).

  EVRE,   (output) DOUBLE PRECISION arrays, dimension (N)
  EVIM    If INITA = 'G' and BALEIG = 'B' or 'E' or BALEIG = 'A',
          then these arrays contain the real and imaginary parts,
          respectively, of the eigenvalues of the matrix A.
          Otherwise, these arrays are not referenced.

  HINVB   (output) COMPLEX*16 array, dimension (LDHINV,M)
          The leading N-by-M part of this array contains the
                   -1
          product H  B.

  LDHINV  INTEGER
          The leading dimension of array HINVB.  LDHINV >= MAX(1,N).
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N - 1 + MAX(N,M,P)),
                    if INITA = 'G' and BALEIG = 'N', or 'B', or 'E';
          LDWORK >= MAX(1, N + MAX(N,M-1,P-1)),
                    if INITA = 'G' and BALEIG = 'C', or 'A';
          LDWORK >= MAX(1, 2*N),
                    if INITA = 'H' and BALEIG = 'C', or 'A';
          LDWORK >= 1, otherwise.
          For optimum performance when INITA = 'G' LDWORK should be
          larger.

  ZWORK   COMPLEX*16 array, dimension (LZWORK)

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= MAX(1,N*N+2*N), if BALEIG = 'C', or 'A';
          LZWORK >= MAX(1,N*N),     otherwise.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if more than 30*N iterations are required to
                isolate all the eigenvalues of the matrix A; the
                computations are continued;
          = 2:  if either FREQ is too near to an eigenvalue of the
                matrix A, or RCOND is less than EPS, where EPS is
                the machine  precision (see LAPACK Library routine
                DLAMCH).
Method 
  The matrix A is first balanced (if BALEIG = 'B' or 'E', or
  BALEIG = 'A') and then reduced to upper Hessenberg form; the same
  transformations are applied to the matrix B and the matrix C.
  The complex Hessenberg matrix  H = (freq*I - A) is then used
                    -1
  to solve for C * H  * B.

  Depending on the input values of parameters BALEIG and INITA,
  the eigenvalues of matrix A and the condition number of
  matrix H with respect to inversion are also calculated.
References 
  [1] Laub, A.J.
      Efficient Calculation of Frequency Response Matrices from
      State-Space Models.
      ACM TOMS, 12, pp. 26-33, 1986.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     TB05AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDG, LDHINV
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDG = PMAX,
     $                   LDHINV = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*NMAX )
      INTEGER          LZWORK
      PARAMETER        ( LZWORK = NMAX*( NMAX+2 ) )
*     .. Local Scalars ..
      COMPLEX*16       FREQ
      DOUBLE PRECISION RCOND
      INTEGER          I, INFO, J, M, N, P
      CHARACTER*1      BALEIG, INITA
      LOGICAL          LBALBA, LBALEA, LBALEB, LBALEC, LINITA
*     .. Local Arrays ..
      COMPLEX*16       G(LDG,MMAX), HINVB(LDHINV,MMAX), ZWORK(LZWORK)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), EVIM(NMAX), EVRE(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB05AD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, FREQ, INITA, BALEIG
      LBALEC = LSAME( BALEIG, 'C' )
      LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' )
      LBALEA = LSAME( BALEIG, 'A' )
      LBALBA = LBALEB.OR.LBALEA
      LINITA = LSAME( INITA,  'G' )
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the frequency response matrix of the ssr (A,B,C).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF ( ( LBALEC ) .OR. ( LBALEA ) ) WRITE ( NOUT,
     $                FMT = 99997 ) RCOND
                  IF ( ( LINITA ) .AND. ( LBALBA ) )
     $               WRITE ( NOUT, FMT = 99996 )
     $                       ( EVRE(I), EVIM(I), I = 1,N )
                  WRITE ( NOUT, FMT = 99995 )
                  DO 20 I = 1, P
                     WRITE ( NOUT, FMT = 99994 ) ( G(I,J), J = 1,M )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( HINVB(I,J), J = 1,M )
   40             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB05AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB05AD = ',I2)
99997 FORMAT (' RCOND = ',F4.2)
99996 FORMAT (/' Eigenvalues of the state transmission matrix A are ',
     $       /(1X,2F7.2,'*j'))
99995 FORMAT (/' The frequency response matrix G(freq) is ')
99994 FORMAT (20(' (',F5.2,',',F5.2,') ',:))
99993 FORMAT (/' H(inverse)*B is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
 TB05AD EXAMPLE PROGRAM DATA
   3     1     2     (0.0,0.5)     G     A
   1.0   2.0   0.0
   4.0  -1.0   0.0
   0.0   0.0   1.0
   1.0   0.0   1.0
   1.0   0.0  -1.0
   0.0   0.0   1.0
Program Results 
 TB05AD EXAMPLE PROGRAM RESULTS

 RCOND = 0.22

 Eigenvalues of the state transmission matrix A are 
    3.00   0.00*j
   -3.00   0.00*j
    1.00   0.00*j

 The frequency response matrix G(freq) is 
 ( 0.69, 0.35) 
 (-0.80,-0.40) 

 H(inverse)*B is 
 (-0.11,-0.05) 
 (-0.43, 0.00) 
 (-0.80,-0.40)

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TC01OD.html000077500000000000000000000211661201767322700161040ustar00rootroot00000000000000 TC01OD - SLICOT Library Routine Documentation

TC01OD

Dual of a left/right polynomial matrix representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find the dual right (left) polynomial matrix representation of
  a given left (right) polynomial matrix representation, where the
  right and left polynomial matrix representations are of the form
  Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively.
Specification 
      SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, INFO )
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,*)
Arguments

Mode Parameters 

  LERI    CHARACTER*1
          Indicates whether a left or right matrix fraction is input
          as follows:
          = 'L':  A left matrix fraction is input;
          = 'R':  A right matrix fraction is input.
Input/Output Parameters 
  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  INDLIM  (input) INTEGER
          The highest value of K for which PCOEFF(.,.,K) and
          QCOEFF(.,.,K) are to be transposed.
          K = kpcoef + 1, where kpcoef is the maximum degree of the
          polynomials in P(s).  INDLIM >= 1.

  PCOEFF  (input/output) DOUBLE PRECISION array, dimension
          (LDPCO1,LDPCO2,INDLIM)
          If LERI = 'L' then porm = P, otherwise porm = M.
          On entry, the leading porm-by-porm-by-INDLIM part of this
          array must contain the coefficients of the denominator
          matrix P(s).
          PCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of
          polynomial (I,J) of P(s), where K = 1,2,...,INDLIM.
          On exit, the leading porm-by-porm-by-INDLIM part of this
          array contains the coefficients of the denominator matrix
          P'(s) of the dual system.

  LDPCO1  INTEGER
          The leading dimension of array PCOEFF.
          LDPCO1 >= MAX(1,P) if LERI = 'L',
          LDPCO1 >= MAX(1,M) if LERI = 'R'.

  LDPCO2  INTEGER
          The second dimension of array PCOEFF.
          LDPCO2 >= MAX(1,P) if LERI = 'L',
          LDPCO2 >= MAX(1,M) if LERI = 'R'.

  QCOEFF  (input/output) DOUBLE PRECISION array, dimension
          (LDQCO1,LDQCO2,INDLIM)
          On entry, the leading P-by-M-by-INDLIM part of this array
          must contain the coefficients of the numerator matrix
          Q(s).
          QCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of
          polynomial (I,J) of Q(s), where K = 1,2,...,INDLIM.
          On exit, the leading M-by-P-by-INDLIM part of the array
          contains the coefficients of the numerator matrix Q'(s)
          of the dual system.

  LDQCO1  INTEGER
          The leading dimension of array QCOEFF.
          LDQCO1 >= MAX(1,M,P).

  LDQCO2  INTEGER
          The second dimension of array QCOEFF.
          LDQCO2 >= MAX(1,M,P).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  If the given M-input/P-output left (right) polynomial matrix
  representation has numerator matrix Q(s) and denominator matrix
  P(s), its dual P-input/M-output right (left) polynomial matrix
  representation simply has numerator matrix Q'(s) and denominator
  matrix P'(s).
References 
  None.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     TC01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, PMAX, INDMAX
      PARAMETER        ( MMAX = 20, PMAX = 20, INDMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDPCO1, LDPCO2, LDQCO1, LDQCO2
      PARAMETER        ( LDPCO1 = MAXMP, LDPCO2 = MAXMP,
     $                   LDQCO1 = MAXMP, LDQCO2 = MAXMP )
*     .. Local Scalars ..
      INTEGER          I, INDLIM, INFO, J, K, M, P, PORM
      CHARACTER*1      LERI
      LOGICAL          LLERI
*     .. Local Arrays ..
      DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,INDMAX),
     $                 QCOEFF(LDQCO1,LDQCO2,INDMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TC01OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, P, INDLIM, LERI
      LLERI = LSAME( LERI, 'L' )
      IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) M
      ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) P
      ELSE IF ( INDLIM.LE.0 .OR. INDLIM.GT.INDMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) INDLIM
      ELSE
         PORM = P
         IF ( .NOT.LLERI ) PORM = M
         READ ( NIN, FMT = * )
     $      ( ( ( PCOEFF(I,J,K), K = 1,INDLIM ), J = 1,PORM ),
     $                           I = 1,PORM )
         READ ( NIN, FMT = * )
     $      ( ( ( QCOEFF(I,J,K), K = 1,INDLIM ), J = 1,M ), I = 1,P )
*        Find the dual right pmr of the given left pmr.
         CALL TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2,
     $                QCOEFF, LDQCO1, LDQCO2, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 40 I = 1, PORM
               DO 20 J = 1, PORM
                  WRITE ( NOUT, FMT = 99996 ) I, J,
     $              ( PCOEFF(I,J,K), K = 1,INDLIM )
   20          CONTINUE
   40       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 80 I = 1, M
               DO 60 J = 1, P
                  WRITE ( NOUT, FMT = 99996 ) I, J,
     $              ( QCOEFF(I,J,K), K = 1,INDLIM )
   60          CONTINUE
   80       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' TC01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TC01OD = ',I2)
99997 FORMAT (' The coefficients of the denominator matrix of the dual',
     $       ' system are ')
99996 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2))
99995 FORMAT (//' The coefficients of the numerator matrix of the dual',
     $       ' system are ')
99994 FORMAT (/' M is out of range.',/' M = ',I5)
99993 FORMAT (/' P is out of range.',/' P = ',I5)
99992 FORMAT (/' INDLIM is out of range.',/' INDLIM = ',I5)
      END
Program Data 
 TC01OD EXAMPLE PROGRAM DATA
   2     2     3     L
   2.0   3.0   1.0
   4.0  -1.0  -1.0
   5.0   7.0  -6.0
   3.0   2.0   2.0
   6.0  -1.0   5.0
   1.0   7.0   5.0
   1.0   1.0   1.0
   4.0   1.0  -1.0
Program Results 
 TC01OD EXAMPLE PROGRAM RESULTS

 The coefficients of the denominator matrix of the dual system are 

 element ( 1, 1) is    2.00   3.00   1.00

 element ( 1, 2) is    5.00   7.00  -6.00

 element ( 2, 1) is    4.00  -1.00  -1.00

 element ( 2, 2) is    3.00   2.00   2.00


 The coefficients of the numerator matrix of the dual system are 

 element ( 1, 1) is    6.00  -1.00   5.00

 element ( 1, 2) is    1.00   1.00   1.00

 element ( 2, 1) is    1.00   7.00   5.00

 element ( 2, 2) is    4.00   1.00  -1.00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TC04AD.html000077500000000000000000000342311201767322700160660ustar00rootroot00000000000000 TC04AD - SLICOT Library Routine Documentation

TC04AD

State-space representation for a given left/right polynomial matrix representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a state-space representation (A,B,C,D) with the same
  transfer matrix T(s) as that of a given left or right polynomial
  matrix representation, i.e.

     C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)).
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  LERI    CHARACTER*1
          Indicates whether a left polynomial matrix representation
          or a right polynomial matrix representation is input as
          follows:
          = 'L':  A left matrix fraction is input;
          = 'R':  A right matrix fraction is input.
Input/Output Parameters 
  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  INDEX   (input) INTEGER array, dimension (MAX(M,P))
          If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the
          maximum degree of the polynomials in the I-th row of the
          denominator matrix P(s) of the given left polynomial
          matrix representation.
          If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the
          maximum degree of the polynomials in the I-th column of
          the denominator matrix P(s) of the given right polynomial
          matrix representation.

  PCOEFF  (input) DOUBLE PRECISION array, dimension
          (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1.
          If LERI = 'L' then porm = P, otherwise porm = M.
          The leading porm-by-porm-by-kpcoef part of this array must
          contain the coefficients of the denominator matrix P(s).
          PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
          of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
          LERI = 'L' then iorj = I, otherwise iorj = J.
          Thus for LERI = 'L', P(s) =
          diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
          If LERI = 'R', PCOEFF is modified by the routine but
          restored on exit.

  LDPCO1  INTEGER
          The leading dimension of array PCOEFF.
          LDPCO1 >= MAX(1,P) if LERI = 'L',
          LDPCO1 >= MAX(1,M) if LERI = 'R'.

  LDPCO2  INTEGER
          The second dimension of array PCOEFF.
          LDPCO2 >= MAX(1,P) if LERI = 'L',
          LDPCO2 >= MAX(1,M) if LERI = 'R'.

  QCOEFF  (input) DOUBLE PRECISION array, dimension
          (LDQCO1,LDQCO2,kpcoef)
          If LERI = 'L' then porp = M, otherwise porp = P.
          The leading porm-by-porp-by-kpcoef part of this array must
          contain the coefficients of the numerator matrix Q(s).
          QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
          If LERI = 'R', QCOEFF is modified by the routine but
          restored on exit.

  LDQCO1  INTEGER
          The leading dimension of array QCOEFF.
          LDQCO1 >= MAX(1,P)   if LERI = 'L',
          LDQCO1 >= MAX(1,M,P) if LERI = 'R'.

  LDQCO2  INTEGER
          The second dimension of array QCOEFF.
          LDQCO2 >= MAX(1,M)   if LERI = 'L',
          LDQCO2 >= MAX(1,M,P) if LERI = 'R'.

  N       (output) INTEGER
          The order of the resulting state-space representation.
                       porm
          That is, N = SUM INDEX(I).
                       I=1

  RCOND   (output) DOUBLE PRECISION
          The estimated reciprocal of the condition number of the
          leading row (if LERI = 'L') or the leading column (if
          LERI = 'R') coefficient matrix of P(s).
          If RCOND is nearly zero, P(s) is nearly row or column
          non-proper.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array contains the state
          dynamics matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P))
          The leading N-by-M part of this array contains the
          input/state matrix B; the remainder of the leading
          N-by-MAX(M,P) part is used as internal workspace.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array contains the
          state/output matrix C; the remainder of the leading
          MAX(M,P)-by-N part is used as internal workspace.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M,P).

  D       (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
          The leading P-by-M part of this array contains the direct
          transmission matrix D; the remainder of the leading
          MAX(M,P)-by-MAX(M,P) part is used as internal workspace.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,M,P).
Workspace 
  IWORK   INTEGER array, dimension (2*MAX(M,P))

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,MAX(M,P)*(MAX(M,P)+4)).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if P(s) is not row (if LERI = 'L') or column
                (if LERI = 'R') proper. Consequently, no state-space
                representation is calculated.
Method 
  The method for a left matrix fraction will be described here;
  right matrix fractions are dealt with by obtaining the dual left
  polynomial matrix representation and constructing an equivalent
  state-space representation for this. The first step is to check
  if the denominator matrix P(s) is row proper; if it is not then
  the routine returns with the Error Indicator (INFO) set to 1.
  Otherwise, Wolovich's Observable  Structure Theorem is used to
  construct a state-space representation (A,B,C,D) in observable
  companion form. The sizes of the blocks of matrix A and matrix C
  here are precisely the row degrees of P(s), while their
  'non-trivial' columns are given easily from its coefficients.
  Similarly, the matrix D is obtained from the leading coefficients
  of P(s) and of the numerator matrix Q(s), while matrix B is given
  by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a
  polynomial matrix whose (j,k)(th) element is given by

               j-u(k-1)-1
            ( s           , j = u(k-1)+1,u(k-1)+2,....,u(k)
  Sbar    = (
     j,k    (           0 , otherwise

          k
  u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d  are the
         i=1  i                     1  2      M
  controllability indices. For convenience in solving this, C' and B
  are initially set up to contain the coefficients of P(s) and Q(s),
  respectively, stored by rows.
References 
  [1] Wolovich, W.A.
      Linear Multivariate Systems, (Theorem 4.3.3).
      Springer-Verlag, 1974.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     TC04AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, PMAX, KPCMAX, NMAX
      PARAMETER        ( MMAX = 5, PMAX = 5, KPCMAX = 5, NMAX = 5 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDPCO1, LDPCO2, LDQCO1, LDQCO2, LDA, LDB, LDC,
     $                 LDD
      PARAMETER        ( LDPCO1 = MAXMP, LDPCO2 = MAXMP,
     $                   LDQCO1 = MAXMP, LDQCO2 = MAXMP,
     $                   LDA = NMAX, LDB = NMAX, LDC = MAXMP,
     $                   LDD = MAXMP )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = ( MAXMP )*( MAXMP+4 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION RCOND
      INTEGER          I, INFO, J, K, KPCOEF, M, N, P, PORM, PORP
      CHARACTER*1      LERI
      LOGICAL          LLERI
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP), PCOEFF(LDPCO1,LDPCO2,KPCMAX),
     $                 QCOEFF(LDQCO1,LDQCO2,KPCMAX), DWORK(LDWORK)
      INTEGER          INDEX(MAXMP), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TC04AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, P, LERI
      LLERI = LSAME( LERI, 'L' )
      IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) M
      ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) P
      ELSE
         PORM = P
         IF ( .NOT.LLERI ) PORM = M
         READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM )
         PORP = M
         IF ( .NOT.LLERI ) PORP = P
         KPCOEF = 0
         DO 20 I = 1, PORM
            KPCOEF = MAX( KPCOEF, INDEX(I) )
   20    CONTINUE
         KPCOEF = KPCOEF + 1
         IF ( KPCOEF.LE.0 .OR. KPCOEF.GT.KPCMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) KPCOEF
         ELSE
            READ ( NIN, FMT = * )
     $         ( ( ( PCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORM ),
     $                              I = 1,PORM )
            READ ( NIN, FMT = * )
     $         ( ( ( QCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORP ),
     $                              I = 1,PORM )
*           Find a ssr of the given left pmr.
            CALL 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 )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) N, RCOND
               WRITE ( NOUT, FMT = 99996 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 60 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   60          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 80 I = 1, P
                  WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   80          CONTINUE
               WRITE ( NOUT, FMT = 99992 )
               DO 100 I = 1, P
                  WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M )
  100          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TC04AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TC04AD = ',I2)
99997 FORMAT (' The order of the resulting state-space representation ',
     $       ' =  ',I2,//' RCOND = ',F4.2)
99996 FORMAT (/' The state dynamics matrix A is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' The input/state matrix B is ')
99993 FORMAT (/' The state/output matrix C is ')
99992 FORMAT (/' The direct transmission matrix D is ')
99991 FORMAT (/' M is out of range.',/' M = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
99989 FORMAT (/' KPCOEF is out of range.',/' KPCOEF = ',I5)
      END
Program Data 
 TC04AD EXAMPLE PROGRAM DATA
   2     2     L
   2     2
   2.0   3.0   1.0
   4.0  -1.0  -1.0
   5.0   7.0  -6.0
   3.0   2.0   2.0
   6.0  -1.0   5.0
   1.0   7.0   5.0
   1.0   1.0   1.0
   4.0   1.0  -1.0
Program Results 
 TC04AD EXAMPLE PROGRAM RESULTS

 The order of the resulting state-space representation  =   4

 RCOND = 0.25

 The state dynamics matrix A is 
   0.0000   0.5714   0.0000  -0.4286
   1.0000   1.0000   0.0000  -1.0000
   0.0000  -2.0000   0.0000   2.0000
   0.0000   0.7857   1.0000  -1.7143

 The input/state matrix B is 
   8.0000   3.8571
   4.0000   4.0000
  -9.0000   5.0000
   4.0000  -5.0714

 The state/output matrix C is 
   0.0000  -0.2143   0.0000   0.2857
   0.0000   0.3571   0.0000  -0.1429

 The direct transmission matrix D is 
  -1.0000   0.9286
   2.0000  -0.2143

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TC05AD.html000077500000000000000000000270111201767322700160650ustar00rootroot00000000000000 TC05AD - SLICOT Library Routine Documentation

TC05AD

Frequency response of a left/right polynomial matrix representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To evaluate the transfer matrix T(s) of a left polynomial matrix
  representation [T(s) = inv(P(s))*Q(s)] or a right polynomial
  matrix representation [T(s) = Q(s)*inv(P(s))] at any specified
  complex frequency s = SVAL.

  This routine will calculate the standard frequency response
  matrix at frequency omega if SVAL is supplied as (0.0,omega).
Specification 
      SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1,
     $                   LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR,
     $                   LDCFRE, IWORK, DWORK, ZWORK, INFO )
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(*)
Arguments

Mode Parameters 

  LERI    CHARACTER*1
          Indicates whether a left polynomial matrix representation
          or a right polynomial matrix representation is to be used
          to evaluate the transfer matrix as follows:
          = 'L':  A left matrix fraction is input;
          = 'R':  A right matrix fraction is input.
Input/Output Parameters 
  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  SVAL    (input) COMPLEX*16
          The frequency at which the transfer matrix or the
          frequency respose matrix is to be evaluated.
          For a standard frequency response set the real part
          of SVAL to zero.

  INDEX   (input) INTEGER array, dimension (MAX(M,P))
          If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the
          maximum degree of the polynomials in the I-th row of the
          denominator matrix P(s) of the given left polynomial
          matrix representation.
          If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the
          maximum degree of the polynomials in the I-th column of
          the denominator matrix P(s) of the given right polynomial
          matrix representation.

  PCOEFF  (input) DOUBLE PRECISION array, dimension
          (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1.
          If LERI = 'L' then porm = P, otherwise porm = M.
          The leading porm-by-porm-by-kpcoef part of this array must
          contain the coefficients of the denominator matrix P(s).
          PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
          of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
          LERI = 'L' then iorj = I, otherwise iorj = J.
          Thus for LERI = 'L', P(s) =
          diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
          If LERI = 'R', PCOEFF is modified by the routine but
          restored on exit.

  LDPCO1  INTEGER
          The leading dimension of array PCOEFF.
          LDPCO1 >= MAX(1,P) if LERI = 'L',
          LDPCO1 >= MAX(1,M) if LERI = 'R'.

  LDPCO2  INTEGER
          The second dimension of array PCOEFF.
          LDPCO2 >= MAX(1,P) if LERI = 'L',
          LDPCO2 >= MAX(1,M) if LERI = 'R'.

  QCOEFF  (input) DOUBLE PRECISION array, dimension
          (LDQCO1,LDQCO2,kpcoef)
          If LERI = 'L' then porp = M, otherwise porp = P.
          The leading porm-by-porp-by-kpcoef part of this array must
          contain the coefficients of the numerator matrix Q(s).
          QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
          If LERI = 'R', QCOEFF is modified by the routine but
          restored on exit.

  LDQCO1  INTEGER
          The leading dimension of array QCOEFF.
          LDQCO1 >= MAX(1,P)   if LERI = 'L',
          LDQCO1 >= MAX(1,M,P) if LERI = 'R'.

  LDQCO2  INTEGER
          The second dimension of array QCOEFF.
          LDQCO2 >= MAX(1,M)   if LERI = 'L',
          LDQCO2 >= MAX(1,M,P) if LERI = 'R'.

  RCOND   (output) DOUBLE PRECISION
          The estimated reciprocal of the condition number of the
          denominator matrix P(SVAL).
          If RCOND is nearly zero, SVAL is approximately a system
          pole.

  CFREQR  (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P))
          The leading porm-by-porp part of this array contains the
          frequency response matrix T(SVAL).

  LDCFRE  INTEGER
          The leading dimension of array CFREQR.
          LDCFRE >= MAX(1,P)   if LERI = 'L',
          LDCFRE >= MAX(1,M,P) if LERI = 'R'.
Workspace 
  IWORK   INTEGER array, dimension (liwork)
          where liwork = P, if LERI = 'L',
                liwork = M, if LERI = 'R'.

  DWORK   DOUBLE PRECISION array, dimension (ldwork)
          where ldwork = 2*P, if LERI = 'L',
                ldwork = 2*M, if LERI = 'R'.

  ZWORK   COMPLEX*16 array, dimension (lzwork),
          where lzwork = P*(P+2), if LERI = 'L',
                lzwork = M*(M+2), if LERI = 'R'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if P(SVAL) is exactly or nearly singular;
                no frequency response is calculated.
Method 
  The method for a left matrix fraction will be described here;
  right matrix fractions are dealt with by obtaining the dual left
  fraction and calculating its frequency response (see SLICOT
  Library routine TC01OD). The first step is to calculate the
  complex value P(SVAL) of the denominator matrix P(s) at the
  desired frequency SVAL. If P(SVAL) is approximately singular,
  SVAL is approximately a pole of this system and so the frequency
  response matrix T(SVAL) is not calculated; in this case, the
  routine returns with the Error Indicator (INFO) set to 1.
  Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s)
  at frequency SVAL is calculated in a similar way to P(SVAL), and
  the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is
  found by solving the corresponding system of complex linear
  equations.
References 
  None
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     TC05AD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, PMAX, KPCMAX
      PARAMETER        ( MMAX = 20, PMAX = 20, KPCMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2
      PARAMETER        ( LDCFRE = MAXMP, LDPCO1 = MAXMP,
     $                   LDPCO2 = MAXMP, LDQCO1 = MAXMP,
     $                   LDQCO2 = MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*MAXMP )
      INTEGER          LZWORK
      PARAMETER        ( LZWORK = ( MAXMP )*( MAXMP+2 ) )
*     .. Local Scalars ..
      COMPLEX*16       SVAL
      DOUBLE PRECISION RCOND
      INTEGER          I, INFO, J, K, KPCOEF, M, P, PORM, PORP
      CHARACTER*1      LERI
      LOGICAL          LLERI
*     .. Local Arrays ..
      COMPLEX*16       CFREQR(LDCFRE,MAXMP), ZWORK(LZWORK)
      DOUBLE PRECISION DWORK(LDWORK), PCOEFF(LDPCO1,LDPCO2,KPCMAX),
     $                 QCOEFF(LDQCO1,LDQCO2,KPCMAX)
      INTEGER          INDEX(MAXMP), IWORK(MAXMP)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TC05AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, P, SVAL, LERI
      LLERI = LSAME( LERI, 'L' )
      IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) M
      ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) P
      ELSE
         PORM = P
         IF ( .NOT.LLERI ) PORM = M
         READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM )
         PORP = M
         IF ( .NOT.LLERI ) PORP = P
         KPCOEF = 0
         DO 20 I = 1, PORM
            KPCOEF = MAX( KPCOEF, INDEX(I) )
   20    CONTINUE
         KPCOEF = KPCOEF + 1
         IF ( KPCOEF.LE.0 .OR. KPCOEF.GT.KPCMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) KPCOEF
         ELSE
            READ ( NIN, FMT = * )
     $         ( ( ( PCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORM ),
     $                              I = 1,PORM )
            READ ( NIN, FMT = * )
     $         ( ( ( QCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORP ),
     $                              I = 1,PORM )
*           Find the standard frequency response matrix of left pmr
*           at 0.5*j.
            CALL TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1,
     $                   LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR,
     $                   LDCFRE, IWORK, DWORK, ZWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) RCOND
               DO 40 I = 1, PORM
                  WRITE ( NOUT, FMT = 99996 )
     $                  ( CFREQR(I,J), J = 1,PORP )
   40          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TC05AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TC05AD = ',I2)
99997 FORMAT (' RCOND = ',F4.2,//' The frequency response matrix T(SVA',
     $       'L) is ')
99996 FORMAT (20(' (',F5.2,',',F5.2,') ',:))
99995 FORMAT (/' M is out of range.',/' M = ',I5)
99994 FORMAT (/' P is out of range.',/' P = ',I5)
99993 FORMAT (/' KPCOEF is out of range.',/' KPCOEF = ',I5)
      END
Program Data 
 TC05AD EXAMPLE PROGRAM DATA
   2     2     (0.0,0.5)     L
   2     2
   2.0   3.0   1.0
   4.0  -1.0  -1.0
   5.0   7.0  -6.0
   3.0   2.0   2.0
   6.0  -1.0   5.0
   1.0   7.0   5.0
   1.0   1.0   1.0
   4.0   1.0  -1.0
Program Results 
 TC05AD EXAMPLE PROGRAM RESULTS

 RCOND = 0.19

 The frequency response matrix T(SVAL) is 
 (-0.25,-0.33)  ( 0.26,-0.45) 
 (-1.48, 0.35)  (-2.25,-1.11)

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TD03AD.html000077500000000000000000000536711201767322700160770ustar00rootroot00000000000000 TD03AD - SLICOT Library Routine Documentation

TD03AD

Left/right polynomial matrix representation for a proper transfer matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a relatively prime left or right polynomial matrix
  representation for a proper transfer matrix T(s) given as either
  row or column polynomial vectors over common denominator
  polynomials, possibly with uncancelled common terms.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  ROWCOL  CHARACTER*1
          Indicates whether T(s) is to be factorized by rows or by
          columns as follows:
          = 'R':  T(s) is factorized by rows;
          = 'C':  T(s) is factorized by columns.

  LERI    CHARACTER*1
          Indicates whether a left or a right polynomial matrix
          representation is required as follows:
          = 'L':  A left polynomial matrix representation
                  inv(P(s))*Q(s) is required;
          = 'R':  A right polynomial matrix representation
                  Q(s)*inv(P(s)) is required.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to balance the triplet
          (A,B,C), before computing a minimal state-space
          representation, as follows:
          = 'S':  Perform balancing (scaling);
          = 'N':  Do not perform balancing.
Input/Output Parameters 
  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  INDEXD  (input) INTEGER array, dimension (P), if ROWCOL = 'R', or
                                 dimension (M), if ROWCOL = 'C'.
          The leading pormd elements of this array must contain the
          row degrees of the denominator polynomials in D(s).
          pormd = P if the transfer matrix T(s) is given as row
          polynomial vectors over denominator polynomials;
          pormd = M if the transfer matrix T(s) is given as column
          polynomial vectors over denominator polynomials.

  DCOEFF  (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef),
          where kdcoef = MAX(INDEXD(I)) + 1.
          The leading pormd-by-kdcoef part of this array must
          contain the coefficients of each denominator polynomial.
          DCOEFF(I,K) is the coefficient in s**(INDEXD(I)-K+1) of
          the I-th denominator polynomial in D(s), where K = 1,2,
          ...,kdcoef.

  LDDCOE  INTEGER
          The leading dimension of array DCOEFF.
          LDDCOE >= MAX(1,P), if ROWCOL = 'R';
          LDDCOE >= MAX(1,M), if ROWCOL = 'C'.

  UCOEFF  (input) DOUBLE PRECISION array, dimension
          (LDUCO1,LDUCO2,kdcoef)
          The leading P-by-M-by-kdcoef part of this array must
          contain the coefficients of the numerator matrix U(s);
          if ROWCOL = 'C', this array is modified internally but
          restored on exit, and the remainder of the leading
          MAX(M,P)-by-MAX(M,P)-by-kdcoef part is used as internal
          workspace.
          UCOEFF(I,J,K) is the coefficient in s**(INDEXD(iorj)-K+1)
          of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef;
          iorj = I if T(s) is given as row polynomial vectors over
          denominator polynomials; iorj = J if T(s) is given as
          column polynomial vectors over denominator polynomials.
          Thus for ROWCOL = 'R', U(s) =
          diag(s**INDEXD(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...).

  LDUCO1  INTEGER
          The leading dimension of array UCOEFF.
          LDUCO1 >= MAX(1,P),   if ROWCOL = 'R';
          LDUCO1 >= MAX(1,M,P), if ROWCOL = 'C'.

  LDUCO2  INTEGER
          The second dimension of array UCOEFF.
          LDUCO2 >= MAX(1,M),   if ROWCOL = 'R';
          LDUCO2 >= MAX(1,M,P), if ROWCOL = 'C'.

  NR      (output) INTEGER
          The order of the resulting minimal realization, i.e. the
          order of the state dynamics matrix A.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N),
                   pormd
          where N = SUM INDEXD(I)
                    I=1
          The leading NR-by-NR part of this array contains the upper
          block Hessenberg state dynamics matrix A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P))
          The leading NR-by-M part of this array contains the
          input/state matrix B; the remainder of the leading
          N-by-MAX(M,P) part is used as internal workspace.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-NR part of this array contains the
          state/output matrix C; the remainder of the leading
          MAX(M,P)-by-N part is used as internal workspace.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M,P).

  D       (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
          The leading P-by-M part of this array contains the direct
          transmission matrix D; the remainder of the leading
          MAX(M,P)-by-MAX(M,P) part is used as internal workspace.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,M,P).

  INDEXP  (output) INTEGER array, dimension (P), if ROWCOL = 'R', or
                                  dimension (M), if ROWCOL = 'C'.
          The leading pormp elements of this array contain the
          row (column if ROWCOL = 'C') degrees of the denominator
          matrix P(s).
          pormp = P if a left polynomial matrix representation
          is requested; pormp = M if a right polynomial matrix
          representation is requested.
          These elements are ordered so that
          INDEXP(1) >= INDEXP(2) >= ... >= INDEXP(pormp).

  PCOEFF  (output) DOUBLE PRECISION array, dimension
          (LDPCO1,LDPCO2,N+1)
          The leading pormp-by-pormp-by-kpcoef part of this array
          contains the coefficients of the denominator matrix P(s),
          where kpcoef = MAX(INDEXP(I)) + 1.
          PCOEFF(I,J,K) is the coefficient in s**(INDEXP(iorj)-K+1)
          of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef;
          iorj = I if a left polynomial matrix representation is
          requested; iorj = J if a right polynomial matrix
          representation is requested.
          Thus for a left polynomial matrix representation, P(s) =
          diag(s**INDEXP(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).

  LDPCO1  INTEGER
          The leading dimension of array PCOEFF.
          LDPCO1 >= MAX(1,P), if ROWCOL = 'R';
          LDPCO1 >= MAX(1,M), if ROWCOL = 'C'.

  LDPCO2  INTEGER
          The second dimension of array PCOEFF.
          LDPCO2 >= MAX(1,P), if ROWCOL = 'R';
          LDPCO2 >= MAX(1,M), if ROWCOL = 'C'.

  QCOEFF  (output) DOUBLE PRECISION array, dimension
          (LDQCO1,LDQCO2,N+1)
          The leading pormp-by-pormd-by-kpcoef part of this array
          contains the coefficients of the numerator matrix Q(s).
          QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).

  LDQCO1  INTEGER
          The leading dimension of array QCOEFF.
          If LERI = 'L', LDQCO1 >= MAX(1,PM),
                                   where PM = P, if ROWCOL = 'R';
                                         PM = M, if ROWCOL = 'C'.
          If LERI = 'R', LDQCO1 >= MAX(1,M,P).

  LDQCO2  INTEGER
          The second dimension of array QCOEFF.
          If LERI = 'L', LDQCO2 >= MAX(1,MP),
                                   where MP = M, if ROWCOL = 'R';
                                         MP = P, if ROWCOL = 'C'.
          If LERI = 'R', LDQCO2 >= MAX(1,M,P).

  VCOEFF  (output) DOUBLE PRECISION array, dimension
          (LDVCO1,LDVCO2,N+1)
          The leading pormp-by-NR-by-kpcoef part of this array
          contains the coefficients of the intermediate matrix
          V(s) as produced by SLICOT Library routine TB03AD.

  LDVCO1  INTEGER
          The leading dimension of array VCOEFF.
          LDVCO1 >= MAX(1,P), if ROWCOL = 'R';
          LDVCO1 >= MAX(1,M), if ROWCOL = 'C'.

  LDVCO2  INTEGER
          The second dimension of array VCOEFF.  LDVCO2 >= MAX(1,N).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B, C). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance
          (determined by the SLICOT routine TB01UD) is used instead.
Workspace 
  IWORK   INTEGER array, dimension (N+MAX(M,P))
          On exit, if INFO = 0, the first nonzero elements of
          IWORK(1:N) return the orders of the diagonal blocks of A.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2))
          where  PM = P, if ROWCOL = 'R';
                 PM = M, if ROWCOL = 'C'.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i (i <= k = pormd), then i is the first
                integer I for which ABS( DCOEFF(I,1) ) is so small
                that the calculations would overflow (see SLICOT
                Library routine TD03AY); that is, the leading
                coefficient of a polynomial is nearly zero; no
                state-space representation or polynomial matrix
                representation is calculated;
          = k+1:  if a singular matrix was encountered during the
                computation of V(s);
          = k+2:  if a singular matrix was encountered during the
                computation of P(s).
Method 
  The method for transfer matrices factorized by rows will be
  described here; T(s) factorized by columns is dealt with by
  operating on the dual T'(s). The description for T(s) is actually
  the left polynomial matrix representation

       T(s) = inv(D(s))*U(s),

  where D(s) is diagonal with its (I,I)-th polynomial element of
  degree INDEXD(I). The first step is to check whether the leading
  coefficient of any polynomial element of D(s) is approximately
  zero, if so the routine returns with INFO > 0. Otherwise,
  Wolovich's Observable Structure Theorem is used to construct a
  state-space representation in observable companion form which is
  equivalent to the above polynomial matrix representation. The
  method is particularly easy here due to the diagonal form of D(s).
  This state-space representation is not necessarily controllable
  (as D(s) and U(s) are not necessarily relatively left prime), but
  it is in theory completely observable; however, its observability
  matrix may be poorly conditioned, so it is treated as a general
  state-space representation and SLICOT Library routine TB03AD is
  used to separate out a minimal realization for T(s) from it by
  means of orthogonal similarity transformations and then to
  calculate a relatively prime (left or right) polynomial matrix
  representation which is equivalent to this.
References 
  [1] Patel, R.V.
      On Computing Matrix Fraction Descriptions and Canonical
      Forms of Linear Time-Invariant Systems.
      UMIST Control Systems Centre Report 489, 1980.

  [2] Wolovich, W.A.
      Linear Multivariable Systems, (Theorem 4.3.3).
      Springer-Verlag, 1974.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     TD03AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, PMAX, KDCMAX, NMAX
      PARAMETER        ( MMAX = 8, PMAX = 8, KDCMAX = 8, NMAX = 8 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, LDPCO2,
     $                 LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, LDVCO2
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MAXMP,
     $                   LDD = MAXMP, LDDCOE = MAXMP,
     $                   LDPCO1 = MAXMP, LDPCO2 = MAXMP,
     $                   LDQCO1 = MAXMP, LDQCO2 = MAXMP,
     $                   LDUCO1 = MAXMP, LDUCO2 = MAXMP,
     $                   LDVCO1 = MAXMP, LDVCO2 = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX + MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX + MAX( NMAX, 3*MAXMP ),
     $                                 MAXMP*( MAXMP + 2 ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      CHARACTER*1      EQUIL, LERI, ROWCOL
      INTEGER          I, INDBLK, INFO, J, K, KDCOEF, M, MAXINP, N, NR,
     $                 P, PORMD, PORMP
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP), DCOEFF(LDDCOE,KDCMAX),
     $                 DWORK(LDWORK), PCOEFF(LDPCO1,LDPCO2,NMAX+1),
     $                 QCOEFF(LDQCO1,LDQCO2,NMAX+1),
     $                 UCOEFF(LDUCO1,LDUCO2,KDCMAX),
     $                 VCOEFF(LDVCO1,LDVCO2,NMAX+1)
      INTEGER          INDEXD(MAXMP), INDEXP(MAXMP), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TD03AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, P, TOL, ROWCOL, LERI, EQUIL
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99986 ) M
      ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99985 ) P
      ELSE
         PORMD = P
         IF ( LSAME( ROWCOL, 'C' ) ) PORMD = M
         PORMP = M
         IF ( LSAME( LERI, 'R' ) ) PORMP = P
         READ ( NIN, FMT = * ) ( INDEXD(I), I = 1,PORMD )
*
         KDCOEF = 0
         N = 0
         DO 20 I = 1, PORMD
            KDCOEF = MAX( KDCOEF, INDEXD(I) )
            N = N + INDEXD(I)
   20    CONTINUE
         KDCOEF = KDCOEF + 1
*
         IF ( KDCOEF.LE.0 .OR. KDCOEF.GT.KDCMAX ) THEN
            WRITE ( NOUT, FMT = 99984 ) KDCOEF
         ELSE
            READ ( NIN, FMT = * )
     $         ( ( DCOEFF(I,J), J = 1,KDCOEF ), I = 1,PORMD )
            READ ( NIN, FMT = * )
     $         ( ( ( UCOEFF(I,J,K), K = 1,KDCOEF ), J = 1,M ), I = 1,P )
*           Find a relatively prime left pmr for the given transfer
*           function.
            CALL 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 )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) NR
               DO 40 I = 1, NR
                  WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 60 I = 1, NR
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   60          CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 80 I = 1, P
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR )
   80          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 100 I = 1, P
                  WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M )
  100          CONTINUE
               INDBLK = 0
               DO 120 I = 1, N
                  IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1
  120          CONTINUE
               IF ( LSAME( LERI, 'L' ) ) THEN
                  WRITE ( NOUT, FMT = 99992 ) INDBLK,
     $                  ( IWORK(I), I = 1,INDBLK )
                  WRITE ( NOUT, FMT = 99990 ) ( INDEXP(I), I = 1,P )
               ELSE
                  WRITE ( NOUT, FMT = 99991 ) INDBLK,
     $                  ( IWORK(I), I = 1,INDBLK )
                  WRITE ( NOUT, FMT = 99989 ) ( INDEXP(I), I = 1,M )
               END IF
               MAXINP = 0
               DO 140 I = 1, PORMP
                  MAXINP = MAX( MAXINP, INDEXP(I) )
  140          CONTINUE
               MAXINP = MAXINP + 1
               WRITE ( NOUT, FMT = 99988 )
               DO 180 I = 1, PORMP
                  DO 160 J = 1, PORMP
                     WRITE ( NOUT, FMT = 99996 )
     $                     ( PCOEFF(I,J,K), K = 1,MAXINP )
  160             CONTINUE
  180          CONTINUE
               WRITE ( NOUT, FMT = 99987 )
               DO 220 I = 1, PORMP
                  DO 200 J = 1, PORMD
                     WRITE ( NOUT, FMT = 99996 )
     $                     ( QCOEFF(I,J,K), K = 1,MAXINP )
  200             CONTINUE
  220          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TD03AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TD03AD = ',I2)
99997 FORMAT (' The order of the resulting minimal realization = ',I2,
     $       //' The state dynamics matrix A is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix B is ')
99994 FORMAT (/' The state/output matrix C is ')
99993 FORMAT (/' The direct transmission matrix D is ')
99992 FORMAT (/' The observability index of the minimal realization = ',
     $       I2,//' The dimensions of the diagonal blocks of the state',
     $       ' dynamics matrix are ',/20(I5))
99991 FORMAT (/' The controllability index of the minimal realization ',
     $       '= ',I2,//' The dimensions of the diagonal blocks of the ',
     $       'state dynamics matrix are ',/20(I5))
99990 FORMAT (/' The row degrees of the denominator matrix P(s) are',
     $       /20(I5))
99989 FORMAT (/' The column degrees of the denominator matrix P(s) are',
     $       /20(I5))
99988 FORMAT (/' The denominator matrix P(s) is ')
99987 FORMAT (/' The numerator matrix Q(s) is ')
99986 FORMAT (/' M is out of range.',/' M = ',I5)
99985 FORMAT (/' P is out of range.',/' P = ',I5)
99984 FORMAT (/' KDCOEF is out of range.',/' KDCOEF = ',I5)
      END
Program Data 
 TD01ND EXAMPLE PROGRAM DATA
   2     2     0.0     R     L     N
   3     3
   1.0   6.0  11.0   6.0
   1.0   6.0  11.0   6.0
   1.0   6.0  12.0   7.0
   0.0   1.0   4.0   3.0
   0.0   0.0   1.0   1.0
   1.0   8.0  20.0  15.0
Program Results 
 TD03AD EXAMPLE PROGRAM RESULTS

 The order of the resulting minimal realization =  3

 The state dynamics matrix A is 
   0.5000   0.9478  10.1036
   0.0000  -1.0000   0.0000
  -0.8660  -0.6156  -5.5000

 The input/state matrix B is 
   2.0000  12.5000
   0.0000  -5.6273
   0.0000  -2.0207

 The state/output matrix C is 
   0.0000   0.0296  -0.5774
   0.0000  -0.1481  -0.5774

 The direct transmission matrix D is 
   1.0000   0.0000
   0.0000   1.0000

 The observability index of the minimal realization =  2

 The dimensions of the diagonal blocks of the state dynamics matrix are 
    2    1

 The row degrees of the denominator matrix P(s) are
    2    1

 The denominator matrix P(s) is 
   1.6667   4.3333   6.6667
   0.3333   5.6667   5.3333
   5.6273   5.6273   0.0000
  -5.6273  -5.6273   0.0000

 The numerator matrix Q(s) is 
   1.6667   4.3333   8.6667
   0.3333   8.0000  16.6667
   5.6273   5.6273   0.0000
  -5.6273 -11.2546   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TD04AD.html000077500000000000000000000366731201767322700161030ustar00rootroot00000000000000 TD04AD - SLICOT Library Routine Documentation

TD04AD

Minimal state-space representation for a proper transfer matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a minimal state-space representation (A,B,C,D) for a
  proper transfer matrix T(s) given as either row or column
  polynomial vectors over denominator polynomials, possibly with
  uncancelled common terms.
Specification 
      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     .. 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,*)
Arguments

Mode Parameters 

  ROWCOL  CHARACTER*1
          Indicates whether the transfer matrix T(s) is given as
          rows or columns over common denominators as follows:
          = 'R':  T(s) is given as rows over common denominators;
          = 'C':  T(s) is given as columns over common denominators.
Input/Output Parameters 
  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  INDEX   (input) INTEGER array, dimension (porm), where porm = P,
          if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'.
          This array must contain the degrees of the denominator
          polynomials in D(s).

  DCOEFF  (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef),
          where kdcoef = MAX(INDEX(I)) + 1.
          The leading porm-by-kdcoef part of this array must contain
          the coefficients of each denominator polynomial.
          DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of the
          I-th denominator polynomial in D(s), where
          K = 1,2,...,kdcoef.

  LDDCOE  INTEGER
          The leading dimension of array DCOEFF.
          LDDCOE >= MAX(1,P) if ROWCOL = 'R';
          LDDCOE >= MAX(1,M) if ROWCOL = 'C'.

  UCOEFF  (input) DOUBLE PRECISION array, dimension
          (LDUCO1,LDUCO2,kdcoef)
          The leading P-by-M-by-kdcoef part of this array must
          contain the numerator matrix U(s); if ROWCOL = 'C', this
          array is modified internally but restored on exit, and the
          remainder of the leading MAX(M,P)-by-MAX(M,P)-by-kdcoef
          part is used as internal workspace.
          UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
          of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef;
          if ROWCOL = 'R' then iorj = I, otherwise iorj = J.
          Thus for ROWCOL = 'R', U(s) =
          diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...).

  LDUCO1  INTEGER
          The leading dimension of array UCOEFF.
          LDUCO1 >= MAX(1,P)   if ROWCOL = 'R';
          LDUCO1 >= MAX(1,M,P) if ROWCOL = 'C'.

  LDUCO2  INTEGER
          The second dimension of array UCOEFF.
          LDUCO2 >= MAX(1,M)   if ROWCOL = 'R';
          LDUCO2 >= MAX(1,M,P) if ROWCOL = 'C'.

  NR      (output) INTEGER
          The order of the resulting minimal realization, i.e. the
          order of the state dynamics matrix A.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N),
                    porm
          where N = SUM INDEX(I).
                    I=1
          The leading NR-by-NR part of this array contains the upper
          block Hessenberg state dynamics matrix A of a minimal
          realization.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P))
          The leading NR-by-M part of this array contains the
          input/state matrix B of a minimal realization; the
          remainder of the leading N-by-MAX(M,P) part is used as
          internal workspace.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (output) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-NR part of this array contains the
          state/output matrix C of a minimal realization; the
          remainder of the leading MAX(M,P)-by-N part is used as
          internal workspace.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M,P).

  D       (output) DOUBLE PRECISION array, dimension (LDD,M),
          if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'.
          The leading P-by-M part of this array contains the direct
          transmission matrix D; if ROWCOL = 'C', the remainder of
          the leading MAX(M,P)-by-MAX(M,P) part is used as internal
          workspace.

  LDD     INTEGER
          The leading dimension of array D.
          LDD >= MAX(1,P)   if ROWCOL = 'R';
          LDD >= MAX(1,M,P) if ROWCOL = 'C'.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determination when
          transforming (A, B, C). If the user sets TOL > 0, then
          the given value of TOL is used as a lower bound for the
          reciprocal condition number (see the description of the
          argument RCOND in the SLICOT routine MB03OD);  a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance
          (determined by the SLICOT routine TB01UD) is used instead.
Workspace 
  IWORK   INTEGER array, dimension (N+MAX(M,P))
          On exit, if INFO = 0, the first nonzero elements of
          IWORK(1:N) return the orders of the diagonal blocks of A.

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)).
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, then i is the first integer for which
                ABS( DCOEFF(I,1) ) is so small that the calculations
                would overflow (see SLICOT Library routine TD03AY);
                that is, the leading coefficient of a polynomial is
                nearly zero; no state-space representation is
                calculated.
Method 
  The method for transfer matrices factorized by rows will be
  described here: T(s) factorized by columns is dealt with by
  operating on the dual T'(s). This description for T(s) is
  actually the left polynomial matrix representation

       T(s) = inv(D(s))*U(s),

  where D(s) is diagonal with its (I,I)-th polynomial element of
  degree INDEX(I). The first step is to check whether the leading
  coefficient of any polynomial element of D(s) is approximately
  zero; if so the routine returns with INFO > 0. Otherwise,
  Wolovich's Observable Structure Theorem is used to construct a
  state-space representation in observable companion form which
  is equivalent to the above polynomial matrix representation.
  The method is particularly easy here due to the diagonal form
  of D(s). This state-space representation is not necessarily
  controllable (as D(s) and U(s) are not necessarily relatively
  left prime), but it is in theory completely observable; however,
  its observability matrix may be poorly conditioned, so it is
  treated as a general state-space representation and SLICOT
  Library routine TB01PD is then called to separate out a minimal
  realization from this general state-space representation by means
  of orthogonal similarity transformations.
References 
  [1] Patel, R.V.
      Computation of Minimal-Order State-Space Realizations and
      Observability Indices using Orthogonal Transformations.
      Int. J. Control, 33, pp. 227-246, 1981.

  [2] Wolovich, W.A.
      Linear Multivariable Systems, (Theorem 4.3.3).
      Springer-Verlag, 1974.
Numerical Aspects 
                            3
  The algorithm requires 0(N ) operations.
Further Comments 
  None
Example

Program Text 

*     TD04AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, PMAX, KDCMAX, NMAX
      PARAMETER        ( MMAX = 10, PMAX = 10, KDCMAX = 10, NMAX = 10 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDDCOE, LDUCO1, LDUCO2, LDA, LDB, LDC, LDD
      PARAMETER        ( LDDCOE = MAXMP, LDUCO1 = MAXMP,
     $                   LDUCO2 = MAXMP, LDA = NMAX, LDB = NMAX,
     $                   LDC = MAXMP, LDD = MAXMP )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX + MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX + MAX( NMAX, 3*MAXMP ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INDBLK, INFO, J, K, KDCOEF, M, N, NR, P, PORM
      CHARACTER*1      ROWCOL
      LOGICAL          LROWCO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP), DCOEFF(LDDCOE,KDCMAX),
     $                 DWORK(LDWORK), UCOEFF(LDUCO1,LDUCO2,KDCMAX)
      INTEGER          INDEX(MAXMP), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TD04AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, P, TOL, ROWCOL
      LROWCO = LSAME( ROWCOL, 'R' )
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) M
      ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) P
      ELSE
         PORM = P
         IF ( .NOT.LROWCO ) PORM = M
         READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM )
*
         N = 0
         KDCOEF = 0
         DO 20 I = 1, PORM
            N = N + INDEX(I)
            KDCOEF = MAX( KDCOEF, INDEX(I) )
   20    CONTINUE
         KDCOEF = KDCOEF + 1
*
         IF ( KDCOEF.LE.0 .OR. KDCOEF.GT.KDCMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) KDCOEF
         ELSE
            READ ( NIN, FMT = * )
     $         ( ( DCOEFF(I,J), J = 1,KDCOEF ), I = 1,PORM )
            READ ( NIN, FMT = * )
     $         ( ( ( UCOEFF(I,J,K), K = 1,KDCOEF ), J = 1,M ), I = 1,P )
*           Find a minimal state-space representation (A,B,C,D).
            CALL TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF,
     $                   LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D,
     $                   LDD, TOL, IWORK, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) NR
               DO 40 I = 1, NR
                  WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 60 I = 1, NR
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   60          CONTINUE
               WRITE ( NOUT, FMT = 99994 )
               DO 80 I = 1, P
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR )
   80          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 100 I = 1, P
                  WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M )
  100          CONTINUE
               INDBLK = 0
               DO 120 I = 1, N
                  IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1
  120          CONTINUE
               IF ( LROWCO ) THEN
                  WRITE ( NOUT, FMT = 99992 ) INDBLK,
     $                       ( IWORK(I), I = 1,INDBLK )
               ELSE
                  WRITE ( NOUT, FMT = 99991 ) INDBLK,
     $                       ( IWORK(I), I = 1,INDBLK )
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TD04AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TD04AD = ',I2)
99997 FORMAT (' The order of the minimal realization = ',I2,//' The st',
     $       'ate dynamics matrix A of a minimal realization is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix B of a minimal realization is ')
99994 FORMAT (/' The state/output matrix C of a minimal realization is '
     $       )
99993 FORMAT (/' The direct transmission matrix D is ')
99992 FORMAT (/' The observability index of a minimal state-space repr',
     $       'esentation = ',I2,//' The dimensions of the diagonal blo',
     $       'cks of the state dynamics matrix are',/20(1X,I2))
99991 FORMAT (/' The controllability index of a minimal state-space re',
     $       'presentation = ',I2,//' The dimensions of the diagonal b',
     $       'locks of the state dynamics matrix are',/20(1X,I2))
99990 FORMAT (/' M is out of range.',/' M = ',I5)
99989 FORMAT (/' P is out of range.',/' P = ',I5)
99988 FORMAT (/' KDCOEF is out of range.',/' KDCOEF = ',I5)
      END
Program Data 
 TD04AD EXAMPLE PROGRAM DATA
   2     2     0.0     R
   3     3
   1.0   6.0  11.0   6.0
   1.0   6.0  11.0   6.0
   1.0   6.0  12.0   7.0
   0.0   1.0   4.0   3.0
   0.0   0.0   1.0   1.0
   1.0   8.0  20.0  15.0
Program Results 
 TD04AD EXAMPLE PROGRAM RESULTS

 The order of the minimal realization =  3

 The state dynamics matrix A of a minimal realization is 
   0.5000  -0.8028   0.9387
   4.4047  -2.3380   2.5076
  -5.5541   1.6872  -4.1620

 The input/state matrix B of a minimal realization is 
  -0.2000  -1.2500
   0.0000  -0.6097
   0.0000   2.2217

 The state/output matrix C of a minimal realization is 
   0.0000  -0.8679   0.2119
   0.0000   0.0000   0.9002

 The direct transmission matrix D is 
   1.0000   0.0000
   0.0000   1.0000

 The observability index of a minimal state-space representation =  2

 The dimensions of the diagonal blocks of the state dynamics matrix are
  2  1

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TD05AD.html000077500000000000000000000151441201767322700160720ustar00rootroot00000000000000 TD05AD - SLICOT Library Routine Documentation

TD05AD

Evaluation of a transfer function G(jW) for a specified frequency

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  Given a complex valued rational function of frequency (transfer
  function) G(jW) this routine will calculate its complex value or
  its magnitude and phase for a specified frequency value.
Specification 
      SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI,
     $                   INFO )
C     .. Scalar Arguments ..
      CHARACTER         OUTPUT, UNITF
      INTEGER           INFO, MP1, NP1
      DOUBLE PRECISION  VALI, VALR, W
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*)
Arguments

Mode Parameters 

  UNITF   CHARACTER*1
          Indicates the choice of frequency unit as follows:
          = 'R':  Input frequency W in radians/second;
          = 'H':  Input frequency W in hertz.

  OUTPUT  CHARACTER*1
          Indicates the choice of co-ordinates for output as folows:
          = 'C':  Cartesian co-ordinates (output real and imaginary
                  parts of G(jW));
          = 'P':  Polar co-ordinates (output magnitude and phase
                  of G(jW)).
Input/Output Parameters 
  NP1     (input) INTEGER
          The order of the denominator + 1, i.e. N + 1.  NP1 >= 1.

  MP1     (input) INTEGER
          The order of the numerator + 1, i.e. M + 1.  MP1 >= 1.

  W       (input) DOUBLE PRECISION
          The frequency value W for which the transfer function is
          to be evaluated.

  A       (input) DOUBLE PRECISION array, dimension (NP1)
          This array must contain the vector of denominator
          coefficients in ascending order of powers. That is, A(i)
          must contain the coefficient of (jW)**(i-1) for i = 1,
          2,...,NP1.

  B       (input) DOUBLE PRECISION array, dimension (MP1)
          This array must contain the vector of numerator
          coefficients in ascending order of powers. That is, B(i)
          must contain the coefficient of (jW)**(i-1) for i = 1,
          2,...,MP1.

  VALR    (output) DOUBLE PRECISION
          If OUTPUT = 'C', VALR contains the real part of G(jW).
          If OUTPUT = 'P', VALR contains the magnitude of G(jW)
                           in dBs.

  VALI    (output) DOUBLE PRECISION
          If OUTPUT = 'C', VALI contains the imaginary part of
                           G(jW).
          If OUTPUT = 'P', VALI contains the phase of G(jW) in
                           degrees.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1:  if the frequency value W is a pole of G(jW), or all
                the coefficients of the A polynomial are zero.
Method 
  By substituting the values of A, B and W in the following
  formula:

         B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1)
  G(jW) = ---------------------------------------------------.
         A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1)
References 
  None.
Numerical Aspects 
  The algorithm requires 0(N+M) operations.
Further Comments 
  None
Example

Program Text 

*     TD05AD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NP1MAX, MP1MAX
      PARAMETER        ( NP1MAX = 20, MP1MAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION VALI, VALR, W
      INTEGER          I, INFO, MP1, NP1
      CHARACTER*1      UNITF, OUTPUT
*     .. Local Arrays ..
      DOUBLE PRECISION A(NP1MAX), B(MP1MAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TD05AD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NP1, MP1, W, UNITF, OUTPUT
      IF ( NP1.LE.0 .OR. NP1.GT.NP1MAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NP1
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,NP1 )
         IF ( MP1.LE.0 .OR. MP1.GT.MP1MAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) MP1
         ELSE
            READ ( NIN, FMT = * ) ( B(I), I = 1,MP1 )
*           Find the real and imaginary parts of G(jW), where
*           W = 1.0 radian.
            CALL TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI,
     $                   INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF ( LSAME( OUTPUT, 'C' ) ) THEN
                  WRITE ( NOUT, FMT = 99997 ) VALR, VALI
               ELSE
                  WRITE ( NOUT, FMT = 99996 ) VALR, VALI
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TD05AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TD05AD = ',I2)
99997 FORMAT (' Complex value of G(jW) = ',F8.4,1X,F8.4,'*j')
99996 FORMAT (' Magnitude of G(jW) = ',F8.4,' dBs, Phase of G(jW) = ',
     $       F8.4,' degrees ')
99995 FORMAT (/' NP1 is out of range.',/' NP1 = ',I5)
99994 FORMAT (/' MP1 is out of range.',/' MP1 = ',I5)
      END
Program Data 
 TD05AD EXAMPLE PROGRAM DATA
   6     4     1.0     R     C
   1.0   1.0   0.0   0.0   2.0   1.0
   6.0   2.0   3.0   1.0
Program Results 
 TD05AD EXAMPLE PROGRAM RESULTS

 Complex value of G(jW) =   0.8462  -0.2308*j

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TF01MD.html000077500000000000000000000220711201767322700161010ustar00rootroot00000000000000 TF01MD - SLICOT Library Routine Documentation

TF01MD

Output response sequence of a linear time-invariant discrete-time system

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the output sequence of a linear time-invariant
  open-loop system given by its discrete-time state-space model
  (A,B,C,D), where A is an N-by-N general matrix.

  The initial state vector x(1) must be supplied by the user.
Specification 
      SUBROUTINE TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   U, LDU, X, Y, LDY, DWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NY      (input) INTEGER
          The number of output vectors y(k) to be computed.
          NY >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct link matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  U       (input) DOUBLE PRECISION array, dimension (LDU,NY)
          The leading M-by-NY part of this array must contain the
          input vector sequence u(k), for k = 1,2,...,NY.
          Specifically, the k-th column of U must contain u(k).

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,M).

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the initial state vector
          x(1) which consists of the N initial states of the system.
          On exit, this array contains the final state vector
          x(NY+1) of the N states of the system at instant NY.

  Y       (output) DOUBLE PRECISION array, dimension (LDY,NY)
          The leading P-by-NY part of this array contains the output
          vector sequence y(1),y(2),...,y(NY) such that the k-th
          column of Y contains y(k) (the outputs at instant k),
          for k = 1,2,...,NY.

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= MAX(1,P).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given an initial state vector x(1), the output vector sequence
  y(1), y(2),..., y(NY) is obtained via the formulae

     x(k+1) = A x(k) + B u(k)
     y(k)   = C x(k) + D u(k),

  where each element y(k) is a vector of length P containing the
  outputs at instant k and k = 1,2,...,NY.
References 
  [1] Luenberger, D.G.
      Introduction to Dynamic Systems: Theory, Models and
      Applications.
      John Wiley & Sons, New York, 1979.
Numerical Aspects 
  The algorithm requires approximately (N + M) x (N + P) x NY
  multiplications and additions.
Further Comments 
  None
Example

Program Text 

*     TF01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX, NYMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20, NYMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD, LDU, LDY
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX,
     $                   LDU = MMAX, LDY = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, M, N, NY, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), U(LDU,NYMAX),
     $                 X(NMAX), Y(LDY,NYMAX)
*     .. External Subroutines ..
      EXTERNAL         TF01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NY
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N )
               READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M )
               READ ( NIN, FMT = * ) ( X(I), I = 1,N )
               IF ( NY.LE.0 .OR. NY.GT.NYMAX ) THEN
                  WRITE ( NOUT, FMT = 99991 ) NY
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( U(I,J), I = 1,M ), J = 1,NY )
*                 Compute y(1),...,y(NY) of the given system.
                  CALL TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D,
     $                         LDD, U, LDU, X, Y, LDY, DWORK, INFO )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99997 ) NY
                     DO 20 K = 1, NY
                        WRITE ( NOUT, FMT = 99996 ) K, Y(1,K)
                        WRITE ( NOUT, FMT = 99995 ) ( Y(J,K), J = 2,P )
   20                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TF01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TF01MD = ',I2)
99997 FORMAT (' The output sequence Y(1),...,Y(',I2,') is',/)
99996 FORMAT (' Y(',I2,') : ',F8.4)
99995 FORMAT (9X,F8.4,/)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
99991 FORMAT (/' NY is out of range.',/' NY = ',I5)
      END
Program Data 
 TF01MD EXAMPLE PROGRAM DATA
   3     2     2     10
   0.0000 -0.0700  0.0150
   1.0000  0.8000 -0.1500
   0.0000  0.0000  0.5000
   0.0000  2.0000  1.0000
  -1.0000 -0.1000  1.0000
   0.0000  1.0000
   0.0000  0.0000
   1.0000  0.0000
   1.0000  0.5000
   0.0000  0.5000
   1.0000  1.0000  1.0000
  -0.6922 -1.4934  0.3081 -2.7726  2.0039
   0.2614 -0.9160 -0.6030  1.2556  0.2951
  -1.5734  1.5639 -0.9942  1.8957  0.8988
   0.4118 -1.4893 -0.9344  1.2506 -0.0701
Program Results 
 TF01MD EXAMPLE PROGRAM RESULTS

 The output sequence Y(1),...,Y(10) is

 Y( 1) :   0.3078
          -0.0928

 Y( 2) :  -1.5125
           1.2611

 Y( 3) :  -1.2577
           3.4002

 Y( 4) :  -0.2947
          -0.7060

 Y( 5) :  -0.5632
           5.4532

 Y( 6) :  -1.0846
           1.1846

 Y( 7) :  -1.2427
           2.2286

 Y( 8) :   1.8097
          -1.9534

 Y( 9) :   0.6685
          -4.4965

 Y(10) :  -0.0896
           1.1654

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TF01MX.html000077500000000000000000000113711201767322700161260ustar00rootroot00000000000000 TF01MX - SLICOT Library Routine Documentation

TF01MX

Output sequence of a linear time-invariant open-loop system given its system matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the output sequence of a linear time-invariant
  open-loop system given by its discrete-time state-space model
  with an (N+P)-by-(N+M) general system matrix S,

         ( A  B )
     S = (      ) .
         ( C  D )

  The initial state vector x(1) must be supplied by the user.

  The input and output trajectories are stored as in the SLICOT
  Library routine TF01MY.
Specification 
      SUBROUTINE TF01MX( N, M, P, NY, S, LDS, U, LDU, X, Y, LDY,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NY      (input) INTEGER
          The number of output vectors y(k) to be computed.
          NY >= 0.

  S       (input) DOUBLE PRECISION array, dimension (LDS,N+M)
          The leading (N+P)-by-(N+M) part of this array must contain
          the system matrix S.

  LDS     INTEGER
          The leading dimension of array S.  LDS >= MAX(1,N+P).

  U       (input) DOUBLE PRECISION array, dimension (LDU,M)
          The leading NY-by-M part of this array must contain the
          input vector sequence u(k), for k = 1,2,...,NY.
          Specifically, the k-th row of U must contain u(k)'.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,NY).

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the initial state vector
          x(1) which consists of the N initial states of the system.
          On exit, this array contains the final state vector
          x(NY+1) of the N states of the system at instant NY+1.

  Y       (output) DOUBLE PRECISION array, dimension (LDY,P)
          The leading NY-by-P part of this array contains the output
          vector sequence y(1),y(2),...,y(NY) such that the k-th
          row of Y contains y(k)' (the outputs at instant k),
          for k = 1,2,...,NY.

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= MAX(1,NY).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= 0,        if MIN(N,P,NY) = 0;  otherwise,
          LDWORK >= N+P,      if M = 0;
          LDWORK >= 2*N+M+P,  if M > 0.
          For better performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given an initial state vector x(1), the output vector sequence
  y(1), y(2),..., y(NY) is obtained via the formulae

     ( x(k+1) )     ( x(k) )
     (        ) = S (      ) ,
     (  y(k)  )     ( u(k) )

  where each element y(k) is a vector of length P containing the
  outputs at instant k, and k = 1,2,...,NY.
References 
  [1] Luenberger, D.G.
      Introduction to Dynamic Systems: Theory, Models and
      Applications.
      John Wiley & Sons, New York, 1979.
Numerical Aspects 
  The algorithm requires approximately (N + M) x (N + P) x NY
  multiplications and additions.
Further Comments 
  The implementation exploits data locality as much as possible,
  given the workspace length.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TF01MY.html000077500000000000000000000126551201767322700161350ustar00rootroot00000000000000 TF01MY - SLICOT Library Routine Documentation

TF01MY

Output sequence of a linear time-invariant open-loop system (variant)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the output sequence of a linear time-invariant
  open-loop system given by its discrete-time state-space model
  (A,B,C,D), where A is an N-by-N general matrix.

  The initial state vector x(1) must be supplied by the user.

  This routine differs from SLICOT Library routine TF01MD in the
  way the input and output trajectories are stored.
Specification 
      SUBROUTINE TF01MY( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   U, LDU, X, Y, LDY, DWORK, LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NY      (input) INTEGER
          The number of output vectors y(k) to be computed.
          NY >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading N-by-N part of this array must contain the
          state matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct link matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  U       (input) DOUBLE PRECISION array, dimension (LDU,M)
          The leading NY-by-M part of this array must contain the
          input vector sequence u(k), for k = 1,2,...,NY.
          Specifically, the k-th row of U must contain u(k)'.

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,NY).

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the initial state vector
          x(1) which consists of the N initial states of the system.
          On exit, this array contains the final state vector
          x(NY+1) of the N states of the system at instant NY+1.

  Y       (output) DOUBLE PRECISION array, dimension (LDY,P)
          The leading NY-by-P part of this array contains the output
          vector sequence y(1),y(2),...,y(NY) such that the k-th
          row of Y contains y(k)' (the outputs at instant k),
          for k = 1,2,...,NY.

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= MAX(1,NY).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.  LDWORK >= N.
          For better performance, LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given an initial state vector x(1), the output vector sequence
  y(1), y(2),..., y(NY) is obtained via the formulae

     x(k+1) = A x(k) + B u(k)
     y(k)   = C x(k) + D u(k),

  where each element y(k) is a vector of length P containing the
  outputs at instant k and k = 1,2,...,NY.
References 
  [1] Luenberger, D.G.
      Introduction to Dynamic Systems: Theory, Models and
      Applications.
      John Wiley & Sons, New York, 1979.
Numerical Aspects 
  The algorithm requires approximately (N + M) x (N + P) x NY
  multiplications and additions.
Further Comments 
  The implementation exploits data locality and uses BLAS 3
  operations as much as possible, given the workspace length.
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TF01ND.html000077500000000000000000000236051201767322700161060ustar00rootroot00000000000000 TF01ND - SLICOT Library Routine Documentation

TF01ND

Output response sequence of a linear time-invariant discrete-time system with upper/lower Hessenberg matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute the output sequence of a linear time-invariant
  open-loop system given by its discrete-time state-space model
  (A,B,C,D), where A is an N-by-N upper or lower Hessenberg matrix.

  The initial state vector x(1) must be supplied by the user.
Specification 
      SUBROUTINE TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, LDC, D,
     $                   LDD, U, LDU, X, Y, LDY, DWORK, INFO )
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,*)
Arguments

Mode Parameters 

  UPLO    CHARACTER*1
          Indicates whether the user wishes to use an upper or lower
          Hessenberg matrix as follows:
          = 'U':  Upper Hessenberg matrix;
          = 'L':  Lower Hessenberg matrix.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrix A.  N >= 0.

  M       (input) INTEGER
          The number of system inputs.  M >= 0.

  P       (input) INTEGER
          The number of system outputs.  P >= 0.

  NY      (input) INTEGER
          The number of output vectors y(k) to be computed.
          NY >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          If UPLO = 'U', the leading N-by-N upper Hessenberg part
          of this array must contain the state matrix A of the
          system.
          If UPLO = 'L', the leading N-by-N lower Hessenberg part
          of this array must contain the state matrix A of the
          system.
          The remainder of the leading N-by-N part is not
          referenced.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  B       (input) DOUBLE PRECISION array, dimension (LDB,M)
          The leading N-by-M part of this array must contain the
          input matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input) DOUBLE PRECISION array, dimension (LDC,N)
          The leading P-by-N part of this array must contain the
          output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  D       (input) DOUBLE PRECISION array, dimension (LDD,M)
          The leading P-by-M part of this array must contain the
          direct link matrix D of the system.

  LDD     INTEGER
          The leading dimension of array D.  LDD >= MAX(1,P).

  U       (input) DOUBLE PRECISION array, dimension (LDU,NY)
          The leading M-by-NY part of this array must contain the
          input vector sequence u(k), for k = 1,2,...,NY.
          Specifically, the k-th column of U must contain u(k).

  LDU     INTEGER
          The leading dimension of array U.  LDU >= MAX(1,M).

  X       (input/output) DOUBLE PRECISION array, dimension (N)
          On entry, this array must contain the initial state vector
          x(1) which consists of the N initial states of the system.
          On exit, this array contains the final state vector
          x(NY+1) of the N states of the system at instant NY.

  Y       (output) DOUBLE PRECISION array, dimension (LDY,NY)
          The leading P-by-NY part of this array contains the output
          vector sequence y(1),y(2),...,y(NY) such that the k-th
          column of Y contains y(k) (the outputs at instant k),
          for k = 1,2,...,NY.

  LDY     INTEGER
          The leading dimension of array Y.  LDY >= MAX(1,P).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (N)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Given an initial state vector x(1), the output vector sequence
  y(1), y(2),..., y(NY) is obtained via the formulae

     x(k+1) = A x(k) + B u(k)
     y(k)   = C x(k) + D u(k),

  where each element y(k) is a vector of length P containing the
  outputs at instant k and k = 1,2,...,NY.
References 
  [1] Luenberger, D.G.
      Introduction to Dynamic Systems: Theory, Models and
      Applications.
      John Wiley & Sons, New York, 1979.
Numerical Aspects 
  The algorithm requires approximately ((N+M)xP + (N/2+M)xN) x NY
  multiplications and additions.
Further Comments 
  The processing time required by this routine will be approximately
  half that required by the SLICOT Library routine TF01MD, which
  treats A as a general matrix.
Example

Program Text 

*     TF01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX, NYMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20, NYMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD, LDU, LDY
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDU = MMAX, LDY = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
*     .. Local Scalars ..
      CHARACTER*1      UPLO
      INTEGER          I, INFO, J, K, M, N, NY, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK), U(LDU,NYMAX),
     $                 X(NMAX), Y(LDY,NYMAX)
*     .. External Subroutines ..
      EXTERNAL         TF01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, NY, UPLO
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N )
               READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M )
               READ ( NIN, FMT = * ) ( X(I), I = 1,N )
               IF ( NY.LE.0 .OR. NY.GT.NYMAX ) THEN
                  WRITE ( NOUT, FMT = 99991 ) NY
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( U(I,J), I = 1,M ), J = 1,NY )
*                 Compute y(1),...,y(NY) of the given system.
                  CALL TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C,
     $                         LDC, D, LDD, U, LDU, X, Y, LDY, DWORK,
     $                         INFO )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99997 ) NY
                     DO 20 K = 1, NY
                        WRITE ( NOUT, FMT = 99996 ) K, Y(1,K)
                        WRITE ( NOUT, FMT = 99995 ) ( Y(J,K), J = 2,P )
   20                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TF01ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TF01ND = ',I2)
99997 FORMAT (' The output sequence Y(1),...,Y(',I2,') is',/)
99996 FORMAT (' Y(',I2,') : ',F8.4)
99995 FORMAT (9X,F8.4,/)
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
99991 FORMAT (/' NY is out of range.',/' NY = ',I5)
      END
Program Data 
 TF01ND EXAMPLE PROGRAM DATA
   3     2     2     10     U
   0.0000 -0.0700  0.0000
   1.0000  0.8000 -0.1500
   0.0000  0.0000  0.5000
   0.0000  2.0000  1.0000
  -1.0000 -0.1000  1.0000
   0.0000  1.0000
   0.0000  0.0000
   1.0000  0.0000
   1.0000  0.5000
   0.0000  0.5000
   1.0000  1.0000  1.0000
  -0.6922 -1.4934  0.3081 -2.7726  2.0039
   0.2614 -0.9160 -0.6030  1.2556  0.2951
  -1.5734  1.5639 -0.9942  1.8957  0.8988
   0.4118 -1.4893 -0.9344  1.2506 -0.0701
Program Results 
 TF01ND EXAMPLE PROGRAM RESULTS

 The output sequence Y(1),...,Y(10) is

 Y( 1) :   0.3078
          -0.0928

 Y( 2) :  -1.5275
           1.2611

 Y( 3) :  -1.3026
           3.4002

 Y( 4) :  -0.3512
          -0.7060

 Y( 5) :  -0.5922
           5.4532

 Y( 6) :  -1.1693
           1.1846

 Y( 7) :  -1.3029
           2.2286

 Y( 8) :   1.7529
          -1.9534

 Y( 9) :   0.6793
          -4.4965

 Y(10) :  -0.0349
           1.1654

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TF01OD.html000077500000000000000000000156531201767322700161130ustar00rootroot00000000000000 TF01OD - SLICOT Library Routine Documentation

TF01OD

Block Hankel expansion of a multivariable parameter sequence

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the block Hankel expansion T of a multivariable
  parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k)
  is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1).
Specification 
      SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, LDT, NC, NH1, NH2, NR
C     .. Array Arguments ..
      DOUBLE PRECISION  H(LDH,*), T(LDT,*)
Arguments

Input/Output Parameters 

  NH1     (input) INTEGER
          The number of rows in each parameter M(k).  NH1 >= 0.

  NH2     (input) INTEGER
          The number of columns in each parameter M(k).  NH2 >= 0.

  NR      (input) INTEGER
          The number of parameters required in each column of the
          block Hankel expansion matrix T.  NR >= 0.

  NC      (input) INTEGER
          The number of parameters required in each row of the
          block Hankel expansion matrix T.  NC >= 0.

  H       (input) DOUBLE PRECISION array, dimension
          (LDH,(NR+NC-1)*NH2)
          The leading NH1-by-(NR+NC-1)*NH2 part of this array must
          contain the multivariable sequence M(k), where k = 1,2,
          ...,(NR+NC-1). Specifically, each parameter M(k) is an
          NH1-by-NH2 matrix whose (i,j)-th element must be stored in
          H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2.

  LDH     INTEGER
          The leading dimension of array H.  LDH >= MAX(1,NH1).

  T       (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC)
          The leading NH1*NR-by-NH2*NC part of this array contains
          the block Hankel expansion of the multivariable sequence
          M(k).

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,NH1*NR).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The NH1-by-NH2 dimensional parameters M(k) of a multivariable
  sequence are arranged into a matrix T in Hankel form such that

           | M(1)   M(2)    M(3)    . . .  M(NC)     |
           |                                         |
           | M(2)   M(3)    M(4)    . . .  M(NC+1)   |
      T =  |  .      .       .              .        |.
           |  .      .       .              .        |
           |  .      .       .              .        |
           |                                         |
           | M(NR)  M(NR+1) M(NR+2) . . .  M(NR+NC-1)|
References 
  [1] Johvidov, J.S.
      Hankel and Toeplitz Matrices and Forms: Algebraic Theory,
      (translated by G.P.A. Thijsse, I. Gohberg, ed.).
      Birkhaeuser, Boston, 1982.
Numerical Aspects 
  The time taken is approximately proportional to
  NH1 x NH2 x NR x NC.
Further Comments 
  None
Example

Program Text 

*     TF01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NH1MAX, NH2MAX, NRMAX, NCMAX
      PARAMETER        ( NH1MAX = 20, NH2MAX = 20, NRMAX = 20,
     $                   NCMAX = 20 )
      INTEGER          LDH, LDT
      PARAMETER        ( LDH = NH1MAX, LDT = NH1MAX*NRMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, NC, NCT, NH1, NH2, NR, NRT
*     .. Local Arrays ..
      DOUBLE PRECISION H(LDH,(NRMAX+NCMAX-1)*NH2MAX),
     $                 T(LDT,NH2MAX*NCMAX)
*     .. External Subroutines ..
      EXTERNAL         TF01OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NH1, NH2, NR, NC
      IF ( NH1.LE.0 .OR. NH1.GE.NH1MAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NH1
      ELSE IF ( NH2.LE.0 .OR. NH2.GT.NH2MAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) NH2
      ELSE IF ( NR.LE.0 .OR. NR.GT.NRMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NR
      ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) NC
      ELSE
         READ ( NIN, FMT = * )
     $      ( ( H(I,J), I = 1,NH1 ), J = 1,( NR+NC-1 )*NH2 )
*        Construct the NRT by NCT block Hankel expansion of M(k).
         CALL TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            NRT = NH1*NR
            NCT = NH2*NC
            WRITE ( NOUT, FMT = 99997 ) NRT, NCT
            DO 20 I = 1, NRT
               WRITE ( NOUT, FMT = 99996 ) ( T(I,J), J = 1,NCT )
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' TF01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TF01OD = ',I2)
99997 FORMAT (' The ',I2,' by ',I2,' matrix T is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' NH1 is out of range.',/' NH1 = ',I5)
99994 FORMAT (/' NH2 is out of range.',/' NH2 = ',I5)
99993 FORMAT (/' NR is out of range.',/' NR = ',I5)
99992 FORMAT (/' NC is out of range.',/' NC = ',I5)
      END
Program Data 
 TF01OD EXAMPLE PROGRAM DATA
   2     2     3     3
   1.0647 -0.4282 -0.4922 -1.2072
  -0.3043  0.6883 -0.0926  0.7167
  -0.1844 -0.8507  0.4441 -0.0478
   0.7195  0.0500 -0.3955  0.5674
   1.3387 -0.2801  0.1073 -0.5315
Program Results 
 TF01OD EXAMPLE PROGRAM RESULTS

 The  6 by  6 matrix T is 
   1.0647  -0.4922  -0.3043  -0.0926  -0.1844   0.4441
  -0.4282  -1.2072   0.6883   0.7167  -0.8507  -0.0478
  -0.3043  -0.0926  -0.1844   0.4441   0.7195  -0.3955
   0.6883   0.7167  -0.8507  -0.0478   0.0500   0.5674
  -0.1844   0.4441   0.7195  -0.3955   1.3387   0.1073
  -0.8507  -0.0478   0.0500   0.5674  -0.2801  -0.5315

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TF01PD.html000077500000000000000000000160111201767322700161010ustar00rootroot00000000000000 TF01PD - SLICOT Library Routine Documentation

TF01PD

Block Toeplitz expansion of a multivariable parameter sequence

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To construct the block Toeplitz expansion T of a multivariable
  parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k)
  is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1).
Specification 
      SUBROUTINE TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, LDT, NC, NH1, NH2, NR
C     .. Array Arguments ..
      DOUBLE PRECISION  H(LDH,*), T(LDT,*)
Arguments

Input/Output Parameters 

  NH1     (input) INTEGER
          The number of rows in each parameter M(k).  NH1 >= 0.

  NH2     (input) INTEGER
          The number of columns in each parameter M(k).  NH2 >= 0.

  NR      (input) INTEGER
          The number of parameters required in each column of the
          block Toeplitz expansion matrix T.  NR >= 0.

  NC      (input) INTEGER
          The number of parameters required in each row of the
          block Toeplitz expansion matrix T.  NC >= 0.

  H       (input) DOUBLE PRECISION array, dimension
          (LDH,(NR+NC-1)*NH2)
          The leading NH1-by-(NR+NC-1)*NH2 part of this array must
          contain the multivariable sequence M(k), where k = 1,2,
          ...,(NR+NC-1). Specifically, each parameter M(k) is an
          NH1-by-NH2 matrix whose (i,j)-th element must be stored in
          H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2.

  LDH     INTEGER
          The leading dimension of array H.  LDH >= MAX(1,NH1).

  T       (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC)
          The leading NH1*NR-by-NH2*NC part of this array contains
          the block Toeplitz expansion of the multivariable sequence
          M(k).

  LDT     INTEGER
          The leading dimension of array T.  LDT >= MAX(1,NH1*NR).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The NH1-by-NH2 dimensional parameters M(k) of a multivariable
  sequence are arranged into a matrix T in Toeplitz form such that

             | M(NC)       M(NC-1)     M(NC-2)    . . .  M(1)  |
             |                                                 |
             | M(NC+1)     M(NC)       M(NC-1)    . . .  M(2)  |
        T =  |  .           .           .                 .    |.
             |  .           .           .                 .    |
             |  .           .           .                 .    |
             |                                                 |
             | M(NR+NC-1)  M(NR+NC-2)  M(NR+NC-3) . . .  M(NR) |
References 
  [1] Johvidov, J.S.
      Hankel and Toeplitz Matrices and Forms: Algebraic Theory,
      (translated by G.P.A. Thijsse, I. Gohberg, ed.).
      Birkhaeuser, Boston, 1982.
Numerical Aspects 
  The time taken is approximately proportional to
  NH1 x NH2 x NR x NC.
Further Comments 
  None
Example

Program Text 

*     TF01PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NH1MAX, NH2MAX, NRMAX, NCMAX
      PARAMETER        ( NH1MAX = 20, NH2MAX = 20, NRMAX = 20,
     $                   NCMAX = 20 )
      INTEGER          LDH, LDT
      PARAMETER        ( LDH = NH1MAX, LDT = NH1MAX*NRMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, NC, NCT, NH1, NH2, NR, NRT
*     .. Local Arrays ..
      DOUBLE PRECISION H(LDH,(NRMAX+NCMAX-1)*NH2MAX),
     $                 T(LDT,NH2MAX*NCMAX)
*     .. External Subroutines ..
      EXTERNAL         TF01PD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NH1, NH2, NR, NC
      IF ( NH1.LE.0 .OR. NH1.GE.NH1MAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NH1
      ELSE IF ( NH2.LE.0 .OR. NH2.GT.NH2MAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) NH2
      ELSE IF ( NR.LE.0 .OR. NR.GT.NRMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NR
      ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) NC
      ELSE
         READ ( NIN, FMT = * )
     $      ( ( H(I,J), I = 1,NH1 ), J = 1,( NR+NC-1 )*NH2 )
*        Construct the NRT by NCT block Toeplitz expansion of M(k).
         CALL TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            NRT = NH1*NR
            NCT = NH2*NC
            WRITE ( NOUT, FMT = 99997 ) NRT, NCT
            DO 20 I = 1, NRT
               WRITE ( NOUT, FMT = 99996 ) ( T(I,J), J = 1,NCT )
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' TF01PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TF01PD = ',I2)
99997 FORMAT (' The ',I2,' by ',I2,' matrix T is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' NH1 is out of range.',/' NH1 = ',I5)
99994 FORMAT (/' NH2 is out of range.',/' NH2 = ',I5)
99993 FORMAT (/' NR is out of range.',/' NR = ',I5)
99992 FORMAT (/' NC is out of range.',/' NC = ',I5)
      END
Program Data 
 TF01PD EXAMPLE PROGRAM DATA
   2     2     3     3
   1.0647 -0.4282 -0.4922 -1.2072
  -0.3043  0.6883 -0.0926  0.7167
  -0.1844 -0.8507  0.4441 -0.0478
   0.7195  0.0500 -0.3955  0.5674
   1.3387 -0.2801  0.1073 -0.5315
Program Results 
 TF01PD EXAMPLE PROGRAM RESULTS

 The  6 by  6 matrix T is 
  -0.1844   0.4441  -0.3043  -0.0926   1.0647  -0.4922
  -0.8507  -0.0478   0.6883   0.7167  -0.4282  -1.2072
   0.7195  -0.3955  -0.1844   0.4441  -0.3043  -0.0926
   0.0500   0.5674  -0.8507  -0.0478   0.6883   0.7167
   1.3387   0.1073   0.7195  -0.3955  -0.1844   0.4441
  -0.2801  -0.5315   0.0500   0.5674  -0.8507  -0.0478

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TF01QD.html000077500000000000000000000237251201767322700161140ustar00rootroot00000000000000 TF01QD - SLICOT Library Routine Documentation

TF01QD

Markov parameters of a multivariable system from its transfer function matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute N Markov parameters M(1), M(2),..., M(N) from a
  multivariable system whose transfer function matrix G(z) is given.
Specification 
      SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N, NB, NC
C     .. Array Arguments ..
      INTEGER           IORD(*)
      DOUBLE PRECISION  AR(*), H(LDH,*), MA(*)
Arguments

Input/Output Parameters 

  NC      (input) INTEGER
          The number of system outputs, i.e. the number of rows in
          the transfer function matrix G(z).  NC >= 0.

  NB      (input) INTEGER
          The number of system inputs, i.e. the number of columns in
          the transfer function matrix G(z).  NB >= 0.

  N       (input) INTEGER
          The number of Markov parameters M(k) to be computed.
          N >= 0.

  IORD    (input) INTEGER array, dimension (NC*NB)
          This array must contain the order r of the elements of the
          transfer function matrix G(z), stored row by row.
          For example, the order of the (i,j)-th element of G(z) is
          given by IORD((i-1)xNB+j).

  AR      (input) DOUBLE PRECISION array, dimension (NA), where
          NA = IORD(1) + IORD(2) + ... + IORD(NC*NB).
          The leading NA elements of this array must contain the
          denominator coefficients AR(1),...,AR(r) in equation (1)
          of the (i,j)-th element of the transfer function matrix
          G(z), stored row by row, i.e. in the order
          (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ...,
          (NC,1),(NC,2),...,(NC,NB). The coefficients must be given
          in decreasing order of powers of z; the coefficient of the
          highest order term is assumed to be equal to 1.

  MA      (input) DOUBLE PRECISION array, dimension (NA)
          The leading NA elements of this array must contain the
          numerator coefficients MA(1),...,MA(r) in equation (1)
          of the (i,j)-th element of the transfer function matrix
          G(z), stored row by row, i.e. in the order
          (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ...,
          (NC,1),(NC,2),...,(NC,NB). The coefficients must be given
          in decreasing order of powers of z.

  H       (output) DOUBLE PRECISION array, dimension (LDH,N*NB)
          The leading NC-by-N*NB part of this array contains the
          multivariable Markov parameter sequence M(k), where each
          parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N.
          The Markov parameters are stored such that H(i,(k-1)xNB+j)
          contains the (i,j)-th element of M(k) for i = 1,2,...,NC
          and j = 1,2,...,NB.

  LDH     INTEGER
          The leading dimension of array H.  LDH >= MAX(1,NC).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The (i,j)-th element of G(z), defining the particular I/O transfer
  between output i and input j, has the following form:

                       -1         -2               -r
                 MA(1)z   + MA(2)z   + ... + MA(r)z
      G  (z) = ----------------------------------------.         (1)
       ij                -1         -2               -r
               1 + AR(1)z   + AR(2)z   + ... + AR(r)z

  The (i,j)-th element of G(z) is defined by its order r, its r
  moving average coefficients (= numerator) MA(1),...,MA(r) and its
  r autoregressive coefficients (= denominator) AR(1),...,AR(r). The
  coefficient of the constant term in the denominator is assumed to
  be equal to 1.

  The relationship between the (i,j)-th element of the Markov
  parameters M(1),M(2),...,M(N) and the corresponding element of the
  transfer function matrix G(z) is given by:

                            -1          -2                -k
   G  (z) = M  (0) + M  (1)z   + M  (2)z   + ... + M  (k)z  + ...(2)
    ij       ij       ij          ij                ij

  Equating (1) and (2), we find that the relationship between the
  (i,j)-th element of the Markov parameters M(k) and the ARMA
  parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th
  element of the transfer function matrix G(z) is as follows:

     M  (1)   = MA(1),
      ij
                        k-1
     M  (k)   = MA(k) - SUM AR(p) x M  (k-p) for 1 < k <= r and
      ij                p=1          ij
                   r
     M  (k+r) = - SUM AR(p) x M  (k+r-p) for k > 0.
      ij          p=1          ij

  From these expressions the Markov parameters M(k) are computed
  element by element.
References 
  [1] Luenberger, D.G.
      Introduction to Dynamic Systems: Theory, Models and
      Applications.
      John Wiley & Sons, New York, 1979.
Numerical Aspects 
  The computation of the (i,j)-th element of M(k) requires:
     (k-1) multiplications and k additions if k <= r;
       r   multiplications and r additions if k > r.
Further Comments 
  None
Example

Program Text 

*     TF01QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, NAMAX, NBMAX, NCMAX
      PARAMETER        ( NMAX = 20, NAMAX = 20, NBMAX = 20, NCMAX = 20 )
      INTEGER          LDH
      PARAMETER        ( LDH = NCMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, L, N, NA, NASUM, NB, NC, NL, NORD
      LOGICAL          ERROR
*     .. Local Arrays ..
      DOUBLE PRECISION AR(NAMAX), H(LDH,NMAX*NBMAX), MA(NAMAX)
      INTEGER          IORD(NCMAX*NBMAX)
*     .. External Subroutines ..
      EXTERNAL         TF01QD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NA, NB, NC
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE IF ( NA.LE.0 .OR. NA.GT.NAMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NA
      ELSE IF ( NB.LE.0 .OR. NB.GT.NBMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) NB
      ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) NC
      ELSE
         ERROR = .FALSE.
         NL = 0
         K = 1
         NASUM = 0
         DO 40 I = 1, NC
            DO 20 J = 1, NB
               READ ( NIN, FMT = * ) NORD
               NASUM = NASUM + NORD
               IF ( NA.GE.NASUM ) THEN
                  READ ( NIN, FMT = * ) ( MA(NL+L), L = 1,NORD )
                  READ ( NIN, FMT = * ) ( AR(NL+L), L = 1,NORD )
                  IORD(K) = NORD
                  K = K + 1
                  NL = NL + NORD
               ELSE
                  WRITE ( NOUT, FMT = 99993 ) NA
                  ERROR = .TRUE.
               END IF
   20       CONTINUE
   40    CONTINUE
         IF ( .NOT. ERROR ) THEN
*           Compute M(1),...,M(N) from the given transfer function
*           matrix G(z).
            CALL TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) N
               DO 80 K = 1, N
                  WRITE ( NOUT, FMT = 99996 ) K,
     $                  ( H(1,(K-1)*NB+J), J = 1,NB )
                  DO 60 I = 2, NC
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( H(I,(K-1)*NB+J), J = 1,NB )
   60             CONTINUE
   80          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TF01QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TF01QD = ',I2)
99997 FORMAT (' The Markov Parameters M(1),...,M(',I1,') are ')
99996 FORMAT (/' M(',I1,') : ',20(1X,F8.4))
99995 FORMAT (8X,20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' NA is out of range.',/' NA = ',I5)
99992 FORMAT (/' NB is out of range.',/' NB = ',I5)
99991 FORMAT (/' NC is out of range.',/' NC = ',I5)
      END
Program Data 
 TF01QD EXAMPLE PROGRAM DATA
   8    10     2     2   
   2
   1.0  -0.5
   0.6  -0.2
   1
   1.0
  -0.8
   3
   0.5  -0.4   0.3
   0.8   0.4   0.1
   4
   1.0   0.5  -0.5   0.0
  -0.8   0.6   0.0  -0.2
Program Results 
 TF01QD EXAMPLE PROGRAM RESULTS

 The Markov Parameters M(1),...,M(8) are 

 M(1) :    1.0000   1.0000
           0.5000   1.0000

 M(2) :   -1.1000   0.8000
          -0.8000   1.3000

 M(3) :    0.8600   0.6400
           0.7400  -0.0600

 M(4) :   -0.7360   0.5120
          -0.3220  -0.8280

 M(5) :    0.6136   0.4096
           0.0416  -0.4264

 M(6) :   -0.5154   0.3277
           0.0215   0.4157

 M(7) :    0.4319   0.2621
          -0.0017   0.5764

 M(8) :   -0.3622   0.2097
          -0.0114   0.0461

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TF01RD.html000077500000000000000000000205501201767322700161060ustar00rootroot00000000000000 TF01RD - SLICOT Library Routine Documentation

TF01RD

Markov parameters of a multivariable system from the state-space representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute N Markov parameters M(1), M(2),..., M(N) from the
  parameters (A,B,C) of a linear time-invariant system, where each
  M(k) is an NC-by-NB matrix and k = 1,2,...,N.

  All matrices are treated as dense, and hence TF01RD is not
  intended for large sparse problems.
Specification 
      SUBROUTINE TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, LDH,
     $                   DWORK, LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  NA      (input) INTEGER
          The order of the matrix A.  NA >= 0.

  NB      (input) INTEGER
          The number of system inputs.  NB >= 0.

  NC      (input) INTEGER
          The number of system outputs.  NC >= 0.

  N       (input) INTEGER
          The number of Markov parameters M(k) to be computed.
          N >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,NA)
          The leading NA-by-NA part of this array must contain the
          state matrix A of the system.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,NA).

  B       (input) DOUBLE PRECISION array, dimension (LDB,NB)
          The leading NA-by-NB part of this array must contain the
          input matrix B of the system.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,NA).

  C       (input) DOUBLE PRECISION array, dimension (LDC,NA)
          The leading NC-by-NA part of this array must contain the
          output matrix C of the system.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,NC).

  H       (output) DOUBLE PRECISION array, dimension (LDH,N*NB)
          The leading NC-by-N*NB part of this array contains the
          multivariable parameters M(k), where each parameter M(k)
          is an NC-by-NB matrix and k = 1,2,...,N. The Markov
          parameters are stored such that H(i,(k-1)xNB+j) contains
          the (i,j)-th element of M(k) for i = 1,2,...,NC and
          j = 1,2,...,NB.

  LDH     INTEGER
          The leading dimension of array H.  LDH >= MAX(1,NC).
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, 2*NA*NC).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  For the linear time-invariant discrete-time system

         x(k+1) = A x(k) + B u(k)
          y(k)  = C x(k) + D u(k),

  the transfer function matrix G(z) is given by
                         -1
           G(z) = C(zI-A)  B + D
                          -1        -2     2   -3
                = D + CB z   + CAB z   + CA B z   + ...          (1)

  Using Markov parameters, G(z) can also be written as
                              -1        -2        -3
           G(z) = M(0) + M(1)z   + M(2)z   + M(3)z   + ...       (2)

                                                            k-1
  Equating (1) and (2), we find that M(0) = D and M(k) = C A    B
  for k > 0, from which the Markov parameters M(1),M(2)...,M(N) are
  computed.
References 
  [1] Chen, C.T.
      Introduction to Linear System Theory.
      H.R.W. Series in Electrical Engineering, Electronics and
      Systems, Holt, Rinehart and Winston Inc., London, 1970.
Numerical Aspects 
  The algorithm requires approximately (NA + NB) x NA x NC x N
  multiplications and additions.
Further Comments 
  None
Example

Program Text 

*     TF01RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, NAMAX, NBMAX, NCMAX
      PARAMETER        ( NMAX = 20, NAMAX = 20, NBMAX = 20, NCMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDH
      PARAMETER        ( LDA = NAMAX, LDB = NAMAX, LDC = NCMAX,
     $                   LDH = NCMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*NAMAX*NCMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, N, NA, NB, NC
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NAMAX), B(LDB,NBMAX), C(LDC,NAMAX),
     $                 H(LDH,NMAX*NBMAX), DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         TF01RD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NA, NB, NC
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE IF ( NA.LE.0 .OR. NA.GT.NAMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NA
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,NA ), J = 1,NA )
         IF ( NB.LE.0 .OR. NB.GT.NBMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) NB
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,NA ), J = 1,NB )
            IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) NC
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,NC ), J = 1,NA )
*              Compute M(1),...,M(N) from the system (A,B,C).
               CALL TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H,
     $                      LDH, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) N
                  DO 40 K = 1, N
                     WRITE ( NOUT, FMT = 99996 ) K,
     $                     ( H(1,(K-1)*NB+J), J = 1,NB )
                     DO 20 I = 2, NC
                        WRITE ( NOUT, FMT = 99995 )
     $                        ( H(I,(K-1)*NB+J), J = 1,NB )
   20                CONTINUE
   40             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TF01RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TF01RD = ',I2)
99997 FORMAT (' The Markov Parameters M(1),...,M(',I1,') are ')
99996 FORMAT (/' M(',I1,') : ',20(1X,F8.4))
99995 FORMAT (8X,20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' NA is out of range.',/' NA = ',I5)
99992 FORMAT (/' NB is out of range.',/' NB = ',I5)
99991 FORMAT (/' NC is out of range.',/' NC = ',I5)
      END
Program Data 
 TF01RD EXAMPLE PROGRAM DATA
   5     3     2     2
   0.000 -0.070  0.015
   1.000  0.800 -0.150
   0.000  0.000  0.500
   0.000  2.000  1.000
  -1.000 -0.100  1.000
   0.000  1.000  0.000
   0.000  1.000  0.000
Program Results 
 TF01RD EXAMPLE PROGRAM RESULTS

 The Markov Parameters M(1),...,M(5) are 

 M(1) :    1.0000   1.0000
           0.0000  -1.0000

 M(2) :    0.2000   0.5000
           2.0000  -0.1000

 M(3) :   -0.1100   0.2500
           1.6000  -0.0100

 M(4) :   -0.2020   0.1250
           1.1400  -0.0010

 M(5) :   -0.2039   0.0625
           0.8000  -0.0001

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01AD.html000077500000000000000000000324311201767322700160670ustar00rootroot00000000000000 TG01AD - SLICOT Library Routine Documentation

TG01AD

Balancing the matrices of the system pencil corresponding to a descriptor triple (A-lambda E,B,C)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To balance the matrices of the system pencil

          S =  ( A  B ) - lambda ( E  0 ) :=  Q - lambda Z,
               ( C  0 )          ( 0  0 )

  corresponding to the descriptor triple (A-lambda E,B,C),
  by balancing. This involves diagonal similarity transformations
  (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system
  (A-lambda E,B,C) to make the rows and columns of system pencil
  matrices

               diag(Dl,I) * S * diag(Dr,I)

  as close in norm as possible. Balancing may reduce the 1-norms
  of the matrices of the system pencil S.

  The balancing can be performed optionally on the following
  particular system pencils

           S = A-lambda E,

           S = ( A-lambda E  B ),    or

           S = ( A-lambda E ).
               (     C      )
Specification 
      SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO )
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( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates which matrices are involved in balancing, as
          follows:
          = 'A':  All matrices are involved in balancing;
          = 'B':  B, A and E matrices are involved in balancing;
          = 'C':  C, A and E matrices are involved in balancing;
          = 'N':  B and C matrices are not involved in balancing.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  THRESH  (input) DOUBLE PRECISION
          Threshold value for magnitude of elements:
          elements with magnitude less than or equal to
          THRESH are ignored for balancing. THRESH >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading L-by-N part of this array contains
          the balanced matrix Dl*A*Dr.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E.
          On exit, the leading L-by-N part of this array contains
          the balanced matrix Dl*E*Dr.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B.
          On exit, if M > 0, the leading L-by-M part of this array
          contains the balanced matrix Dl*B.
          The array B is not referenced if M = 0.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, if P > 0, the leading P-by-N part of this array
          contains the balanced matrix C*Dr.
          The array C is not referenced if P = 0.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  LSCALE  (output) DOUBLE PRECISION array, dimension (L)
          The scaling factors applied to S from left.  If Dl(j) is
          the scaling factor applied to row j, then
          SCALE(j) = Dl(j), for j = 1,...,L.

  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
          The scaling factors applied to S from right.  If Dr(j) is
          the scaling factor applied to column j, then
          SCALE(j) = Dr(j), for j = 1,...,N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (3*(L+N))
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Balancing consists of applying a diagonal similarity
  transformation
                         -1
               diag(Dl,I)  * S * diag(Dr,I)

  to make the 1-norms of each row of the first L rows of S and its
  corresponding N columns nearly equal.

  Information about the diagonal matrices Dl and Dr are returned in
  the vectors LSCALE and RSCALE, respectively.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.

  [2] R.C. Ward, R. C.
      Balancing the generalized eigenvalue problem.
      SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     TG01AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDE = LMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, 3*(LMAX+NMAX ) ) )
*     .. Local Scalars ..
      CHARACTER*1      JOBS
      INTEGER          I, INFO, J, L, M, N, P
      DOUBLE PRECISION ABCNRM, ENORM, SABCNM, SENORM, THRESH
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), LSCALE(LMAX),
     $                 RSCALE(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANGE
      EXTERNAL         DLANGE
*     .. External Subroutines ..
      EXTERNAL         TG01AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M, P, JOBS, THRESH
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) L
      ELSE
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99987 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
               IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
                  WRITE ( NOUT, FMT = 99986 ) P
               ELSE
                  READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*                 Compute norms before scaling
                  ABCNRM = MAX( DLANGE( '1', L, N, A, LDA, DWORK ),
     $                          DLANGE( '1', L, M, B, LDB, DWORK ),
     $                          DLANGE( '1', P, N, C, LDC, DWORK ) )
                  ENORM = DLANGE( '1', L, N, E, LDE, DWORK )
*                 Find the transformed descriptor system
*                 (A-lambda E,B,C).
                  CALL TG01AD( JOBS, L, N, M, P, THRESH, A, LDA, E, LDE,
     $                         B, LDB, C, LDC, LSCALE, RSCALE, DWORK,
     $                         INFO )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     SABCNM = MAX( DLANGE( '1', L, N, A, LDA, DWORK ),
     $                             DLANGE( '1', L, M, B, LDB, DWORK ),
     $                             DLANGE( '1', P, N, C, LDC, DWORK ) )
                     SENORM = DLANGE( '1', L, N, E, LDE, DWORK )
                     WRITE ( NOUT, FMT = 99997 )
                     DO 10 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10                CONTINUE
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 30 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30                CONTINUE
                     WRITE ( NOUT, FMT = 99992 )
                     DO 40 I = 1, P
                        WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99995 ) ( LSCALE(I), I = 1,L )
                     WRITE ( NOUT, FMT = 99990 )
                     WRITE ( NOUT, FMT = 99995 ) ( RSCALE(J), J = 1,N )
                     WRITE ( NOUT, FMT = 99994 )
     $                       ABCNRM, SABCNM, ENORM, SENORM
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01AD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Dl*A*Dr is ')
99996 FORMAT (/' The transformed descriptor matrix Dl*E*Dr is ')
99995 FORMAT (20(1X,F9.4))
99994 FORMAT (/' Norm of [ A B; C 0]         =', 1PD10.3/
     $         ' Norm of scaled [ A B; C 0]  =', 1PD10.3/
     $         ' Norm of E                   =', 1PD10.3/
     $         ' Norm of scaled E            =', 1PD10.3)
99993 FORMAT (/' The transformed input/state matrix Dl*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Dr is ')
99991 FORMAT (/' The diagonal of left scaling matrix Dl is ')
99990 FORMAT (/' The diagonal of right scaling matrix Dr is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
TG01AD EXAMPLE PROGRAM DATA
  4    4     2     2     A   0.0
        -1         0         0    0.003
         0         0    0.1000    0.02
       100        10         0    0.4
         0         0         0    0.0
         1       0.2         0    0.0
         0         1         0    0.01
       300        90         6    0.3
         0         0        20    0.0
        10         0
         0         0
         0      1000
     10000     10000
      -0.1      0.0    0.001    0.0
       0.0      0.01  -0.001    0.0001
Program Results 
 TG01AD EXAMPLE PROGRAM RESULTS


 The transformed state dynamics matrix Dl*A*Dr is 
   -1.0000    0.0000    0.0000    0.3000
    0.0000    0.0000    1.0000    2.0000
    1.0000    0.1000    0.0000    0.4000
    0.0000    0.0000    0.0000    0.0000

 The transformed descriptor matrix Dl*E*Dr is 
    1.0000    0.2000    0.0000    0.0000
    0.0000    1.0000    0.0000    1.0000
    3.0000    0.9000    0.6000    0.3000
    0.0000    0.0000    0.2000    0.0000

 The transformed input/state matrix Dl*B is 
  100.0000    0.0000
    0.0000    0.0000
    0.0000  100.0000
  100.0000  100.0000

 The transformed state/output matrix C*Dr is 
   -0.0100    0.0000    0.0010    0.0000
    0.0000    0.0010   -0.0010    0.0010

 The diagonal of left scaling matrix Dl is 
   10.0000   10.0000    0.1000    0.0100

 The diagonal of right scaling matrix Dr is 
    0.1000    0.1000    1.0000   10.0000

 Norm of [ A B; C 0]         = 1.100D+04
 Norm of scaled [ A B; C 0]  = 2.000D+02
 Norm of E                   = 3.010D+02
 Norm of scaled E            = 4.000D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01AZ.html000077500000000000000000000336711201767322700161240ustar00rootroot00000000000000 TG01AZ - SLICOT Library Routine Documentation

TG01AZ

Balancing the matrices of the system pencil corresponding to a descriptor triple (A-lambda E,B,C) (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To balance the matrices of the system pencil

          S =  ( A  B ) - lambda ( E  0 ) :=  Q - lambda Z,
               ( C  0 )          ( 0  0 )

  corresponding to the descriptor triple (A-lambda E,B,C),
  by balancing. This involves diagonal similarity transformations
  (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system
  (A-lambda E,B,C) to make the rows and columns of system pencil
  matrices

               diag(Dl,I) * S * diag(Dr,I)

  as close in norm as possible. Balancing may reduce the 1-norms
  of the matrices of the system pencil S.

  The balancing can be performed optionally on the following
  particular system pencils

           S = A-lambda E,

           S = ( A-lambda E  B ),    or

           S = ( A-lambda E ).
               (     C      )
Specification 
      SUBROUTINE TG01AZ( JOB, L, N, M, P, THRESH, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO )
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( * )
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates which matrices are involved in balancing, as
          follows:
          = 'A':  All matrices are involved in balancing;
          = 'B':  B, A and E matrices are involved in balancing;
          = 'C':  C, A and E matrices are involved in balancing;
          = 'N':  B and C matrices are not involved in balancing.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  THRESH  (input) DOUBLE PRECISION
          Threshold value for magnitude of elements:
          elements with magnitude less than or equal to
          THRESH are ignored for balancing. THRESH >= 0.
          The magnitude is computed as the sum of the absolute
          values of the real and imaginary parts.

  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading L-by-N part of this array contains
          the balanced matrix Dl*A*Dr.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) COMPLEX*16 array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E.
          On exit, the leading L-by-N part of this array contains
          the balanced matrix Dl*E*Dr.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) COMPLEX*16 array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B.
          On exit, if M > 0, the leading L-by-M part of this array
          contains the balanced matrix Dl*B.
          The array B is not referenced if M = 0.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.

  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, if P > 0, the leading P-by-N part of this array
          contains the balanced matrix C*Dr.
          The array C is not referenced if P = 0.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  LSCALE  (output) DOUBLE PRECISION array, dimension (L)
          The scaling factors applied to S from left.  If Dl(j) is
          the scaling factor applied to row j, then
          SCALE(j) = Dl(j), for j = 1,...,L.

  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
          The scaling factors applied to S from right.  If Dr(j) is
          the scaling factor applied to column j, then
          SCALE(j) = Dr(j), for j = 1,...,N.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (3*(L+N))
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  Balancing consists of applying a diagonal similarity
  transformation
                         -1
               diag(Dl,I)  * S * diag(Dr,I)

  to make the 1-norms of each row of the first L rows of S and its
  corresponding N columns nearly equal.

  Information about the diagonal matrices Dl and Dr are returned in
  the vectors LSCALE and RSCALE, respectively.
References 
  [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.

  [2] R.C. Ward, R. C.
      Balancing the generalized eigenvalue problem.
      SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     TG01AZ EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDE = LMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, 3*(LMAX+NMAX ) ) )
*     .. Local Scalars ..
      CHARACTER*1      JOBS
      INTEGER          I, INFO, J, L, M, N, P
      DOUBLE PRECISION ABCNRM, ENORM, SABCNM, SENORM, THRESH
*     .. Local Arrays ..
      COMPLEX*16       A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 E(LDE,NMAX)
      DOUBLE PRECISION DWORK(LDWORK), LSCALE(LMAX), RSCALE(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION ZLANGE
      EXTERNAL         ZLANGE
*     .. External Subroutines ..
      EXTERNAL         TG01AZ
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M, P, JOBS, THRESH
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) L
      ELSE
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99987 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
               IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
                  WRITE ( NOUT, FMT = 99986 ) P
               ELSE
                  READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*                 Compute norms before scaling
                  ABCNRM = MAX( ZLANGE( '1', L, N, A, LDA, DWORK ),
     $                          ZLANGE( '1', L, M, B, LDB, DWORK ),
     $                          ZLANGE( '1', P, N, C, LDC, DWORK ) )
                  ENORM = ZLANGE( '1', L, N, E, LDE, DWORK )
*                 Find the transformed descriptor system
*                 (A-lambda E,B,C).
                  CALL TG01AZ( JOBS, L, N, M, P, THRESH, A, LDA, E, LDE,
     $                         B, LDB, C, LDC, LSCALE, RSCALE, DWORK,
     $                         INFO )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     SABCNM = MAX( ZLANGE( '1', L, N, A, LDA, DWORK ),
     $                             ZLANGE( '1', L, M, B, LDB, DWORK ),
     $                             ZLANGE( '1', P, N, C, LDC, DWORK ) )
                     SENORM = ZLANGE( '1', L, N, E, LDE, DWORK )
                     WRITE ( NOUT, FMT = 99997 )
                     DO 10 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10                CONTINUE
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 30 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30                CONTINUE
                     WRITE ( NOUT, FMT = 99992 )
                     DO 40 I = 1, P
                        WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99985 ) ( LSCALE(I), I = 1,L )
                     WRITE ( NOUT, FMT = 99990 )
                     WRITE ( NOUT, FMT = 99985 ) ( RSCALE(J), J = 1,N )
                     WRITE ( NOUT, FMT = 99994 )
     $                       ABCNRM, SABCNM, ENORM, SENORM
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01AZ EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01AZ = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Dl*A*Dr is ')
99996 FORMAT (/' The transformed descriptor matrix Dl*E*Dr is ')
99995 FORMAT (20(1X,F9.4,SP,F9.4,S,'i '))
99994 FORMAT (/' Norm of [ A B; C 0]         =', 1PD10.3/
     $         ' Norm of scaled [ A B; C 0]  =', 1PD10.3/
     $         ' Norm of E                   =', 1PD10.3/
     $         ' Norm of scaled E            =', 1PD10.3)
99993 FORMAT (/' The transformed input/state matrix Dl*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Dr is ')
99991 FORMAT (/' The diagonal of left scaling matrix Dl is ')
99990 FORMAT (/' The diagonal of right scaling matrix Dr is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
99985 FORMAT (20(1X,F9.4))
      END
Program Data 
TG01AZ EXAMPLE PROGRAM DATA
  4    4     2     2     A   0.0
        -1         0         0    0.003
         0         0    0.1000    0.02
       100        10         0    0.4
         0         0         0    0.0
         1       0.2         0    0.0
         0         1         0    0.01
       300        90         6    0.3
         0         0        20    0.0
        10         0
         0         0
         0      1000
     10000     10000
      -0.1      0.0    0.001    0.0
       0.0      0.01  -0.001    0.0001
Program Results 
 TG01AZ EXAMPLE PROGRAM RESULTS


 The transformed state dynamics matrix Dl*A*Dr is 
   -1.0000  +0.0000i     0.0000  +0.0000i     0.0000  +0.0000i     0.3000  +0.0000i 
    0.0000  +0.0000i     0.0000  +0.0000i     1.0000  +0.0000i     2.0000  +0.0000i 
    1.0000  +0.0000i     0.1000  +0.0000i     0.0000  +0.0000i     0.4000  +0.0000i 
    0.0000  +0.0000i     0.0000  +0.0000i     0.0000  +0.0000i     0.0000  +0.0000i 

 The transformed descriptor matrix Dl*E*Dr is 
    1.0000  +0.0000i     0.2000  +0.0000i     0.0000  +0.0000i     0.0000  +0.0000i 
    0.0000  +0.0000i     1.0000  +0.0000i     0.0000  +0.0000i     1.0000  +0.0000i 
    3.0000  +0.0000i     0.9000  +0.0000i     0.6000  +0.0000i     0.3000  +0.0000i 
    0.0000  +0.0000i     0.0000  +0.0000i     0.2000  +0.0000i     0.0000  +0.0000i 

 The transformed input/state matrix Dl*B is 
  100.0000  +0.0000i     0.0000  +0.0000i 
    0.0000  +0.0000i     0.0000  +0.0000i 
    0.0000  +0.0000i   100.0000  +0.0000i 
  100.0000  +0.0000i   100.0000  +0.0000i 

 The transformed state/output matrix C*Dr is 
   -0.0100  +0.0000i     0.0000  +0.0000i     0.0010  +0.0000i     0.0000  +0.0000i 
    0.0000  +0.0000i     0.0010  +0.0000i    -0.0010  +0.0000i     0.0010  +0.0000i 

 The diagonal of left scaling matrix Dl is 
   10.0000   10.0000    0.1000    0.0100

 The diagonal of right scaling matrix Dr is 
    0.1000    0.1000    1.0000   10.0000

 Norm of [ A B; C 0]         = 1.100D+04
 Norm of scaled [ A B; C 0]  = 2.000D+02
 Norm of E                   = 3.010D+02
 Norm of scaled E            = 4.000D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01BD.html000077500000000000000000000230771201767322700160760ustar00rootroot00000000000000 TG01BD - SLICOT Library Routine Documentation

TG01BD

Orthogonal reduction of a descriptor system to the generalized Hessenberg form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the matrices A and E of the system pencil

          S =  ( A  B ) - lambda ( E  0 ) ,
               ( C  0 )          ( 0  0 )

  corresponding to the descriptor triple (A-lambda E,B,C),
  to generalized upper Hessenberg form using orthogonal
  transformations,

       Q' * A * Z = H,   Q' * E * Z = T,

  where H is upper Hessenberg, T is upper triangular, Q and Z
  are orthogonal, and ' means transpose. The corresponding
  transformations, written compactly as diag(Q',I) * S * diag(Z,I),
  are also applied to B and C, getting Q' * B and C * Z.

  The orthogonal matrices Q and Z are determined as products of
  Givens rotations. They may either be formed explicitly, or they
  may be postmultiplied into input matrices Q1 and Z1, so that

       Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)'
       Q1 * E * Z1' = (Q1*Q) * T * (Z1*Z)'.
Specification 
      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     .. 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, * )
Arguments

Mode Parameters 

  JOBE    CHARACTER*1
          Specifies whether E is a general square or an upper
          triangular matrix, as follows:
          = 'G':  E is a general square matrix;
          = 'U':  E is an upper triangular matrix.

  COMPQ   CHARACTER*1
          Indicates what should be done with matrix Q, as follows:
          = 'N':  do not compute Q;
          = 'I':  Q is initialized to the unit matrix, and the
                  orthogonal matrix Q is returned;
          = 'V':  Q must contain an orthogonal matrix Q1 on entry,
                  and the product Q1*Q is returned.

  COMPZ   CHARACTER*1
          Indicates what should be done with matrix Z, as follows:
          = 'N':  do not compute Z;
          = 'I':  Z is initialized to the unit matrix, and the
                  orthogonal matrix Z is returned;
          = 'V':  Z must contain an orthogonal matrix Z1 on entry,
                  and the product Z1*Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The order of the matrices A, E, and the number of rows of
          the matrix B.  N >= 0.

  M       (input) INTEGER
          The number of columns of the matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of the matrix C.  P >= 0.

  ILO     (input) INTEGER
  IHI     (input) INTEGER
          It is assumed that A and E are already upper triangular in
          rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI could
          normally be set by a previous call to LAPACK Library
          routine DGGBAL; otherwise they should be set to 1 and N,
          respectively.
          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
          If JOBE = 'U', the matrix E is assumed upper triangular.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading N-by-N part of this array contains
          the upper Hessenberg matrix H = Q' * A * Z. The elements
          below the first subdiagonal are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the descriptor matrix E. If JOBE = 'U', this
          matrix is assumed upper triangular.
          On exit, the leading N-by-N part of this array contains
          the upper triangular matrix T = Q' * E * Z. The elements
          below the diagonal are set to zero.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input/state matrix B.
          On exit, if M > 0, the leading N-by-M part of this array
          contains the transformed matrix Q' * B.
          The array B is not referenced if M = 0.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,N) if M > 0;  LDB >= 1 if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, if P > 0, the leading P-by-N part of this array
          contains the transformed matrix C * Z.
          The array C is not referenced if P = 0.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          If COMPQ = 'N':  Q is not referenced;
          If COMPQ = 'I':  on entry, Q need not be set, and on exit
                           it contains the orthogonal matrix Q,
                           where Q' is the product of the Givens
                           transformations which are applied to A,
                           E, and B on the left;
          If COMPQ = 'V':  on entry, Q must contain an orthogonal
                           matrix Q1, and on exit this is
                           overwritten by Q1*Q.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,        if COMPQ = 'N';
          LDQ >= MAX(1,N), if COMPQ = 'I' or 'V'.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          If COMPZ = 'N':  Z is not referenced;
          If COMPZ = 'I':  on entry, Z need not be set, and on exit
                           it contains the orthogonal matrix Z,
                           which is the product of the Givens
                           transformations applied to A, E, and C
                           on the right;
          If COMPZ = 'V':  on entry, Z must contain an orthogonal
                           matrix Z1, and on exit this is
                           overwritten by Z1*Z.

  LDZ     INTEGER
          The leading dimension of array Z.
          LDZ >= 1,        if COMPZ = 'N';
          LDZ >= MAX(1,N), if COMPZ = 'I' or 'V'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) contains the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of the array DWORK.
          LDWORK >= 1,                          if JOBE = 'U';
          LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)), if JOBE = 'G', where
          NI = N+1-ILO, if COMPQ = 'N', and NI = N, otherwise.
          For good performance, if JOBE = 'G', LDWORK must generally
          be larger, LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)*NB), where
          NB is the optimal block size.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit.
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  First, this routine computes the QR factorization of E and applies
  the transformations to A, B, and possibly Q. Then, the routine
  reduces A to upper Hessenberg form, preserving E triangular, by
  an unblocked reduction [1], using two sequences of plane rotations
  applied alternately from the left and from the right. The
  corresponding transformations may be accumulated and/or applied
  to the matrices B and C. If JOBE = 'U', the initial reduction of E
  to upper triangular form is skipped.

  This routine is a modification and extension of the LAPACK Library
  routine DGGHRD [2].
References 
  [1] Golub, G.H. and van Loan, C.F.
      Matrix Computations. Third Edition.
      M. D. Johns Hopkins University Press, Baltimore, 1996.

  [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
      Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
      Ostrouchov, S., and Sorensen, D.
      LAPACK Users' Guide: Second Edition.
      SIAM, Philadelphia, 1995.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01CD.html000077500000000000000000000242661201767322700161000ustar00rootroot00000000000000 TG01CD - SLICOT Library Routine Documentation

TG01CD

Orthogonal reduction of a descriptor system pair (A-lambda E,B) to the QR-coordinate form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the descriptor system pair (A-lambda E,B) to the
  QR-coordinate form by computing an orthogonal transformation
  matrix Q such that the transformed descriptor system pair
  (Q'*A-lambda Q'*E, Q'*B) has the descriptor matrix Q'*E
  in an upper trapezoidal form.
  The left orthogonal transformations performed to reduce E
  can be optionally accumulated.
Specification 
      SUBROUTINE TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, Q, LDQ,
     $                   DWORK, LDWORK, INFO )
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, * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          = 'N':  do not compute Q;
          = 'I':  Q is initialized to the unit matrix, and the
                  orthogonal matrix Q is returned;
          = 'U':  Q must contain an orthogonal matrix Q1 on entry,
                  and the product Q1*Q is returned.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A and E.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*A.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*E in upper trapezoidal form,
          i.e.

                   ( E11 )
            Q'*E = (     ) ,     if L >= N ,
                   (  0  )
          or

            Q'*E = ( E11 E12 ),  if L < N ,

          where E11 is an MIN(L,N)-by-MIN(L,N) upper triangular
          matrix.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B.
          On exit, the leading L-by-M part of this array contains
          the transformed matrix Q'*B.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,L)
          If COMPQ = 'N':  Q is not referenced.
          If COMPQ = 'I':  on entry, Q need not be set;
                           on exit, the leading L-by-L part of this
                           array contains the orthogonal matrix Q,
                           where Q' is the product of Householder
                           transformations which are applied to A,
                           E, and B on the left.
          If COMPQ = 'U':  on entry, the leading L-by-L part of this
                           array must contain an orthogonal matrix
                           Q1;
                           on exit, the leading L-by-L part of this
                           array contains the orthogonal matrix
                           Q1*Q.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,        if COMPQ = 'N';
          LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)).
          For optimum performance
          LWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)*NB),
          where NB is the optimal blocksize.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes the QR factorization of E to reduce it
  to the upper trapezoidal form.

  The transformations are also applied to the rest of system
  matrices

      A <- Q' * A ,  B <- Q' * B.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( L*L*N )  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TG01CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20)
      INTEGER          LDA, LDB, LDE, LDQ
      PARAMETER        ( LDA = LMAX, LDB = LMAX,
     $                   LDE = LMAX, LDQ = LMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MIN(LMAX,NMAX)+MAX(LMAX,NMAX,MMAX) )
*     .. Local Scalars ..
      CHARACTER*1      COMPQ
      INTEGER          I, INFO, J, L, M, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M
      COMPQ = 'I'
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) L
      ELSE
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
*              Find the transformed descriptor system pair
*              (A-lambda E,B).
               CALL TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB,
     $                      Q, LDQ, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 30 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L )
   40             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01CD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' The transformed input/state matrix Q''*B is ')
99993 FORMAT (/' The left transformation matrix Q is ')
99992 FORMAT (/' L is out of range.',/' L = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
TG01CD EXAMPLE PROGRAM DATA
  4    4     2    0.0    
    -1     0     0     3
     0     0     1     2
     1     1     0     4
     0     0     0     0
     1     2     0     0
     0     1     0     1
     3     9     6     3
     0     0     2     0
     1     0
     0     0
     0     1
     1     1
Program Results 
 TG01CD EXAMPLE PROGRAM RESULTS


 The transformed state dynamics matrix Q'*A is 
  -0.6325  -0.9487   0.0000  -4.7434
  -0.8706  -0.2176  -0.7255  -0.3627
  -0.5203  -0.1301   0.3902   1.4307
  -0.7559  -0.1890   0.5669   2.0788

 The transformed descriptor matrix Q'*E is 
  -3.1623  -9.1706  -5.6921  -2.8460
   0.0000  -1.3784  -1.3059  -1.3784
   0.0000   0.0000  -2.4279   0.0000
   0.0000   0.0000   0.0000   0.0000

 The transformed input/state matrix Q'*B is 
  -0.3162  -0.9487
   0.6529  -0.2176
  -0.4336  -0.9538
   1.1339   0.3780

 The left transformation matrix Q is 
  -0.3162   0.6529   0.3902   0.5669
   0.0000  -0.7255   0.3902   0.5669
  -0.9487  -0.2176  -0.1301  -0.1890
   0.0000   0.0000  -0.8238   0.5669

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01DD.html000077500000000000000000000241311201767322700160700ustar00rootroot00000000000000 TG01DD - SLICOT Library Routine Documentation

TG01DD

Orthogonal reduction of a descriptor system pair (C,A-lambda E) to the RQ-coordinate form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the descriptor system pair (C,A-lambda E) to the
  RQ-coordinate form by computing an orthogonal transformation
  matrix Z such that the transformed descriptor system pair
  (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper
  trapezoidal form.
  The right orthogonal transformations performed to reduce E can
  be optionally accumulated.
Specification 
      SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ,
     $                   DWORK, LDWORK, INFO )
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, * )
Arguments

Mode Parameters 

  COMPZ   CHARACTER*1
          = 'N':  do not compute Z;
          = 'I':  Z is initialized to the unit matrix, and the
                  orthogonal matrix Z is returned;
          = 'U':  Z must contain an orthogonal matrix Z1 on entry,
                  and the product Z1*Z is returned.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix A*Z.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix E*Z in upper trapezoidal form,
          i.e.

                   ( E11 )
             E*Z = (     ) ,  if L >= N ,
                   (  R  )
          or

             E*Z = ( 0  R ),  if L < N ,

          where R is an MIN(L,N)-by-MIN(L,N) upper triangular
          matrix.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix C*Z.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          If COMPZ = 'N':  Z is not referenced.
          If COMPZ = 'I':  on entry, Z need not be set;
                           on exit, the leading N-by-N part of this
                           array contains the orthogonal matrix Z,
                           which is the product of Householder
                           transformations applied to A, E, and C
                           on the right.
          If COMPZ = 'U':  on entry, the leading N-by-N part of this
                           array must contain an orthogonal matrix
                           Z1;
                           on exit, the leading N-by-N part of this
                           array contains the orthogonal matrix
                           Z1*Z.

  LDZ     INTEGER
          The leading dimension of array Z.
          LDZ >= 1,        if COMPZ = 'N';
          LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)).
          For optimum performance
          LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB),
          where NB is the optimal blocksize.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes the RQ factorization of E to reduce it
  the upper trapezoidal form.

  The transformations are also applied to the rest of system
  matrices

      A <- A * Z,  C <- C * Z.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( L*N*N )  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TG01DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, PMAX = 20)
      INTEGER          LDA, LDC, LDE, LDZ
      PARAMETER        ( LDA = LMAX, LDC = PMAX,
     $                   LDE = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MIN(LMAX,NMAX)+MAX(LMAX,NMAX,PMAX) )
*     .. Local Scalars ..
      CHARACTER*1      COMPZ
      INTEGER          I, INFO, J, L, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, P
      COMPZ = 'I'
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) L
      ELSE
         IF( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed descriptor system pair
*              (A-lambda E,B).
               CALL TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC,
     $                      Z, LDZ, DWORK, LDWORK, INFO )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 30 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   40             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01DD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' The transformed input/state matrix C*Z is ')
99993 FORMAT (/' The right transformation matrix Z is ')
99992 FORMAT (/' L is out of range.',/' L = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
TG01DD EXAMPLE PROGRAM DATA
  4    4     2    0.0    
    -1     0     0     3
     0     0     1     2
     1     1     0     4
     0     0     0     0
     1     2     0     0
     0     1     0     1
     3     9     6     3
     0     0     2     0
    -1     0     1     0
     0     1    -1     1
Program Results 
 TG01DD EXAMPLE PROGRAM RESULTS


 The transformed state dynamics matrix A*Z is 
   0.4082   3.0773   0.6030   0.0000
   0.8165   1.7233   0.6030  -1.0000
   2.0412   2.8311   2.4121   0.0000
   0.0000   0.0000   0.0000   0.0000

 The transformed descriptor matrix E*Z is 
   0.0000  -0.7385   2.1106   0.0000
   0.0000   0.7385   1.2060   0.0000
   0.0000   0.0000   9.9499  -6.0000
   0.0000   0.0000   0.0000  -2.0000

 The transformed input/state matrix C*Z is 
  -0.8165   0.4924  -0.3015  -1.0000
   0.0000   0.7385   1.2060   1.0000

 The right transformation matrix Z is 
   0.8165  -0.4924   0.3015   0.0000
  -0.4082  -0.1231   0.9045   0.0000
   0.0000   0.0000   0.0000  -1.0000
   0.4082   0.8616   0.3015   0.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01ED.html000077500000000000000000000355771201767322700161110ustar00rootroot00000000000000 TG01ED - SLICOT Library Routine Documentation

TG01ED

Orthogonal reduction of a descriptor system to a SVD coordinate form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute for the descriptor system (A-lambda E,B,C)
  the orthogonal transformation matrices Q and Z such that the
  transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an
  SVD (singular value decomposition) coordinate form with
  the system matrices  Q'*A*Z and Q'*E*Z in the form

               ( A11  A12 )             ( Er  0 )
      Q'*A*Z = (          ) ,  Q'*E*Z = (       ) ,
               ( A21  A22 )             (  0  0 )

  where Er is an invertible diagonal matrix having on the diagonal
  the decreasingly ordered nonzero singular values of E.
  Optionally, the A22 matrix can be further reduced to the
  SVD form

               ( Ar  0 )
         A22 = (       ) ,
               (  0  0 )

  where Ar is an invertible diagonal matrix having on the diagonal
  the decreasingly ordered nonzero singular values of A22.
  The left and/or right orthogonal transformations performed
  to reduce E and A22 are accumulated.
Specification 
      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     .. 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, * )
Arguments

Mode Parameters 

  JOBA    CHARACTER*1
          = 'N':  do not reduce A22;
          = 'R':  reduce A22 to an SVD form.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix
          is in the form

                        ( A11  *   *  )
               Q'*A*Z = (  *   Ar  0  ) ,
                        (  *   0   0  )

          where A11 is a RANKE-by-RANKE matrix and Ar is a
          RNKA22-by-RNKA22 invertible diagonal matrix, with
          decresingly ordered positive diagonal elements.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*E*Z.

                   ( Er  0 )
          Q'*E*Z = (       ) ,
                   (  0  0 )

          where Er is a RANKE-by-RANKE invertible diagonal matrix
          having on the diagonal the decreasingly ordered positive
          singular values of E.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B.
          On exit, the leading L-by-M part of this array contains
          the transformed matrix Q'*B.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix C*Z.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Q       (output) DOUBLE PRECISION array, dimension (LDQ,L)
          The leading L-by-L part of this array contains the
          orthogonal matrix Q, which is the accumulated product of
          transformations applied to A, E, and B on the left.

  LDQ     INTEGER
          The leading dimension of array Q.  LDQ >= MAX(1,L).

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          The leading N-by-N part of this array contains the
          orthogonal matrix Z, which is the accumulated product of
          transformations applied to A, E, and C on the right.

  LDZ     INTEGER
          The leading dimension of array Z.  LDZ >= MAX(1,N).

  RANKE   (output) INTEGER
          The effective rank of matrix E, and thus also the order
          of the invertible diagonal submatrix Er.
          RANKE is computed as the number of singular values of E
          greater than TOL*SVEMAX, where SVEMAX is the maximum
          singular value of E.

  RNKA22  (output) INTEGER
          If JOBA = 'R', then RNKA22 is the effective rank of
          matrix A22, and thus also the order of the invertible
          diagonal submatrix Ar. RNKA22 is computed as the number
          of singular values of A22 greater than TOL*SVAMAX,
          where SVAMAX is an estimate of the maximum singular value
          of A.
          If JOBA = 'N', then RNKA22 is not referenced.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the rank of E
          and of A22. If TOL > 0, then singular values less than
          TOL*SVMAX are treated as zero, where SVMAX is the maximum
          singular value of E or an estimate of it for A and E.
          If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is
          used instead, where EPS is the machine precision
          (see LAPACK Library routine DLAMCH). TOL < 1.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(1,MIN(L,N) +
                        MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  the QR algorithm has failed to converge when computing
                singular value decomposition. In this case INFO
                specifies how many superdiagonals did not converge.
                This failure is not likely to occur.
Method 
  The routine computes the singular value decomposition (SVD) of E,
  in the form

                 ( Er  0 )
        E  = Q * (       ) * Z'
                 (  0  0 )

  and finds the largest RANKE-by-RANKE leading diagonal submatrix
  Er whose condition number is less than 1/TOL. RANKE defines thus
  the effective rank of matrix E.
  If JOBA = 'R' the same reduction is performed on A22 in the
  partitioned matrix

               ( A11  A12 )
      Q'*A*Z = (          ) ,
               ( A21  A22 )

  to obtain it in the form

               ( Ar  0 )
         A22 = (       ) ,
               (  0  0 )

  with Ar an invertible diagonal matrix.

  The accumulated transformations are also applied to the rest of
  matrices

       B <- Q' * B,  C <- C * Z.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( L*L*N )  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TG01ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDE = LMAX, LDQ = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, MIN( LMAX, NMAX ) +
     $                            MAX( MMAX, PMAX, 3*MIN( LMAX, NMAX ) +
     $                            MAX( LMAX, NMAX ),
     $                            5*MIN( LMAX, NMAX ) ) ) )
*     .. Local Scalars ..
      CHARACTER*1      JOBA
      INTEGER          I, INFO, J, L, M, N, P, RANKE, RNKA22
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01ED
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M, P, TOL
      JOBA = 'R'
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) L
      ELSE
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99987 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
               IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
                  WRITE ( NOUT, FMT = 99986 ) P
               ELSE
                  READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*                 Find the transformed descriptor system
*                 (A-lambda E,B,C).
                  CALL TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB,
     $                         C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22,
     $                         TOL, DWORK, LDWORK, INFO )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22
                     WRITE ( NOUT, FMT = 99997 )
                     DO 10 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10                CONTINUE
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 30 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30                CONTINUE
                     WRITE ( NOUT, FMT = 99992 )
                     DO 40 I = 1, P
                        WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99991 )
                     DO 50 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L )
   50                CONTINUE
                     WRITE ( NOUT, FMT = 99990 )
                     DO 60 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01ED EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01ED = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Rank of matrix E   =', I5/
     $        ' Rank of matrix A22 =', I5)
99993 FORMAT (/' The transformed input/state matrix Q''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Z is ')
99991 FORMAT (/' The left transformation matrix Q is ')
99990 FORMAT (/' The right transformation matrix Z is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
TG01ED EXAMPLE PROGRAM DATA
  4    4     2     2     0.0    
    -1     0     0     3
     0     0     1     2
     1     1     0     4
     0     0     0     0
     1     2     0     0
     0     1     0     1
     3     9     6     3
     0     0     2     0
     1     0
     0     0
     0     1
     1     1
    -1     0     1     0
     0     1    -1     1
Program Results 
 TG01ED EXAMPLE PROGRAM RESULTS

 Rank of matrix E   =    3
 Rank of matrix A22 =    1

 The transformed state dynamics matrix Q'*A*Z is 
   2.1882  -0.8664  -3.5097  -2.1353
  -0.4569  -0.2146   1.9802   0.3531
  -0.5717  -0.5245  -0.4591   0.4696
  -0.4766  -0.5846   2.1414   0.3086

 The transformed descriptor matrix Q'*E*Z is 
  11.8494   0.0000   0.0000   0.0000
   0.0000   2.1302   0.0000   0.0000
   0.0000   0.0000   1.0270   0.0000
   0.0000   0.0000   0.0000   0.0000

 The transformed input/state matrix Q'*B is 
  -0.2396  -1.0668
  -0.2656  -0.8393
  -0.7657  -0.1213
   1.1339   0.3780

 The transformed state/output matrix C*Z is 
  -0.2499  -1.0573   0.3912  -0.8165
  -0.5225   1.3958   0.8825   0.0000

 The left transformation matrix Q is 
  -0.1534   0.5377  -0.6049   0.5669
  -0.0872   0.2536   0.7789   0.5669
  -0.9805  -0.0360   0.0395  -0.1890
  -0.0863  -0.8033  -0.1608   0.5669

 The right transformation matrix Z is 
  -0.2612   0.2017  -0.4737   0.8165
  -0.7780   0.4718  -0.0738  -0.4082
  -0.5111  -0.8556  -0.0826   0.0000
  -0.2556   0.0684   0.8737   0.4082

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01FD.html000077500000000000000000000424611201767322700161000ustar00rootroot00000000000000 TG01FD - SLICOT Library Routine Documentation

TG01FD

Orthogonal reduction of a descriptor system to a SVD-like coordinate form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute for the descriptor system (A-lambda E,B,C)
  the orthogonal transformation matrices Q and Z such that the
  transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is
  in a SVD-like coordinate form with

               ( A11  A12 )             ( Er  0 )
      Q'*A*Z = (          ) ,  Q'*E*Z = (       ) ,
               ( A21  A22 )             (  0  0 )

  where Er is an upper triangular invertible matrix.
  Optionally, the A22 matrix can be further reduced to the form

               ( Ar  X )
         A22 = (       ) ,
               (  0  0 )

  with Ar an upper triangular invertible matrix, and X either a full
  or a zero matrix.
  The left and/or right orthogonal transformations performed
  to reduce E and A22 can be optionally accumulated.
Specification 
      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     .. 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, * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          = 'N':  do not compute Q;
          = 'I':  Q is initialized to the unit matrix, and the
                  orthogonal matrix Q is returned;
          = 'U':  Q must contain an orthogonal matrix Q1 on entry,
                  and the product Q1*Q is returned.

  COMPZ   CHARACTER*1
          = 'N':  do not compute Z;
          = 'I':  Z is initialized to the unit matrix, and the
                  orthogonal matrix Z is returned;
          = 'U':  Z must contain an orthogonal matrix Z1 on entry,
                  and the product Z1*Z is returned.

  JOBA    CHARACTER*1
          = 'N':  do not reduce A22;
          = 'R':  reduce A22 to a SVD-like upper triangular form.
          = 'T':  reduce A22 to an upper trapezoidal form.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix
          is in the form

                        ( A11  *   *  )
               Q'*A*Z = (  *   Ar  X  ) ,
                        (  *   0   0  )

          where A11 is a RANKE-by-RANKE matrix and Ar is a
          RNKA22-by-RNKA22 invertible upper triangular matrix.
          If JOBA = 'R' then A has the above form with X = 0.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*E*Z.

                   ( Er  0 )
          Q'*E*Z = (       ) ,
                   (  0  0 )

          where Er is a RANKE-by-RANKE upper triangular invertible
          matrix.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B.
          On exit, the leading L-by-M part of this array contains
          the transformed matrix Q'*B.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix C*Z.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,L)
          If COMPQ = 'N':  Q is not referenced.
          If COMPQ = 'I':  on entry, Q need not be set;
                           on exit, the leading L-by-L part of this
                           array contains the orthogonal matrix Q,
                           where Q' is the product of Householder
                           transformations which are applied to A,
                           E, and B on the left.
          If COMPQ = 'U':  on entry, the leading L-by-L part of this
                           array must contain an orthogonal matrix
                           Q1;
                           on exit, the leading L-by-L part of this
                           array contains the orthogonal matrix
                           Q1*Q.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,        if COMPQ = 'N';
          LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          If COMPZ = 'N':  Z is not referenced.
          If COMPZ = 'I':  on entry, Z need not be set;
                           on exit, the leading N-by-N part of this
                           array contains the orthogonal matrix Z,
                           which is the product of Householder
                           transformations applied to A, E, and C
                           on the right.
          If COMPZ = 'U':  on entry, the leading N-by-N part of this
                           array must contain an orthogonal matrix
                           Z1;
                           on exit, the leading N-by-N part of this
                           array contains the orthogonal matrix
                           Z1*Z.

  LDZ     INTEGER
          The leading dimension of array Z.
          LDZ >= 1,        if COMPZ = 'N';
          LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.

  RANKE   (output) INTEGER
          The estimated rank of matrix E, and thus also the order
          of the invertible upper triangular submatrix Er.

  RNKA22  (output) INTEGER
          If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of
          matrix A22, and thus also the order of the invertible
          upper triangular submatrix Ar.
          If JOBA = 'N', then RNKA22 is not referenced.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the rank of E
          and of A22. If the user sets TOL > 0, then the given
          value of TOL is used as a lower bound for the
          reciprocal condition numbers of leading submatrices
          of R or R22 in the QR decompositions E * P = Q * R of E
          or A22 * P22 = Q22 * R22 of A22.
          A submatrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = L*N*EPS,  is used instead, where
          EPS is the machine precision (see LAPACK Library routine
          DLAMCH). TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ).
          For optimal performance, LDWORK should be larger.

          If LDWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          DWORK array, returns this value as the first entry of
          the DWORK array, and no error message related to LDWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a truncated QR factorization with column
  pivoting of E, in the form

                    ( E11 E12 )
        E * P = Q * (         )
                    (  0  E22 )

  and finds the largest RANKE-by-RANKE leading submatrix E11 whose
  estimated condition number is less than 1/TOL. RANKE defines thus
  the rank of matrix E. Further E22, being negligible, is set to
  zero, and an orthogonal matrix Y is determined such that

        ( E11 E12 ) = ( Er  0 ) * Y .

  The overal transformation matrix Z results as Z = P * Y' and the
  resulting transformed matrices Q'*A*Z and Q'*E*Z have the form

                       ( Er  0 )                      ( A11  A12 )
      E <- Q'* E * Z = (       ) ,  A <- Q' * A * Z = (          ) ,
                       (  0  0 )                      ( A21  A22 )

  where Er is an upper triangular invertible matrix.
  If JOBA = 'R' the same reduction is performed on A22 to obtain it
  in the form

               ( Ar  0 )
         A22 = (       ) ,
               (  0  0 )

  with Ar an upper triangular invertible matrix.
  If JOBA = 'T' then A22 is row compressed using the QR
  factorization with column pivoting to the form

               ( Ar  X )
         A22 = (       )
               (  0  0 )

  with Ar an upper triangular invertible matrix.

  The transformations are also applied to the rest of system
  matrices

       B <- Q' * B, C <- C * Z.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( L*L*N )  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TG01FD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDE = LMAX, LDQ = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, PMAX,
     $                   MIN(LMAX,NMAX)+MAX( 3*NMAX, MMAX, LMAX ) ) )
*     .. Local Scalars ..
      CHARACTER*1      COMPQ, COMPZ, JOBA
      INTEGER          I, INFO, J, L, M, N, P, RANKE, RNKA22
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          IWORK(NMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01FD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M, P, TOL
      COMPQ = 'I'
      COMPZ = 'I'
      JOBA = 'R'
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) L
      ELSE
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99987 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
               IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
                  WRITE ( NOUT, FMT = 99986 ) P
               ELSE
                  READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*                 Find the transformed descriptor system
*                 (A-lambda E,B,C).
                  CALL 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 )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22
                     WRITE ( NOUT, FMT = 99997 )
                     DO 10 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10                CONTINUE
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 30 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30                CONTINUE
                     WRITE ( NOUT, FMT = 99992 )
                     DO 40 I = 1, P
                        WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99991 )
                     DO 50 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L )
   50                CONTINUE
                     WRITE ( NOUT, FMT = 99990 )
                     DO 60 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01FD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01FD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Rank of matrix E   =', I5/
     $        ' Rank of matrix A22 =', I5)
99993 FORMAT (/' The transformed input/state matrix Q''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Z is ')
99991 FORMAT (/' The left transformation matrix Q is ')
99990 FORMAT (/' The right transformation matrix Z is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
TG01FD EXAMPLE PROGRAM DATA
  4    4     2     2     0.0    
    -1     0     0     3
     0     0     1     2
     1     1     0     4
     0     0     0     0
     1     2     0     0
     0     1     0     1
     3     9     6     3
     0     0     2     0
     1     0
     0     0
     0     1
     1     1
    -1     0     1     0
     0     1    -1     1
Program Results 
 TG01FD EXAMPLE PROGRAM RESULTS

 Rank of matrix E   =    3
 Rank of matrix A22 =    1

 The transformed state dynamics matrix Q'*A*Z is 
   2.0278   0.1078   3.9062  -2.1571
  -0.0980   0.2544   1.6053  -0.1269
   0.2713   0.7760  -0.3692  -0.4853
   0.0690  -0.5669  -2.1974   0.3086

 The transformed descriptor matrix Q'*E*Z is 
  10.1587   5.8230   1.3021   0.0000
   0.0000  -2.4684  -0.1896   0.0000
   0.0000   0.0000   1.0338   0.0000
   0.0000   0.0000   0.0000   0.0000

 The transformed input/state matrix Q'*B is 
  -0.2157  -0.9705
   0.3015   0.9516
   0.7595   0.0991
   1.1339   0.3780

 The transformed state/output matrix C*Z is 
   0.3651  -1.0000  -0.4472  -0.8165
  -1.0954   1.0000  -0.8944   0.0000

 The left transformation matrix Q is 
  -0.2157  -0.5088   0.6109   0.5669
  -0.1078  -0.2544  -0.7760   0.5669
  -0.9705   0.1413  -0.0495  -0.1890
   0.0000   0.8102   0.1486   0.5669

 The right transformation matrix Z is 
  -0.3651   0.0000   0.4472   0.8165
  -0.9129   0.0000   0.0000  -0.4082
   0.0000  -1.0000   0.0000   0.0000
  -0.1826   0.0000  -0.8944   0.4082

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01FZ.html000077500000000000000000000442651201767322700161320ustar00rootroot00000000000000 TG01FZ - SLICOT Library Routine Documentation

TG01FZ

Orthogonal reduction of a descriptor system to a SVD-like coordinate form (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute for the descriptor system (A-lambda E,B,C)
  the unitary transformation matrices Q and Z such that the
  transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is
  in a SVD-like coordinate form with

               ( A11  A12 )             ( Er  0 )
      Q'*A*Z = (          ) ,  Q'*E*Z = (       ) ,
               ( A21  A22 )             (  0  0 )

  where Er is an upper triangular invertible matrix, and ' denotes
  the conjugate transpose. Optionally, the A22 matrix can be further
  reduced to the form

               ( Ar  X )
         A22 = (       ) ,
               (  0  0 )

  with Ar an upper triangular invertible matrix, and X either a full
  or a zero matrix.
  The left and/or right unitary transformations performed
  to reduce E and A22 can be optionally accumulated.
Specification 
      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     .. 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( * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          = 'N':  do not compute Q;
          = 'I':  Q is initialized to the unit matrix, and the
                  unitary matrix Q is returned;
          = 'U':  Q must contain a unitary matrix Q1 on entry,
                  and the product Q1*Q is returned.

  COMPZ   CHARACTER*1
          = 'N':  do not compute Z;
          = 'I':  Z is initialized to the unit matrix, and the
                  unitary matrix Z is returned;
          = 'U':  Z must contain a unitary matrix Z1 on entry,
                  and the product Z1*Z is returned.

  JOBA    CHARACTER*1
          = 'N':  do not reduce A22;
          = 'R':  reduce A22 to a SVD-like upper triangular form.
          = 'T':  reduce A22 to an upper trapezoidal form.
Input/Output Parameters 
  L       (input) INTEGER
          The number of rows of matrices A, B, and E.  L >= 0.

  N       (input) INTEGER
          The number of columns of matrices A, E, and C.  N >= 0.

  M       (input) INTEGER
          The number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The number of rows of matrix C.  P >= 0.

  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the state dynamics matrix A.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix
          is in the form

                        ( A11  *   *  )
               Q'*A*Z = (  *   Ar  X  ) ,
                        (  *   0   0  )

          where A11 is a RANKE-by-RANKE matrix and Ar is a
          RNKA22-by-RNKA22 invertible upper triangular matrix.
          If JOBA = 'R' then A has the above form with X = 0.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) COMPLEX*16 array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the descriptor matrix E.
          On exit, the leading L-by-N part of this array contains
          the transformed matrix Q'*E*Z.

                   ( Er  0 )
          Q'*E*Z = (       ) ,
                   (  0  0 )

          where Er is a RANKE-by-RANKE upper triangular invertible
          matrix.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) COMPLEX*16 array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the input/state matrix B.
          On exit, the leading L-by-M part of this array contains
          the transformed matrix Q'*B.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.

  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix C*Z.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Q       (input/output) COMPLEX*16 array, dimension (LDQ,L)
          If COMPQ = 'N':  Q is not referenced.
          If COMPQ = 'I':  on entry, Q need not be set;
                           on exit, the leading L-by-L part of this
                           array contains the unitary matrix Q,
                           where Q' is the product of Householder
                           transformations which are applied to A,
                           E, and B on the left.
          If COMPQ = 'U':  on entry, the leading L-by-L part of this
                           array must contain a unitary matrix Q1;
                           on exit, the leading L-by-L part of this
                           array contains the unitary matrix Q1*Q.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,        if COMPQ = 'N';
          LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'.

  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)
          If COMPZ = 'N':  Z is not referenced.
          If COMPZ = 'I':  on entry, Z need not be set;
                           on exit, the leading N-by-N part of this
                           array contains the unitary matrix Z,
                           which is the product of Householder
                           transformations applied to A, E, and C
                           on the right.
          If COMPZ = 'U':  on entry, the leading N-by-N part of this
                           array must contain a unitary matrix Z1;
                           on exit, the leading N-by-N part of this
                           array contains the unitary matrix Z1*Z.

  LDZ     INTEGER
          The leading dimension of array Z.
          LDZ >= 1,        if COMPZ = 'N';
          LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.

  RANKE   (output) INTEGER
          The estimated rank of matrix E, and thus also the order
          of the invertible upper triangular submatrix Er.

  RNKA22  (output) INTEGER
          If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of
          matrix A22, and thus also the order of the invertible
          upper triangular submatrix Ar.
          If JOBA = 'N', then RNKA22 is not referenced.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in determining the rank of E
          and of A22. If the user sets TOL > 0, then the given
          value of TOL is used as a lower bound for the
          reciprocal condition numbers of leading submatrices
          of R or R22 in the QR decompositions E * P = Q * R of E
          or A22 * P22 = Q22 * R22 of A22.
          A submatrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = L*N*EPS,  is used instead, where
          EPS is the machine precision (see LAPACK Library routine
          DLAMCH). TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension (N)

  DWORK   DOUBLE PRECISION array, dimension (2*N)

  ZWORK   DOUBLE PRECISION array, dimension (LZWORK)
          On exit, if INFO = 0, ZWORK(1) returns the optimal value
          of LZWORK.

  LZWORK  INTEGER
          The length of the array ZWORK.
          LZWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ).
          For optimal performance, LZWORK should be larger.

          If LZWORK = -1, then a workspace query is assumed;
          the routine only calculates the optimal size of the
          ZWORK array, returns this value as the first entry of
          the ZWORK array, and no error message related to LZWORK
          is issued by XERBLA.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine computes a truncated QR factorization with column
  pivoting of E, in the form

                    ( E11 E12 )
        E * P = Q * (         )
                    (  0  E22 )

  and finds the largest RANKE-by-RANKE leading submatrix E11 whose
  estimated condition number is less than 1/TOL. RANKE defines thus
  the rank of matrix E. Further E22, being negligible, is set to
  zero, and a unitary matrix Y is determined such that

        ( E11 E12 ) = ( Er  0 ) * Y .

  The overal transformation matrix Z results as Z = P * Y' and the
  resulting transformed matrices Q'*A*Z and Q'*E*Z have the form

                       ( Er  0 )                      ( A11  A12 )
      E <- Q'* E * Z = (       ) ,  A <- Q' * A * Z = (          ) ,
                       (  0  0 )                      ( A21  A22 )

  where Er is an upper triangular invertible matrix.
  If JOBA = 'R' the same reduction is performed on A22 to obtain it
  in the form

               ( Ar  0 )
         A22 = (       ) ,
               (  0  0 )

  with Ar an upper triangular invertible matrix.
  If JOBA = 'T' then A22 is row compressed using the QR
  factorization with column pivoting to the form

               ( Ar  X )
         A22 = (       )
               (  0  0 )

  with Ar an upper triangular invertible matrix.

  The transformations are also applied to the rest of system
  matrices

       B <- Q' * B, C <- C * Z.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( L*L*N )  floating point operations.
Further Comments 
  None
Example

Program Text 

*     TG01FZ EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDE = LMAX, LDQ = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*NMAX )
      INTEGER          LZWORK
      PARAMETER        ( LZWORK = MAX( 1, NMAX+PMAX,
     $                   MIN(LMAX,NMAX)+MAX( 3*NMAX-1, MMAX, LMAX ) ) )
*     .. Local Scalars ..
      CHARACTER*1      COMPQ, COMPZ, JOBA
      INTEGER          I, INFO, J, L, M, N, P, RANKE, RNKA22
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          IWORK(NMAX)
      COMPLEX*16       A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 E(LDE,NMAX), Q(LDQ,LMAX), Z(LDZ,NMAX),
     $                 ZWORK(LZWORK)
      DOUBLE PRECISION DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         TG01FZ
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, M, P, TOL
      COMPQ = 'I'
      COMPZ = 'I'
      JOBA = 'R'
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) L
      ELSE
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99988 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99987 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L )
               IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
                  WRITE ( NOUT, FMT = 99986 ) P
               ELSE
                  READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*                 Find the transformed descriptor system
*                 (A-lambda E,B,C).
                  CALL 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 )
*
                  IF ( INFO.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99998 ) INFO
                  ELSE
                     WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22
                     WRITE ( NOUT, FMT = 99997 )
                     DO 10 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10                CONTINUE
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20                CONTINUE
                     WRITE ( NOUT, FMT = 99993 )
                     DO 30 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30                CONTINUE
                     WRITE ( NOUT, FMT = 99992 )
                     DO 40 I = 1, P
                        WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40                CONTINUE
                     WRITE ( NOUT, FMT = 99991 )
                     DO 50 I = 1, L
                        WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L )
   50                CONTINUE
                     WRITE ( NOUT, FMT = 99990 )
                     DO 60 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01FZ EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01FZ = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ')
99995 FORMAT (20(1X,F8.4,SP,F8.4,S,'i '))
99994 FORMAT (' Rank of matrix E   =', I5/
     $        ' Rank of matrix A22 =', I5)
99993 FORMAT (/' The transformed input/state matrix Q''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Z is ')
99991 FORMAT (/' The left transformation matrix Q is ')
99990 FORMAT (/' The right transformation matrix Z is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
TG01FZ EXAMPLE PROGRAM DATA
  4    4     2     2     0.0    
    -1     0     0     3
     0     0     1     2
     1     1     0     4
     0     0     0     0
     1     2     0     0
     0     1     0     1
     3     9     6     3
     0     0     2     0
     1     0
     0     0
     0     1
     1     1
    -1     0     1     0
     0     1    -1     1
Program Results 
 TG01FZ EXAMPLE PROGRAM RESULTS

 Rank of matrix E   =    3
 Rank of matrix A22 =    1

 The transformed state dynamics matrix Q'*A*Z is 
   2.0278 +0.0000i    0.1078 +0.0000i    3.9062 +0.0000i   -2.1571 +0.0000i 
  -0.0980 +0.0000i    0.2544 +0.0000i    1.6053 +0.0000i   -0.1269 +0.0000i 
   0.2713 +0.0000i    0.7760 +0.0000i   -0.3692 +0.0000i   -0.4853 +0.0000i 
   0.0690 +0.0000i   -0.5669 +0.0000i   -2.1974 +0.0000i    0.3086 +0.0000i 

 The transformed descriptor matrix Q'*E*Z is 
  10.1587 +0.0000i    5.8230 +0.0000i    1.3021 +0.0000i    0.0000 +0.0000i 
   0.0000 +0.0000i   -2.4684 +0.0000i   -0.1896 +0.0000i    0.0000 +0.0000i 
   0.0000 +0.0000i    0.0000 +0.0000i    1.0338 +0.0000i    0.0000 +0.0000i 
   0.0000 +0.0000i    0.0000 +0.0000i    0.0000 +0.0000i    0.0000 +0.0000i 

 The transformed input/state matrix Q'*B is 
  -0.2157 +0.0000i   -0.9705 +0.0000i 
   0.3015 +0.0000i    0.9516 +0.0000i 
   0.7595 +0.0000i    0.0991 +0.0000i 
   1.1339 +0.0000i    0.3780 +0.0000i 

 The transformed state/output matrix C*Z is 
   0.3651 +0.0000i   -1.0000 +0.0000i   -0.4472 +0.0000i   -0.8165 +0.0000i 
  -1.0954 +0.0000i    1.0000 +0.0000i   -0.8944 +0.0000i    0.0000 +0.0000i 

 The left transformation matrix Q is 
  -0.2157 +0.0000i   -0.5088 +0.0000i    0.6109 +0.0000i    0.5669 +0.0000i 
  -0.1078 +0.0000i   -0.2544 +0.0000i   -0.7760 +0.0000i    0.5669 +0.0000i 
  -0.9705 +0.0000i    0.1413 +0.0000i   -0.0495 +0.0000i   -0.1890 +0.0000i 
   0.0000 +0.0000i    0.8102 +0.0000i    0.1486 +0.0000i    0.5669 +0.0000i 

 The right transformation matrix Z is 
  -0.3651 +0.0000i    0.0000 +0.0000i    0.4472 +0.0000i    0.8165 +0.0000i 
  -0.9129 +0.0000i    0.0000 +0.0000i    0.0000 +0.0000i   -0.4082 +0.0000i 
   0.0000 +0.0000i   -1.0000 +0.0000i    0.0000 +0.0000i    0.0000 +0.0000i 
  -0.1826 +0.0000i    0.0000 +0.0000i   -0.8944 +0.0000i    0.4082 +0.0000i

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01HD.html000077500000000000000000000566461201767322700161140ustar00rootroot00000000000000 TG01HD - SLICOT Library Routine Documentation

TG01HD

Orthogonal reduction of a descriptor system to the controllability staircase form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal transformation matrices Q and Z which
  reduce the N-th order descriptor system (A-lambda*E,B,C)
  to the form

             ( Ac  *  )             ( Ec  *  )           ( Bc )
    Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,  Q'*B = (    ) ,
             ( 0  Anc )             ( 0  Enc )           ( 0  )

       C*Z = ( Cc Cnc ) ,

  where the NCONT-th order descriptor system (Ac-lambda*Ec,Bc,Cc)
  is a finite and/or infinite controllable. The pencil
  Anc - lambda*Enc is regular of order N-NCONT and contains the
  uncontrollable finite and/or infinite eigenvalues of the pencil
  A-lambda*E.

  For JOBCON = 'C' or 'I', the pencil ( Bc Ec-lambda*Ac ) has full
  row rank NCONT for all finite lambda and is in a staircase form
  with
                  _      _          _        _
                ( E1,0   E1,1  ...  E1,k-1   E1,k  )
                (        _          _        _     )
    ( Bc Ec ) = (  0     E2,1  ...  E2,k-1   E2,k  ) ,  (1)
                (              ...  _        _     )
                (  0       0   ...  Ek,k-1   Ek,k  )

                  _          _        _
                ( A1,1  ...  A1,k-1   A1,k  )
                (            _        _     )
      Ac      = (   0   ...  A2,k-1   A2,k  ) ,         (2)
                (       ...           _     )
                (   0   ...    0      Ak,k  )
        _
  where Ei,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix
                         _
  (with rtau(0) = M) and Ai,i is an rtau(i)-by-rtau(i)
  upper triangular matrix.

  For JOBCON = 'F', the pencil ( Bc Ac-lambda*Ec ) has full
  row rank NCONT for all finite lambda and is in a staircase form
  with
                  _     _          _        _
                ( A1,0  A1,1  ...  A1,k-1   A1,k  )
                (       _          _        _     )
    ( Bc Ac ) = (  0    A2,1  ...  A2,k-1   A2,k  ) ,   (3)
                (             ...  _        _     )
                (  0      0   ...  Ak,k-1   Ak,k  )

                  _          _        _
                ( E1,1  ...  E1,k-1   E1,k  )
                (            _        _     )
      Ec      = (   0   ...  E2,k-1   E2,k  ) ,         (4)
                (       ...           _     )
                (   0   ...    0      Ek,k  )
        _
  where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix
                         _
  (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i)
  upper triangular matrix.

  For JOBCON = 'C', the (N-NCONT)-by-(N-NCONT) regular pencil
  Anc - lambda*Enc has the form

                      ( Ainc - lambda*Einc         *          )
   Anc - lambda*Enc = (                                       ) ,
                      (        0           Afnc - lambda*Efnc )

  where:
    1) the NIUCON-by-NIUCON regular pencil Ainc - lambda*Einc,
       with Ainc upper triangular and nonsingular, contains the
       uncontrollable infinite eigenvalues of A - lambda*E;
    2) the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) regular pencil
       Afnc - lambda*Efnc, with Efnc upper triangular and
       nonsingular, contains the uncontrollable finite
       eigenvalues of A - lambda*E.

  Note: The significance of the two diagonal blocks can be
        interchanged by calling the routine with the
        arguments A and E interchanged. In this case,
        Ainc - lambda*Einc contains the uncontrollable zero
        eigenvalues of A - lambda*E, while Afnc - lambda*Efnc
        contains the uncontrollable nonzero finite and infinite
        eigenvalues of A - lambda*E.

  For JOBCON = 'F', the pencil Anc - lambda*Enc has the form

     Anc - lambda*Enc = Afnc - lambda*Efnc ,

  where the regular pencil Afnc - lambda*Efnc, with Efnc
  upper triangular and nonsingular, contains the uncontrollable
  finite eigenvalues of A - lambda*E.

  For JOBCON = 'I', the pencil Anc - lambda*Enc has the form

     Anc - lambda*Enc = Ainc - lambda*Einc ,

  where the regular pencil Ainc - lambda*Einc, with Ainc
  upper triangular and nonsingular, contains the uncontrollable
  nonzero finite and infinite eigenvalues of A - lambda*E.

  The left and/or right orthogonal transformations Q and Z
  performed to reduce the system matrices can be optionally
  accumulated.

  The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has
  the same transfer-function matrix as the original system
  (A-lambda*E,B,C).
Specification 
      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     .. 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, * )
Arguments

Mode Parameters 

  JOBCON  CHARACTER*1
          = 'C':  separate both finite and infinite uncontrollable
                  eigenvalues;
          = 'F':  separate only finite uncontrollable eigenvalues:
          = 'I':  separate only nonzero finite and infinite
                  uncontrollable eigenvalues.

  COMPQ   CHARACTER*1
          = 'N':  do not compute Q;
          = 'I':  Q is initialized to the unit matrix, and the
                  orthogonal matrix Q is returned;
          = 'U':  Q must contain an orthogonal matrix Q1 on entry,
                  and the product Q1*Q is returned.

  COMPZ   CHARACTER*1
          = 'N':  do not compute Z;
          = 'I':  Z is initialized to the unit matrix, and the
                  orthogonal matrix Z is returned;
          = 'U':  Z must contain an orthogonal matrix Z1 on entry,
                  and the product Z1*Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the descriptor state vector; also the
          order of square matrices A and E, the number of rows of
          matrix B, and the number of columns of matrix C.  N >= 0.

  M       (input) INTEGER
          The dimension of descriptor system input vector; also the
          number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The dimension of descriptor system output vector; also the
          number of rows of matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the N-by-N state matrix A.
          On exit, the leading N-by-N part of this array contains
          the transformed state matrix Q'*A*Z,

                             ( Ac   *  )
                    Q'*A*Z = (         ) ,
                             ( 0   Anc )

          where Ac is NCONT-by-NCONT and Anc is
          (N-NCONT)-by-(N-NCONT).
          If JOBCON = 'F', the matrix ( Bc Ac ) is in the
          controllability staircase form (3).
          If JOBCON = 'C' or 'I', the submatrix Ac is upper
          triangular.
          If JOBCON = 'C', the Anc matrix has the form

                          ( Ainc   *  )
                    Anc = (           ) ,
                          (  0   Afnc )

          where the NIUCON-by-NIUCON matrix Ainc is nonsingular and
          upper triangular.
          If JOBCON = 'I', Anc is nonsingular and upper triangular.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the N-by-N descriptor matrix E.
          On exit, the leading N-by-N part of this array contains
          the transformed descriptor matrix Q'*E*Z,

                             ( Ec   *  )
                    Q'*E*Z = (         ) ,
                             ( 0   Enc )

          where Ec is NCONT-by-NCONT and Enc is
          (N-NCONT)-by-(N-NCONT).
          If JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the
          controllability staircase form (1).
          If JOBCON = 'F', the submatrix Ec is upper triangular.
          If JOBCON = 'C', the Enc matrix has the form

                          ( Einc   *  )
                    Enc = (           ) ,
                          (  0   Efnc )

          where the NIUCON-by-NIUCON matrix Einc is nilpotent
          and the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) matrix Efnc
          is nonsingular and upper triangular.
          If JOBCON = 'F', Enc is nonsingular and upper triangular.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the N-by-M input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed input matrix

                           ( Bc )
                    Q'*B = (    ) ,
                           ( 0  )

           where Bc is NCONT-by-M.
           For JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the
           controllability staircase form (1).
           For JOBCON = 'F', the matrix ( Bc Ac ) is in the
           controllability staircase form (3).

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix C*Z.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          If COMPQ = 'N': Q is not referenced.
          If COMPQ = 'I': on entry, Q need not be set;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix Q,
                          where Q' is the product of transformations
                          which are applied to A, E, and B on
                          the left.
          If COMPQ = 'U': on entry, the leading N-by-N part of this
                          array must contain an orthogonal matrix
                          Qc;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix
                          Qc*Q.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,        if COMPQ = 'N';
          LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          If COMPZ = 'N': Z is not referenced.
          If COMPZ = 'I': on entry, Z need not be set;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix Z,
                          which is the product of transformations
                          applied to A, E, and C on the right.
          If COMPZ = 'U': on entry, the leading N-by-N part of this
                          array must contain an orthogonal matrix
                          Zc;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix
                          Zc*Z.

  LDZ     INTEGER
          The leading dimension of array Z.
          LDZ >= 1,        if COMPZ = 'N';
          LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.

  NCONT   (output) INTEGER
          The order of the reduced matrices Ac and Ec, and the
          number of rows of reduced matrix Bc; also the order of
          the controllable part of the pair (A-lambda*E,B).

  NIUCON  (output) INTEGER
          For JOBCON = 'C', the order of the reduced matrices
          Ainc and Einc; also the number of uncontrollable
          infinite eigenvalues of the pencil A - lambda*E.
          For JOBCON = 'F' or 'I', NIUCON has no significance
          and is set to zero.

  NRBLCK  (output) INTEGER
          For JOBCON = 'C' or 'I', the number k, of full row rank
                 _
          blocks Ei,i in the staircase form of the pencil
          (Bc Ec-lambda*Ac) (see (1) and (2)).
          For JOBCON = 'F', the number k, of full row rank blocks
          _
          Ai,i in the staircase form of the pencil (Bc Ac-lambda*Ec)
          (see (3) and (4)).

  RTAU    (output) INTEGER array, dimension (N)
          RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of
                                  _         _
          the full row rank block Ei,i-1 or Ai,i-1 in the staircase
          form (1) or (3) for JOBCON = 'C' or 'I', or
          for JOBCON = 'F', respectively.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determinations when
          transforming (A-lambda*E, B). If the user sets TOL > 0,
          then the given value of TOL is used as a lower bound for
          reciprocal condition numbers in rank determinations; a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
          is the machine precision (see LAPACK Library routine
          DLAMCH).  TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension MAX(N,2*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The subroutine is based on the reduction algorithms of [1].
References 
  [1] A. Varga
      Computation of Irreducible Generalized State-Space
      Realizations.
      Kybernetika, vol. 26, pp. 89-106, 1990.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( N**3 )  floating point operations.
Further Comments 
  If the system matrices A, E and B are badly scaled, it is
  generally recommendable to scale them with the SLICOT routine
  TG01AD, before calling TG01HD.
Example

Program Text 

*     TG01HD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = PMAX,
     $                   LDE = LMAX, LDQ = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, NMAX, 2*MMAX ) )
*     .. Local Scalars ..
      CHARACTER*1      COMPQ, COMPZ, JOBCO
      INTEGER          I, INFO, J, M, N, NCONT, NIUCON, NRBLCK, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          IWORK(MMAX), RTAU(NMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01HD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBCO
      COMPQ = 'I'
      COMPZ = 'I'
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99987 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99986 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed descriptor system (A-lambda E,B,C).
               CALL TG01HD( JOBCO, 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) NCONT, NIUCON
                  WRITE ( NOUT, FMT = 99985 )
                  WRITE ( NOUT, FMT = 99984 ) ( RTAU(I), I = 1,NRBLCK )
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 30 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 40 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 50 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N )
   50             CONTINUE
                  WRITE ( NOUT, FMT = 99990 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01HD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01HD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Dimension of controllable part   =', I5/
     $        ' Number of uncontrollable infinite eigenvalues =', I5)
99993 FORMAT (/' The transformed input/state matrix Q''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Z is ')
99991 FORMAT (/' The left transformation matrix Q is ')
99990 FORMAT (/' The right transformation matrix Z is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
99985 FORMAT (/' The staircase form row dimensions are ' )
99984 FORMAT (10I5)
      END
Program Data 
TG01HD EXAMPLE PROGRAM DATA
  7    3     2     0.0    C
     2     0     2     0    -1     3     1
     0     1     0     0     1     0     0
     0     0     0     1     0     0     1
     0     0     2     0    -1     3     1
     0     0     0     1     0     0     1
     0     1     0     0     1     0     0
     0     0     0     1     0     0     1
     0     0     1     0     0     0     0
     0     0     0     0     0     1     0
     0     0     0     0     0     0     1
     0     0     0     0     0     0     1
     0     0     0     1     0     0     0
     0     0     1     0    -1     0     0
     1     3     0     2     0     0     0
     2     1     0
     0     0     0
     0     0     0
     0     0     0
     0     0     0
     0     0     0
     1     2     3
     1     0     0     1     0     0     1
     0    -1     1     0    -1     1     0
Program Results 
 TG01HD EXAMPLE PROGRAM RESULTS

 Dimension of controllable part   =    3
 Number of uncontrollable infinite eigenvalues =    1

 The staircase form row dimensions are 
    2    1

 The transformed state dynamics matrix Q'*A*Z is 
   0.0000   0.0000   0.0000   0.0000  -1.2627   0.4334   0.4666
   0.0000   2.0000   0.0000  -3.7417  -0.8520   0.2924  -0.4342
   0.0000   0.0000   1.7862   0.3780  -0.2651  -0.7723   0.0000
   0.0000   0.0000   0.0000   3.7417   0.8520  -0.2924   0.4342
   0.0000   0.0000   0.0000   0.0000  -1.5540   0.5334   0.5742
   0.0000   0.0000   0.0000   0.0000  -0.6533   0.2242   0.2414
   0.0000   0.0000   0.0000   0.0000  -0.5892   0.2022   0.2177

 The transformed descriptor matrix Q'*E*Z is 
  -1.8325   1.0000   2.3752   0.0000  -0.8214   0.2819   1.8016
   0.4887   0.0000   0.3770  -0.5345   0.1874   0.5461   0.0000
  -0.1728   0.0000  -0.1333  -1.1339   0.1325   0.3861   0.0000
   0.0000   0.0000   0.0000   0.0000   0.8520  -0.2924   0.4342
   0.0000   0.0000   0.0000   0.0000  -1.0260  -0.1496   0.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   1.1937   0.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000

 The transformed input/state matrix Q'*B is 
   1.0000   2.0000   3.0000
   2.0000   1.0000   0.0000
   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000

 The transformed state/output matrix C*Z is 
   0.0000   1.0000   0.0000   0.0000  -1.2627   0.4334   0.4666
   0.3665   0.0000  -0.9803  -1.6036   0.1874   0.5461   0.0000

 The left transformation matrix Q is 
   0.0000   1.0000   0.0000   0.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   0.7071   0.0000   0.2740  -0.6519   0.0000
   0.0000   0.0000   0.0000   0.0000   0.8304   0.3491  -0.4342
   0.0000   0.0000   0.0000  -1.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   0.4003   0.1683   0.9008
   0.0000   0.0000   0.7071   0.0000  -0.2740   0.6519   0.0000
   1.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000

 The right transformation matrix Z is 
   0.0000   1.0000   0.0000   0.0000   0.0000   0.0000   0.0000
  -0.6108   0.0000   0.7917   0.0000   0.0000   0.0000   0.0000
   0.4887   0.0000   0.3770  -0.5345   0.1874   0.5461   0.0000
   0.0000   0.0000   0.0000   0.0000  -0.4107   0.1410   0.9008
   0.6108   0.0000   0.4713   0.2673  -0.1874  -0.5461   0.0000
  -0.1222   0.0000  -0.0943  -0.8018  -0.1874  -0.5461   0.0000
   0.0000   0.0000   0.0000   0.0000  -0.8520   0.2924  -0.4342

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01HX.html000077500000000000000000000304011201767322700161150ustar00rootroot00000000000000 TG01HX - SLICOT Library Routine Documentation

TG01HX

Orthogonal reduction of a descriptor system to a system with the same transfer-function matrix and with no uncontrollable finite eigenvalues

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  Given the descriptor system (A-lambda*E,B,C) with the system
  matrices A, E and B of the form

         ( A1 X1 )        ( E1 Y1 )        ( B1 )
     A = (       ) ,  E = (       ) ,  B = (    ) ,
         ( 0  X2 )        ( 0  Y2 )        ( 0  )

  where
       - B is an L-by-M matrix, with B1 an N1-by-M  submatrix
       - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix
       - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix
           with LBE nonzero sub-diagonals,
  this routine reduces the pair (A1-lambda*E1,B1) to the form

  Qc'*[A1-lambda*E1 B1]*diag(Zc,I) =

                           ( Bc Ac-lambda*Ec      *         )
                           (                                ) ,
                           ( 0     0         Anc-lambda*Enc )

  where:
  1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for
     all finite lambda and is in a staircase form with
                        _      _          _        _
                      ( A1,0   A1,1  ...  A1,k-1   A1,k  )
                      (        _          _        _     )
          ( Bc Ac ) = (  0     A2,1  ...  A2,k-1   A2,k  ) ,  (1)
                      (              ...  _        _     )
                      (  0       0   ...  Ak,k-1   Ak,k  )

                        _          _        _
                      ( E1,1  ...  E1,k-1   E1,k  )
                      (            _        _     )
            Ec      = (   0   ...  E2,k-1   E2,k  ) ,         (2)
                      (       ...           _     )
                      (   0   ...    0      Ek,k  )
            _
      where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank
                                    _
      matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i)
      upper triangular matrix.

   2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc
      upper triangular; this pencil contains the uncontrollable
      finite eigenvalues of the pencil (A1-lambda*E1).

  The transformations are applied to the whole matrices A, E, B
  and C. The left and/or right orthogonal transformations Qc and Zc
  performed to reduce the pencil S(lambda) can be optionally
  accumulated in the matrices Q and Z, respectivelly.

  The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no
  uncontrollable finite eigenvalues and has the same
  transfer-function matrix as the original system (A-lambda*E,B,C).
Specification 
      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     .. 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, * )
Arguments

Mode Parameters 

  COMPQ   CHARACTER*1
          = 'N':  do not compute Q;
          = 'I':  Q is initialized to the unit matrix, and the
                  orthogonal matrix Q is returned;
          = 'U':  Q must contain an orthogonal matrix Q1 on entry,
                  and the product Q1*Q is returned.

  COMPZ   CHARACTER*1
          = 'N':  do not compute Z;
          = 'I':  Z is initialized to the unit matrix, and the
                  orthogonal matrix Z is returned;
          = 'U':  Z must contain an orthogonal matrix Z1 on entry,
                  and the product Z1*Z is returned.
Input/Output Parameters 
  L       (input) INTEGER
          The number of descriptor state equations; also the number
          of rows of matrices A, E and B.  L >= 0.

  N       (input) INTEGER
          The dimension of the descriptor state vector; also the
          number of columns of matrices A, E and C.  N >= 0.

  M       (input) INTEGER
          The dimension of descriptor system input vector; also the
          number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The dimension of descriptor system output; also the
          number of rows of matrix C.  P >= 0.

  N1      (input) INTEGER
          The order of subsystem (A1-lambda*E1,B1,C1) to be reduced.
          MIN(L,N) >= N1 >= 0.

  LBE     (input) INTEGER
          The number of nonzero sub-diagonals of submatrix E1.
          MAX(0,N1-1) >= LBE >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading L-by-N part of this array must
          contain the L-by-N state matrix A in the partitioned
          form
                   ( A1 X1 )
               A = (       ) ,
                   ( 0  X2 )

          where A1 is N1-by-N1.
          On exit, the leading L-by-N part of this array contains
          the transformed state matrix,

                               ( Ac  *   * )
                    Qc'*A*Zc = ( 0  Anc  * ) ,
                               ( 0   0   * )

          where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR).
          The matrix ( Bc Ac ) is in the controlability
          staircase form (1).

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,L).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading L-by-N part of this array must
          contain the L-by-N descriptor matrix E in the partitioned
          form
                   ( E1 Y1 )
               E = (       ) ,
                   ( 0  Y2 )

          where E1 is N1-by-N1 matrix with LBE nonzero
          sub-diagonals.
          On exit, the leading L-by-N part of this array contains
          the transformed descriptor matrix

                               ( Ec  *   * )
                    Qc'*E*Zc = ( 0  Enc  * ) ,
                               ( 0   0   * )

          where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR).
          Both Ec and Enc are upper triangular and Enc is
          nonsingular.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,L).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading L-by-M part of this array must
          contain the L-by-M input matrix B in the partitioned
          form
                   ( B1 )
               B = (    ) ,
                   ( 0  )

          where B1 is N1-by-M.
          On exit, the leading L-by-M part of this array contains
          the transformed input matrix

                            ( Bc )
                    Qc'*B = (    ) ,
                            ( 0  )

          where Bc is NR-by-M.
          The matrix ( Bc Ac ) is in the controlability
          staircase form (1).

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,L).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix C*Zc.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,L)
          If COMPQ = 'N': Q is not referenced.
          If COMPQ = 'I': on entry, Q need not be set;
                          on exit, the leading L-by-L part of this
                          array contains the orthogonal matrix Q,
                          where Q' is the product of transformations
                          which are applied to A, E, and B on
                          the left.
          If COMPQ = 'U': on entry, the leading L-by-L part of this
                          array must contain an orthogonal matrix
                          Qc;
                          on exit, the leading L-by-L part of this
                          array contains the orthogonal matrix
                          Qc*Q.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,        if COMPQ = 'N';
          LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          If COMPZ = 'N': Z is not referenced.
          If COMPZ = 'I': on entry, Z need not be set;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix Z,
                          which is the product of transformations
                          applied to A, E, and C on the right.
          If COMPZ = 'U': on entry, the leading N-by-N part of this
                          array must contain an orthogonal matrix
                          Zc;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix
                          Zc*Z.

  LDZ     INTEGER
          The leading dimension of array Z.
          LDZ >= 1,        if COMPZ = 'N';
          LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.

  NR      (output) INTEGER
          The order of the reduced matrices Ac and Ec, and the
          number of rows of the reduced matrix Bc; also the order of
          the controllable part of the pair (B, A-lambda*E).

  NRBLCK  (output) INTEGER                      _
          The number k, of full row rank blocks Ai,i in the
          staircase form of the pencil (Bc Ac-lambda*Ec) (see (1)
          and (2)).

  RTAU    (output) INTEGER array, dimension (N1)
          RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of
                                  _
          the full row rank block Ai,i-1 in the staircase form (1).
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determinations when
          transforming (A-lambda*E, B). If the user sets TOL > 0,
          then the given value of TOL is used as a lower bound for
          reciprocal condition numbers in rank determinations; a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = L*N*EPS,  is used instead, where
          EPS is the machine precision (see LAPACK Library routine
          DLAMCH).  TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension (M)

  DWORK   DOUBLE PRECISION array, dimension MAX(N,L,2*M)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The subroutine is based on the reduction algorithm of [1].
References 
  [1] A. Varga
      Computation of Irreducible Generalized State-Space
      Realizations.
      Kybernetika, vol. 26, pp. 89-106, 1990.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( N*N1**2 )  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None
Return to Supporting Routines index slicot-5.0+20101122/doc/TG01ID.html000077500000000000000000000601001201767322700160710ustar00rootroot00000000000000 TG01ID - SLICOT Library Routine Documentation

TG01ID

Orthogonal reduction of a descriptor system to the observability staircase form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To compute orthogonal transformation matrices Q and Z which
  reduce the N-th order descriptor system (A-lambda*E,B,C)
  to the form

             ( Ano  * )             ( Eno  * )           ( Bno )
    Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,  Q'*B = (     ) ,
             ( 0   Ao )             ( 0   Eo )           ( Bo  )

       C*Z = ( 0   Co ) ,

  where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co)
  is a finite and/or infinite observable. The pencil
  Ano - lambda*Eno is regular of order N-NOBSV and contains the
  unobservable finite and/or infinite eigenvalues of the pencil
  A-lambda*E.

  For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full
                                      (      Co      )
  column rank NOBSV for all finite lambda and is in a staircase form
  with
                  _      _            _      _
                ( Ek,k   Ek,k-1   ... Ek,2   Ek,1   )
                ( _      _            _      _      )
    ( Eo ) =    ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) ,  (1)
    ( Co )      (     ...         ... _      _      )
                (  0       0      ... E1,2   E1,1   )
                (                            _      )
                (  0       0      ... 0      E0,1   )
                  _          _      _
                ( Ak,k  ...  Ak,2   Ak,1 )
                (       ...  _      _    )
      Ao      = (   0   ...  A2,2   A2,1 ) ,             (2)
                (                   _    )
                (   0   ...    0    A1,1 )
        _
  where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix
                         _
  (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i)
  upper triangular matrix.

  For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full
                               (      Co      )
  column rank NOBSV for all finite lambda and is in a staircase form
  with
                  _      _            _      _
                ( Ak,k   Ak,k-1   ... Ak,2   Ak,1   )
                ( _      _            _      _      )
    ( Ao ) =    ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) ,  (3)
    ( Co )      (     ...         ... _      _      )
                (  0       0      ... A1,2   A1,1   )
                (                            _      )
                (  0       0      ... 0      A0,1   )
                  _          _      _
                ( Ek,k  ...  Ek,2   Ek,1 )
                (       ...  _      _    )
      Eo      = (   0   ...  E2,2   E2,1 ) ,             (4)
                (                   _    )
                (   0   ...    0    E1,1 )
        _
  where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix
                         _
  (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i)
  upper triangular matrix.

  For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil
  Ano - lambda*Eno has the form

                      ( Afno - lambda*Efno         *          )
   Ano - lambda*Eno = (                                       ) ,
                      (        0           Aino - lambda*Eino )

  where:
    1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino,
       with Aino upper triangular and nonsingular, contains the
       unobservable infinite eigenvalues of A - lambda*E;
    2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil
       Afno - lambda*Efno, with Efno upper triangular and
       nonsingular, contains the unobservable finite
       eigenvalues of A - lambda*E.

  Note: The significance of the two diagonal blocks can be
        interchanged by calling the routine with the
        arguments A and E interchanged. In this case,
        Aino - lambda*Eino contains the unobservable zero
        eigenvalues of A - lambda*E, while Afno - lambda*Efno
        contains the unobservable nonzero finite and infinite
        eigenvalues of A - lambda*E.

  For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form

     Ano - lambda*Eno = Afno - lambda*Efno ,

  where the regular pencil Afno - lambda*Efno, with Efno
  upper triangular and nonsingular, contains the unobservable
  finite eigenvalues of A - lambda*E.

  For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form

     Ano - lambda*Eno = Aino - lambda*Eino ,

  where the regular pencil Aino - lambda*Eino, with Aino
  upper triangular and nonsingular, contains the unobservable
  nonzero finite and infinite eigenvalues of A - lambda*E.

  The left and/or right orthogonal transformations Q and Z
  performed to reduce the system matrices can be optionally
  accumulated.

  The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has
  the same transfer-function matrix as the original system
  (A-lambda*E,B,C).
Specification 
      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     .. 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, * )
Arguments

Mode Parameters 

  JOBOBS   CHARACTER*1
          = 'O':  separate both finite and infinite unobservable
                  eigenvalues;
          = 'F':  separate only finite unobservable eigenvalues;
          = 'I':  separate only nonzero finite and infinite
                  unobservable eigenvalues.

  COMPQ   CHARACTER*1
          = 'N':  do not compute Q;
          = 'I':  Q is initialized to the unit matrix, and the
                  orthogonal matrix Q is returned;
          = 'U':  Q must contain an orthogonal matrix Q1 on entry,
                  and the product Q1*Q is returned.

  COMPZ   CHARACTER*1
          = 'N':  do not compute Z;
          = 'I':  Z is initialized to the unit matrix, and the
                  orthogonal matrix Z is returned;
          = 'U':  Z must contain an orthogonal matrix Z1 on entry,
                  and the product Z1*Z is returned.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the descriptor state vector; also the
          order of square matrices A and E, the number of rows of
          matrix B, and the number of columns of matrix C.  N >= 0.

  M       (input) INTEGER
          The dimension of descriptor system input vector; also the
          number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The dimension of descriptor system output vector; also the
          number of rows of matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the N-by-N state matrix A.
          On exit, the leading N-by-N part of this array contains
          the transformed state matrix Q'*A*Z,

                             ( Ano  *  )
                    Q'*A*Z = (         ) ,
                             ( 0    Ao )

          where Ao is NOBSV-by-NOBSV and Ano is
          (N-NOBSV)-by-(N-NOBSV).
          If JOBOBS = 'F', the matrix ( Ao ) is in the observability
                                      ( Co )
          staircase form (3).
          If JOBOBS = 'O' or 'I', the submatrix Ao is upper
          triangular.
          If JOBOBS = 'O', the submatrix Ano has the form

                          ( Afno   *  )
                    Ano = (           ) ,
                          (  0   Aino )

          where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and
          upper triangular.
          If JOBOBS = 'I', Ano is nonsingular and upper triangular.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the N-by-N descriptor matrix E.
          On exit, the leading N-by-N part of this array contains
          the transformed state matrix Q'*E*Z,

                             ( Eno  *  )
                    Q'*E*Z = (         ) ,
                             ( 0    Eo )

          where Eo is NOBSV-by-NOBSV and Eno is
          (N-NOBSV)-by-(N-NOBSV).
          If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the
                                             ( Co )
          observability staircase form (1).
          If JOBOBS = 'F', the submatrix Eo is upper triangular.
          If JOBOBS = 'O', the Eno matrix has the form

                          ( Efno   *  )
                    Eno = (           ) ,
                          (  0   Eino )

          where the NIUOBS-by-NIUOBS matrix Eino is nilpotent
          and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno
          is nonsingular and upper triangular.
          If JOBOBS = 'F', Eno is nonsingular and upper triangular.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension
          (LDB,MAX(M,P))
          On entry, the leading N-by-M part of this array must
          contain the N-by-M input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed input matrix Q'*B.

  LDB     INTEGER
          The leading dimension of array B.
          LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0.

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the state/output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed matrix

                  C*Z = (  0   Co ) ,

          where Co is P-by-NOBSV.
          If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the
                                             ( Co )
          observability staircase form (1).
          If JOBOBS = 'F', the matrix ( Ao ) is in the observability
                                      ( Co )
          staircase form (3).

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,M,P).

  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
          If COMPQ = 'N': Q is not referenced.
          If COMPQ = 'I': on entry, Q need not be set;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix Q,
                          where Q' is the product of transformations
                          which are applied to A, E, and B on
                          the left.
          If COMPQ = 'U': on entry, the leading N-by-N part of this
                          array must contain an orthogonal matrix
                          Qc;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix
                          Qc*Q.

  LDQ     INTEGER
          The leading dimension of array Q.
          LDQ >= 1,        if COMPQ = 'N';
          LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'.

  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
          If COMPZ = 'N': Z is not referenced.
          If COMPZ = 'I': on entry, Z need not be set;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix Z,
                          which is the product of transformations
                          applied to A, E, and C on the right.
          If COMPZ = 'U': on entry, the leading N-by-N part of this
                          array must contain an orthogonal matrix
                          Zc;
                          on exit, the leading N-by-N part of this
                          array contains the orthogonal matrix
                          Zc*Z.

  LDZ     INTEGER
          The leading dimension of array Z.
          LDZ >= 1,        if COMPZ = 'N';
          LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.

  NOBSV   (output) INTEGER
          The order of the reduced matrices Ao and Eo, and the
          number of columns of reduced matrix Co; also the order of
          observable part of the pair (C, A-lambda*E).

  NIUOBS  (output) INTEGER
          For JOBOBS = 'O', the order of the reduced matrices
          Aino and Eino; also the number of unobservable
          infinite eigenvalues of the pencil A - lambda*E.
          For JOBOBS = 'F' or 'I', NIUOBS has no significance
          and is set to zero.

  NLBLCK  (output) INTEGER
          For JOBOBS = 'O' or 'I', the number k, of full column rank
                 _
          blocks Ei-1,i in the staircase form of the pencil
          (Eo-lambda*Ao) (see (1) and (2)).
          (    Co      )
          For JOBOBS = 'F', the number k, of full column rank blocks
          _
          Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo)
                                                     (     Co     )
          (see (3) and (4)).

  CTAU    (output) INTEGER array, dimension (N)
          CTAU(i), for i = 1, ..., NLBLCK, is the column dimension
                                        _         _
          of the full column rank block Ei-1,i or Ai-1,i in the
          staircase form (1) or (3) for JOBOBS = 'O' or 'I', or
          for JOBOBS = 'F', respectively.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determinations when
          transforming (A'-lambda*E',C')'. If the user sets TOL > 0,
          then the given value of TOL is used as a lower bound for
          reciprocal condition numbers in rank determinations; a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
          is the machine precision (see LAPACK Library routine
          DLAMCH).  TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension (P)

  DWORK   DOUBLE PRECISION array, dimension MAX(N,2*P)
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The subroutine is based on the dual of the reduction
  algorithms of [1].
References 
  [1] A. Varga
      Computation of Irreducible Generalized State-Space
      Realizations.
      Kybernetika, vol. 26, pp. 89-106, 1990.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( N**3 )  floating point operations.
Further Comments 
  If the system matrices A, E and C are badly scaled, it is
  generally recommendable to scale them with the SLICOT routine
  TG01AD, before calling TG01ID.
Example

Program Text 

*     TG01ID EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, MMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MPMX
      PARAMETER        ( MPMX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDE, LDQ, LDZ
      PARAMETER        ( LDA = LMAX, LDB = LMAX, LDC = MAX(MMAX,PMAX),
     $                   LDE = LMAX, LDQ = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 1, NMAX, 2*PMAX ) )
*     .. Local Scalars ..
      CHARACTER*1      COMPQ, COMPZ, JOBOBS
      INTEGER          I, INFO, J, M, N, NOBSV, NIUOBS, NLBLCK, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          IWORK(MMAX), CTAU(NMAX)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MPMX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX),
     $                 Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01ID
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBOBS
      COMPQ = 'I'
      COMPZ = 'I'
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99987 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99986 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed descriptor system (A-lambda E,B,C).
               CALL 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 )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) NOBSV, NIUOBS
                  WRITE ( NOUT, FMT = 99985 )
                  WRITE ( NOUT, FMT = 99984 ) ( CTAU(I), I = 1,NLBLCK )
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 30 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 40 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 50 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N )
   50             CONTINUE
                  WRITE ( NOUT, FMT = 99990 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01ID EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01ID = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Dimension of observable part   =', I5/
     $        ' Number of unobservable infinite eigenvalues =', I5)
99993 FORMAT (/' The transformed input/state matrix Q''*B is ')
99992 FORMAT (/' The transformed state/output matrix C*Z is ')
99991 FORMAT (/' The left transformation matrix Q is ')
99990 FORMAT (/' The right transformation matrix Z is ')
99989 FORMAT (/' L is out of range.',/' L = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
99985 FORMAT (/' The staircase form column dimensions are ' )
99984 FORMAT (10I5)
      END
Program Data 
TG01ID EXAMPLE PROGRAM DATA
  7    2     3     0.0    O
     2     0     0     0     0     0     0
     0     1     0     0     0     1     0
     2     0     0     2     0     0     0
     0     0     1     0     1     0     1
    -1     1     0    -1     0     1     0
     3     0     0     3     0     0     0
     1     0     1     1     1     0     1
     0     0     0     0     0     0     1
     0     0     0     0     0     0     3
     1     0     0     0     0     1     0
     0     0     0     0     1     0     2
     0     0     0     0     0    -1     0
     0     1     0     0     0     0     0
     0     0     1     1     0     0     0
     1     0
     0    -1
     0     1
     1     0
     0    -1
     0     1
     1     0
     2     0     0     0     0     0     1
     1     0     0     0     0     0     2
     0     0     0     0     0     0     3
Program Results 
 TG01ID EXAMPLE PROGRAM RESULTS

 Dimension of observable part   =    3
 Number of unobservable infinite eigenvalues =    1

 The staircase form column dimensions are 
    2    1

 The transformed state dynamics matrix Q'*A*Z is 
   0.2177   0.2414   0.5742   0.4342   0.0000  -0.4342   0.4666
   0.2022   0.2242   0.5334  -0.2924  -0.7723   0.2924   0.4334
  -0.5892  -0.6533  -1.5540   0.8520  -0.2651  -0.8520  -1.2627
   0.0000   0.0000   0.0000   3.7417   0.3780  -3.7417   0.0000
   0.0000   0.0000   0.0000   0.0000   1.7862   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   2.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000

 The transformed descriptor matrix Q'*E*Z is 
   1.0000   0.0000   0.0000   0.4342   0.0000   0.0000   1.8016
   0.0000   1.1937  -0.1496  -0.2924   0.3861   0.5461   0.2819
   0.0000   0.0000  -1.0260   0.8520   0.1325   0.1874  -0.8214
   0.0000   0.0000   0.0000   0.0000  -1.1339  -0.5345   0.0000
   0.0000   0.0000   0.0000   0.0000  -0.1333   0.3770   2.3752
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000
   0.0000   0.0000   0.0000   0.0000  -0.1728   0.4887  -1.8325

 The transformed input/state matrix Q'*B is 
   0.4666   0.0000
   0.4334   0.5461
  -1.2627   0.1874
   0.0000  -1.6036
   0.0000  -0.9803
   1.0000   0.0000
   0.0000   0.3665

 The transformed state/output matrix C*Z is 
   0.0000   0.0000   0.0000   0.0000   0.0000   2.0000   1.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000   2.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   3.0000

 The left transformation matrix Q is 
   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   0.7917   0.0000  -0.6108
   0.0000   0.5461   0.1874  -0.5345   0.3770   0.0000   0.4887
   0.9008   0.1410  -0.4107   0.0000   0.0000   0.0000   0.0000
   0.0000  -0.5461  -0.1874   0.2673   0.4713   0.0000   0.6108
   0.0000  -0.5461  -0.1874  -0.8018  -0.0943   0.0000  -0.1222
  -0.4342   0.2924  -0.8520   0.0000   0.0000   0.0000   0.0000

 The right transformation matrix Z is 
   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000   0.0000
   0.0000  -0.6519   0.2740   0.0000   0.7071   0.0000   0.0000
  -0.4342   0.3491   0.8304   0.0000   0.0000   0.0000   0.0000
   0.0000   0.0000   0.0000  -1.0000   0.0000   0.0000   0.0000
   0.9008   0.1683   0.4003   0.0000   0.0000   0.0000   0.0000
   0.0000   0.6519  -0.2740   0.0000   0.7071   0.0000   0.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01JD.html000077500000000000000000000455661201767322700161150ustar00rootroot00000000000000 TG01JD - SLICOT Library Routine Documentation

TG01JD

Irreducible descriptor representation

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To find a reduced (controllable, observable, or irreducible)
  descriptor representation (Ar-lambda*Er,Br,Cr) for an original
  descriptor representation (A-lambda*E,B,C).
  The pencil Ar-lambda*Er is in an upper block Hessenberg form, with
  either Ar or Er upper triangular.
Specification 
      SUBROUTINE TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, NR, INFRED, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
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,*)
Arguments

Mode Parameters 

  JOB     CHARACTER*1
          Indicates whether the user wishes to remove the
          uncontrollable and/or unobservable parts as follows:
          = 'I':  Remove both the uncontrollable and unobservable
                  parts to get an irreducible descriptor
                  representation;
          = 'C':  Remove the uncontrollable part only to get a
                  controllable descriptor representation;
          = 'O':  Remove the unobservable part only to get an
                  observable descriptor representation.

  SYSTYP  CHARACTER*1
          Indicates the type of descriptor system algorithm
          to be applied according to the assumed
          transfer-function matrix as follows:
          = 'R':  Rational transfer-function matrix;
          = 'S':  Proper (standard) transfer-function matrix;
          = 'P':  Polynomial transfer-function matrix.

  EQUIL   CHARACTER*1
          Specifies whether the user wishes to preliminarily scale
          the system (A-lambda*E,B,C) as follows:
          = 'S':  Perform scaling;
          = 'N':  Do not perform scaling.
Input/Output Parameters 
  N       (input) INTEGER
          The dimension of the descriptor state vector; also the
          order of square matrices A and E, the number of rows of
          matrix B, and the number of columns of matrix C.  N >= 0.

  M       (input) INTEGER
          The dimension of descriptor system input vector; also the
          number of columns of matrix B.  M >= 0.

  P       (input) INTEGER
          The dimension of descriptor system output vector; also the
          number of rows of matrix C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state matrix A.
          On exit, the leading NR-by-NR part of this array contains
          the reduced order state matrix Ar of an irreducible,
          controllable, or observable realization for the original
          system, depending on the value of JOB, JOB = 'I',
          JOB = 'C', or JOB = 'O', respectively.
          The matrix Ar is upper triangular if SYSTYP = 'R' or 'P'.
          If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar]
          is in a controllable staircase form (see TG01HD).
          If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar )
                                                           ( Cr )
          is in an observable staircase form (see TG01HD).
          The block structure of staircase forms is contained
          in the leading INFRED(7) elements of IWORK.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the original descriptor matrix E.
          On exit, the leading NR-by-NR part of this array contains
          the reduced order descriptor matrix Er of an irreducible,
          controllable, or observable realization for the original
          system, depending on the value of JOB, JOB = 'I',
          JOB = 'C', or JOB = 'O', respectively.
          The resulting Er has INFRED(6) nonzero sub-diagonals.
          If at least for one k = 1,...,4, INFRED(k) >= 0, then the
          resulting Er is structured being either upper triangular
          or block Hessenberg, in accordance to the last
          performed order reduction phase (see METHOD).
          The block structure of staircase forms is contained
          in the leading INFRED(7) elements of IWORK.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M),
          if JOB = 'C', or (LDB,MAX(M,P)), otherwise.
          On entry, the leading N-by-M part of this array must
          contain the original input matrix B; if JOB = 'I',
          or JOB = 'O', the remainder of the leading N-by-MAX(M,P)
          part is used as internal workspace.
          On exit, the leading NR-by-M part of this array contains
          the reduced input matrix Br of an irreducible,
          controllable, or observable realization for the original
          system, depending on the value of JOB, JOB = 'I',
          JOB = 'C', or JOB = 'O', respectively.
          If JOB = 'C', only the first IWORK(1) rows of B are
          nonzero.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the original output matrix C; if JOB = 'I',
          or JOB = 'O', the remainder of the leading MAX(M,P)-by-N
          part is used as internal workspace.
          On exit, the leading P-by-NR part of this array contains
          the transformed state/output matrix Cr of an irreducible,
          controllable, or observable realization for the original
          system, depending on the value of JOB, JOB = 'I',
          JOB = 'C', or JOB = 'O', respectively.
          If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns
          (in the first NR columns) of C are nonzero.

  LDC     INTEGER
          The leading dimension of array C.
          LDC >= MAX(1,M,P) if N > 0.
          LDC >= 1          if N = 0.

  NR      (output) INTEGER
          The order of the reduced descriptor representation
          (Ar-lambda*Er,Br,Cr) of an irreducible, controllable,
          or observable realization for the original system,
          depending on JOB = 'I', JOB = 'C', or JOB = 'O',
          respectively.

  INFRED  (output) INTEGER array, dimension 7
          This array contains information on performed reduction
          and on structure of resulting system matrices as follows:
          INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction
                         (see METHOD) has been performed. In this
                         case, INFRED(k) is the achieved order
                         reduction in Phase k.
          INFRED(k) < 0  (k = 1, 2, 3, or 4) if Phase k was not
                         performed.
          INFRED(5)  -   the number of nonzero sub-diagonals of A.
          INFRED(6)  -   the number of nonzero sub-diagonals of E.
          INFRED(7)  -   the number of blocks in the resulting
                         staircase form at last performed reduction
                         phase. The block dimensions are contained
                         in the first INFRED(7) elements of IWORK.
Tolerances 
  TOL     DOUBLE PRECISION
          The tolerance to be used in rank determinations when
          transforming (A-lambda*E,B,C). If the user sets TOL > 0,
          then the given value of TOL is used as a lower bound for
          reciprocal condition numbers in rank determinations; a
          (sub)matrix whose estimated condition number is less than
          1/TOL is considered to be of full rank.  If the user sets
          TOL <= 0, then an implicitly computed, default tolerance,
          defined by  TOLDEF = N*N*EPS,  is used instead, where
          EPS is the machine precision (see LAPACK Library routine
          DLAMCH).  TOL < 1.
Workspace 
  IWORK   INTEGER array, dimension N+MAX(M,P)
          On exit, if INFO = 0, the leading INFRED(7) elements of
          IWORK contain the orders of the diagonal blocks of
          Ar-lambda*Er.

  DWORK   DOUBLE PRECISION array, dimension LDWORK

  LDWORK  INTEGER
          The length of the array DWORK.
          LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S';
          LDWORK >= MAX(N,2*M,2*P),   if EQUIL = 'N'.
          If LDWORK >= MAX(2*N*N+N*M+N*P)+MAX(N,2*M,2*P) then more
          accurate results are to be expected by performing only
          those reductions phases (see METHOD), where effective
          order reduction occurs. This is achieved by saving the
          system matrices before each phase and restoring them if no
          order reduction took place.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The subroutine is based on the reduction algorithms of [1].
  The order reduction is performed in 4 phases:
  Phase 1: Eliminate all finite uncontrolable eigenvalues.
           The resulting matrix ( Br Ar ) is in a controllable
           staircase form (see SLICOT Library routine TG01HD), and
           Er is upper triangular.
           This phase is performed if JOB = 'I' or 'C' and
           SYSTYP = 'R' or 'S'.
  Phase 2: Eliminate all infinite and finite nonzero uncontrollable
           eigenvalues. The resulting matrix ( Br Er ) is in a
           controllable staircase form (see TG01HD), and Ar is
           upper triangular.
           This phase is performed if JOB = 'I' or 'C' and
           SYSTYP = 'R' or 'P'.
  Phase 3: Eliminate all finite unobservable eigenvalues.
           The resulting matrix ( Ar ) is in an observable
                                ( Cr )
           staircase form (see SLICOT Library routine TG01ID), and
           Er is upper triangular.
           This phase is performed if JOB = 'I' or 'O' and
           SYSTYP = 'R' or 'S'.
  Phase 4: Eliminate all infinite and finite nonzero unobservable
           eigenvalues. The resulting matrix ( Er ) is in an
                                             ( Cr )
           observable staircase form (see TG01ID), and Ar is
           upper triangular.
           This phase is performed if JOB = 'I' or 'O' and
           SYSTYP = 'R' or 'P'.
References 
  [1] A. Varga
      Computation of Irreducible Generalized State-Space
      Realizations.
      Kybernetika, vol. 26, pp. 89-106, 1990.
Numerical Aspects 
  The algorithm is numerically backward stable and requires
  0( N**3 )  floating point operations.
Further Comments 
  If the pencil (A-lambda*E) has no zero eigenvalues, then an
  irreducible realization can be computed skipping Phases 1 and 3
  by using the setting: JOB = 'I' and SYSTYP = 'P'.
Example

Program Text 

*     TG01JD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDE = NMAX )
      INTEGER          LDWORK, LIWORK
      PARAMETER        ( LDWORK = MAX( 8*NMAX,2*MMAX,2*PMAX ),
     $                   LIWORK = NMAX + MAX( MMAX, PMAX ) )
*     .. Local Scalars ..
      CHARACTER        EQUIL, JOB, SYSTYP
      INTEGER          I, INFO, J, M, N, NR, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          INFRED(7), IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01JD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOB, SYSTYP, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99987 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99986 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the irreducible descriptor system (Ar-lambda Er,Br,Cr).
               CALL TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE,
     $                      B, LDB, C, LDC, NR, INFRED, TOL, IWORK,
     $                      DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) NR
                  WRITE ( NOUT, FMT = 99991 )
                  DO 10 I = 1, 4
                     IF( INFRED(I).GE.0 )
     $                  WRITE ( NOUT, FMT = 99990 ) I, INFRED(I)
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 30 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,NR )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 50 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   50             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01JD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01JD = ',I2)
99997 FORMAT (/' The reduced state dynamics matrix Ar is ')
99996 FORMAT (/' The reduced descriptor matrix Er is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Order of reduced system =', I5 )
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' Achieved order reductions in different phases')
99990 FORMAT (' Phase',I2,':', I3, ' elliminated eigenvalue(s)' )
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
      END
Program Data 
TG01JD EXAMPLE PROGRAM DATA
  9    2    2     0.0    I  R  N 
    -2    -3     0     0     0     0     0     0     0
     1     0     0     0     0     0     0     0     0
     0     0    -2    -3     0     0     0     0     0
     0     0     1     0     0     0     0     0     0
     0     0     0     0     1     0     0     0     0
     0     0     0     0     0     1     0     0     0
     0     0     0     0     0     0     1     0     0
     0     0     0     0     0     0     0     1     0
     0     0     0     0     0     0     0     0     1
     1     0     0     0     0     0     0     0     0
     0     1     0     0     0     0     0     0     0
     0     0     1     0     0     0     0     0     0
     0     0     0     1     0     0     0     0     0
     0     0     0     0     0     0     0     0     0
     0     0     0     0     1     0     0     0     0
     0     0     0     0     0     0     0     0     0
     0     0     0     0     0     0     1     0     0
     0     0     0     0     0     0     0     1     0
     1     0
     0     0
     0     1
     0     0
    -1     0
     0     0
     0    -1
     0     0
     0     0
     1     0     1    -3     0     1     0     2     0
     0     1     1     3     0     1     0     0     1
Program Results 
 TG01JD EXAMPLE PROGRAM RESULTS

 Order of reduced system =    7

 Achieved order reductions in different phases
 Phase 1:  0 elliminated eigenvalue(s)
 Phase 2:  0 elliminated eigenvalue(s)
 Phase 3:  2 elliminated eigenvalue(s)
 Phase 4:  0 elliminated eigenvalue(s)

 The reduced state dynamics matrix Ar is 
   1.0000  -0.0393  -0.0980  -0.1066   0.0781  -0.2330   0.0777
   0.0000   1.0312   0.2717   0.2609  -0.1533   0.6758  -0.3553
   0.0000   0.0000   1.3887   0.6699  -0.4281   1.6389  -0.7615
   0.0000   0.0000   0.0000  -1.2147   0.2423  -0.9792   0.4788
   0.0000   0.0000   0.0000   0.0000  -1.0545   0.5035  -0.2788
   0.0000   0.0000   0.0000   0.0000   0.0000   1.6355  -0.4323
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   1.0000

 The reduced descriptor matrix Er is 
   0.4100   0.2590   0.5080  -0.3109   0.0705   0.1429  -0.1477
  -0.7629  -0.3464   0.0992  -0.3007   0.0619   0.2483  -0.0152
   0.1120  -0.2124  -0.4184  -0.1288   0.0569  -0.4213  -0.6182
   0.0000   0.1122  -0.0039   0.2771  -0.0758   0.0975   0.3923
   0.0000   0.0000   0.3708  -0.4290   0.1006   0.1402  -0.2699
   0.0000   0.0000   0.0000   0.0000   0.9458  -0.2211   0.2378
   0.0000   0.0000   0.0000   0.5711   0.2648   0.5948  -0.5000

 The reduced input/state matrix Br is 
  -0.5597   0.2363
  -0.4843  -0.0498
  -0.4727  -0.1491
   0.1802   1.1574
   0.5995   0.1556
  -0.1729  -0.3999
   0.0000   0.2500

 The reduced state/output matrix Cr is 
   0.0000   0.0000   0.0000   0.0000   0.0000   0.0000   4.0000
   0.0000   0.0000   0.0000   0.0000   0.0000   3.1524  -1.7500

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/TG01WD.html000077500000000000000000000153571201767322700161250ustar00rootroot00000000000000 TG01WD - SLICOT Library Routine Documentation

TG01WD

Reduction of the descriptor dynamics matrix pair to generalized real Schur form

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To reduce the pair (A,E) to a real generalized Schur form
  by using an orthogonal equivalence transformation
  (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation
  to the matrices B and C: B <-- Q'*B and C <-- C*Z.
Specification 
      SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC,
     $                   Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK,
     $                   LDWORK, INFO )
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,*)
Arguments

Input/Output Parameters 

  N       (input) INTEGER
          The order of the original state-space representation,
          i.e., the order of the matrices A and E.  N >= 0.

  M       (input) INTEGER
          The number of system inputs, or of columns of B.  M >= 0.

  P       (input) INTEGER
          The number of system outputs, or of rows of C.  P >= 0.

  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
          On entry, the leading N-by-N part of this array must
          contain the original state dynamics matrix A.
          On exit, the leading N-by-N part of this array contains
          the matrix Q' * A * Z in an upper quasi-triangular form.
          The elements below the first subdiagonal are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,N).

  E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
          On entry, the leading N-by-N part of this array must
          contain the original descriptor matrix E.
          On exit, the leading N-by-N part of this array contains
          the matrix Q' * E * Z in an upper triangular form.
          The elements below the diagonal are set to zero.

  LDE     INTEGER
          The leading dimension of array E.  LDE >= MAX(1,N).

  B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
          On entry, the leading N-by-M part of this array must
          contain the input matrix B.
          On exit, the leading N-by-M part of this array contains
          the transformed input matrix Q' * B.

  LDB     INTEGER
          The leading dimension of array B.  LDB >= MAX(1,N).

  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
          On entry, the leading P-by-N part of this array must
          contain the output matrix C.
          On exit, the leading P-by-N part of this array contains
          the transformed output matrix C * Z.

  LDC     INTEGER
          The leading dimension of array C.  LDC >= MAX(1,P).

  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
          The leading N-by-N part of this array contains the left
          orthogonal transformation matrix used to reduce (A,E) to
          the real generalized Schur form.
          The columns of Q are the left generalized Schur vectors
          of the pair (A,E).

  LDQ     INTEGER
          The leading dimension of array Q.  LDQ >= max(1,N).

  Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
          The leading N-by-N part of this array contains the right
          orthogonal transformation matrix used to reduce (A,E) to
          the real generalized Schur form.
          The columns of Z are the right generalized Schur vectors
          of the pair (A,E).

  LDZ     INTEGER
          The leading dimension of array Z.  LDZ >= max(1,N).

  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
  BETA    (output) DOUBLE PRECISION array, dimension (N)
          On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j),
          j=1,...,N, will be the generalized eigenvalues.
          ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the
          diagonals of the complex Schur form that would result if
          the 2-by-2 diagonal blocks of the real Schur form of
          (A,E) were further reduced to triangular form using
          2-by-2 complex unitary transformations.
          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) negative.
Workspace 
  DWORK   DOUBLE PRECISION array, dimension (LDWORK)
          On exit, if INFO = 0, DWORK(1) returns the optimal value
          of LDWORK.

  LDWORK  INTEGER
          The dimension of working array DWORK.  LDWORK >= 8*N+16.
          For optimum performance LDWORK should be larger.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          > 0:  if INFO = i, the QZ algorithm failed to compute
                the generalized real Schur form; elements i+1:N of
                ALPHAR, ALPHAI, and BETA should be correct.
Method 
  The pair (A,E) is reduced to a real generalized Schur form using
  an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z)
  and the transformation is applied to the matrices B and C:
  B <-- Q'*B and C <-- C*Z.
Numerical Aspects 
                                  3
  The algorithm requires about 25N  floating point operations.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/UD01BD.html000077500000000000000000000146271201767322700160750ustar00rootroot00000000000000 UD01BD - SLICOT Library Routine Documentation

UD01BD

Reading a matrix polynomial

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To read the coefficients of a matrix polynomial
                                                 dp-1           dp
     P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s    + P(dp) * s  .
Specification 
      SUBROUTINE UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, LDP1, LDP2, MP, NP, NIN
C     .. Array Arguments ..
      DOUBLE PRECISION  P(LDP1,LDP2,*)
Arguments

Input/Output Parameters 

  MP      (input) INTEGER
          The number of rows of the matrix polynomial P(s).
          MP >= 1.

  NP      (input) INTEGER
          The number of columns of the matrix polynomial P(s).
          NP >= 1.

  DP      (input) INTEGER
          The degree of the matrix polynomial P(s).  DP >= 0.

  NIN     (input) INTEGER
          The input channel from which the elements of P(s) are
          read.  NIN >= 0.

  P       (output) DOUBLE PRECISION array, dimension
          (LDP1,LDP2,DP+1)
          The leading MP-by-NP-by-(DP+1) part of this array contains
          the coefficients of the matrix polynomial P(s).
          Specifically, P(i,j,k) contains the coefficient of
          s**(k-1) of the polynomial which is the (i,j)-th element
          of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and
          k = 1,2,...,DP+1.

  LDP1    INTEGER
          The leading dimension of array P.  LDP1 >= MP.

  LDP2    INTEGER
          The second dimension of array P.  LDP2 >= NP.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The coefficients P(i), i = 0, ..., DP, which are MP-by-NP
  matrices, are read from the input file NIN row by row. Each P(i)
  must be preceded by a text line. This text line can be used to
  indicate the coefficient matrices.
References 
  None.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     UD01BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MPMAX, NPMAX, DPMAX
      PARAMETER        ( MPMAX = 10, NPMAX = 10, DPMAX = 5 )
      INTEGER          LDP1, LDP2
      PARAMETER        ( LDP1 = MPMAX, LDP2 = NPMAX )
*     .. Local Scalars ..
      INTEGER          DP, INFO, L, MP, NP
*     .. Local Arrays ..
      DOUBLE PRECISION P(LDP1,LDP2,DPMAX)
*     .. External Subroutines ..
      EXTERNAL         UD01BD, UD01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) MP, NP, DP
      IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) MP
      ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NP
      ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DP
      ELSE
*        Read the coefficients of the matrix polynomial P(s).
         CALL UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, 99996 ) MP, NP, DP
*           Write the coefficients of the matrix polynomial P(s).
            L = 5
            CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, ' P',
     $                   INFO )
            IF ( INFO.NE.0 )
     $         WRITE ( NOUT, FMT = 99997 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' UD01BD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from UD01BD = ',I2)
99997 FORMAT (' INFO on exit from UD01ND = ',I2)
99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2)
99995 FORMAT (/' NP is out of range.',/' NP = ',I5)
99994 FORMAT (/' MP is out of range.',/' MP = ',I5)
99993 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END
Program Data 
UD01BD EXAMPLE PROGRAM DATA
   4   3   2 
P0
 1.0D-00  0.0D-00  0.0D-00
 0.0D-00  2.0D-00  4.0D-00
 0.0D-00  4.0D-00  8.0D-00
 0.0D-00  6.0D-00  1.2D+01
P1
 0.0D-00  1.0D-00  2.0D-00
 1.0D-00  0.0D-00  0.0D-00
 2.0D-00  0.0D-00  0.0D-00
 3.0D-00  0.0D-00  0.0D-00
P2
 1.0D-00  0.0D-00  0.0D-00
 0.0D-00  0.0D-00  0.0D-00
 0.0D-00  0.0D-00  0.0D-00
 0.0D-00  0.0D-00  0.0D-00
Program Results 
 UD01BD EXAMPLE PROGRAM RESULTS

 MP = 4   NP = 3   DP = 2

  P( 0) ( 4X 3)
            1              2              3
  1    0.1000000D+01  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.2000000D+01  0.4000000D+01
  3    0.0000000D+00  0.4000000D+01  0.8000000D+01
  4    0.0000000D+00  0.6000000D+01  0.1200000D+02

  P( 1) ( 4X 3)
            1              2              3
  1    0.0000000D+00  0.1000000D+01  0.2000000D+01
  2    0.1000000D+01  0.0000000D+00  0.0000000D+00
  3    0.2000000D+01  0.0000000D+00  0.0000000D+00
  4    0.3000000D+01  0.0000000D+00  0.0000000D+00

  P( 2) ( 4X 3)
            1              2              3
  1    0.1000000D+01  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.0000000D+00  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00  0.0000000D+00
  4    0.0000000D+00  0.0000000D+00  0.0000000D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/UD01CD.html000077500000000000000000000163241201767322700160720ustar00rootroot00000000000000 UD01CD - SLICOT Library Routine Documentation

UD01CD

Reading a sparse matrix polynomial

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To read the elements of a sparse matrix polynomial
                                                 dp-1           dp
     P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s    + P(dp) * s  .
Specification 
      SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, LDP1, LDP2, MP, NP, NIN
C     .. Array Arguments ..
      DOUBLE PRECISION  P(LDP1,LDP2,*)
Arguments

Input/Output Parameters 

  MP      (input) INTEGER
          The number of rows of the matrix polynomial P(s).
          MP >= 1.

  NP      (input) INTEGER
          The number of columns of the matrix polynomial P(s).
          NP >= 1.

  DP      (input) INTEGER
          The degree of the matrix polynomial P(s).  DP >= 0.

  NIN     (input) INTEGER
          The input channel from which the elements of P(s) are
          read.  NIN >= 0.

  P       (output) DOUBLE PRECISION array, dimension
          (LDP1,LDP2,DP+1)
          The leading MP-by-NP-by-(DP+1) part of this array contains
          the coefficients of the matrix polynomial P(s).
          Specifically, P(i,j,k) contains the coefficient of
          s**(k-1) of the polynomial which is the (i,j)-th element
          of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and
          k = 1,2,...,DP+1.
          The not assigned elements are set to zero.

  LDP1    INTEGER
          The leading dimension of array P.  LDP1 >= MP.

  LDP2    INTEGER
          The second dimension of array P.  LDP2 >= NP.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1 : if a row index i is read with i < 1 or i > MP or
                a column index j is read with j < 1 or j > NP or
                a coefficient degree d is read with d < 0 or
                d > DP + 1. This is a warning.
Method 
  First, the elements P(i,j,k) with 1 <= i <= MP, 1 <= j <= NP and
  1 <= k <= DP + 1 are set to zero. Next the nonzero (polynomial)
  elements are read from the input file NIN. Each nonzero element is
  given by the values i, j, d, P(i,j,k), k = 1, ..., d+1, where d is
  the degree and P(i,j,k) is the coefficient of s**(k-1) in the
  (i,j)-th element of P(s), i.e., let
                                                           d
      P   (s) = P   (0) + P   (1) * s + . . . + P   (d) * s
       i,j       i,j       i,j                   i,j

  be the nonzero (i,j)-th element of the matrix polynomial P(s).

  Then P(i,j,k) corresponds to coefficient P   (k-1), k = 1,...,d+1.
                                            i,j
  For each nonzero element, the values i, j, and d are read as one
  record of the file NIN, and the values P(i,j,k), k = 1,...,d+1,
  are read as the following record.
  The routine terminates after the last line has been read.
References 
  None.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     UD01CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MPMAX, NPMAX, DPMAX
      PARAMETER        ( MPMAX = 10, NPMAX = 10, DPMAX = 5 )
      INTEGER          LDP1, LDP2
      PARAMETER        ( LDP1 = MPMAX, LDP2 = NPMAX )
*     .. Local Scalars ..
      INTEGER          DP, INFO, INFO1, L, MP, NP
*     .. Local Arrays ..
      DOUBLE PRECISION P(LDP1,LDP2,DPMAX)
*     .. External Subroutines ..
      EXTERNAL         UD01CD, UD01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) MP, NP, DP
      IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) MP
      ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NP
      ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DP
      ELSE
*        Read the coefficients of the matrix polynomial P(s).
         CALL UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO )
         IF ( INFO.GE.0 ) THEN
            WRITE ( NOUT, 99996 ) MP, NP, DP
*           Write the coefficients of the matrix polynomial P(s).
            L = 5
            CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, ' P',
     $                   INFO1 )
            IF ( INFO1.NE.0 )
     $         WRITE ( NOUT, FMT = 99997 ) INFO1
         END IF
         IF ( INFO.NE.0 )
     $      WRITE ( NOUT, FMT = 99998 ) INFO
      END IF
      STOP
*
99999 FORMAT (' UD01CD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from UD01CD = ',I2)
99997 FORMAT (' INFO on exit from UD01ND = ',I2)
99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2)
99995 FORMAT (/' NP is out of range.',/' NP = ',I5)
99994 FORMAT (/' MP is out of range.',/' MP = ',I5)
99993 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END
Program Data 
UD01CD EXAMPLE PROGRAM DATA
   4   3   2
1  1  1
1.0  1.0
2  2  2
2.0  0.0  1.0
3  3  2
0.0  3.0  1.0
4  1  0
4.0
Program Results 
 UD01CD EXAMPLE PROGRAM RESULTS

 MP = 4   NP = 3   DP = 2

  P( 0) ( 4X 3)
            1              2              3
  1    0.1000000D+01  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.2000000D+01  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00  0.0000000D+00
  4    0.4000000D+01  0.0000000D+00  0.0000000D+00

  P( 1) ( 4X 3)
            1              2              3
  1    0.1000000D+01  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.0000000D+00  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00  0.3000000D+01
  4    0.0000000D+00  0.0000000D+00  0.0000000D+00

  P( 2) ( 4X 3)
            1              2              3
  1    0.0000000D+00  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.1000000D+01  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00  0.1000000D+01
  4    0.0000000D+00  0.0000000D+00  0.0000000D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/UD01DD.html000077500000000000000000000122751201767322700160740ustar00rootroot00000000000000 UD01DD - SLICOT Library Routine Documentation

UD01DD

Reading a sparse real matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To read the elements of a sparse matrix.
Specification 
      SUBROUTINE UD01DD( M, N, NIN, A, LDA, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, M, N, NIN
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of the matrix A.  M >= 0.

  N       (input) INTEGER
          The number of columns of the matrix A.  N >= 0.

  NIN     (input) INTEGER
          The input channel from which the elements of A are read.
          NIN >= 0.

  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
          The leading M-by-N part of this array contains the sparse
          matrix A. The not assigned elements are set to zero.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= MAX(1,M).
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value;
          = 1 : if a row index i is read with i < 1 or i > M or
                a column index j is read with j < 1 or j > N.
                This is a warning.
Method 
  First, the elements A(i,j) with 1 <= i <= M and 1 <= j <= N are
  set to zero. Next the nonzero elements are read from the input
  file NIN. Each line of NIN must contain consecutively the values
  i, j, A(i,j). The routine terminates after the last line has been
  read.
References 
  None.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     UD01DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 10, NMAX = 10 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
*     .. Local Scalars ..
      INTEGER          INFO, INFO1, M, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX)
*     .. External Subroutines ..
      EXTERNAL         UD01DD, UD01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
*        Read the coefficients of the matrix polynomial P(s).
         CALL UD01DD( M, N, NIN, A, LDA, INFO )
         IF ( INFO.GE.0 ) THEN
*           Write the matrix A.
            CALL UD01MD( M, N, 5, NOUT, A, LDA, ' Matrix A', INFO1 )
            IF ( INFO1.NE.0 )
     $         WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
         IF ( INFO.NE.0 )
     $      WRITE ( NOUT, FMT = 99997 ) INFO
      END IF
      STOP
*
99999 FORMAT (' UD01DD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from UD01MD = ',I2)
99997 FORMAT (' INFO on exit from UD01DD = ',I2)
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
UD01DD EXAMPLE PROGRAM DATA
6  5
1   1   -1.1
6   1    1.5
2   2   -2.2
6   2    2.5
3   3   -3.3
6   3    3.5
4   4   -4.4
6   4    4.5
5   5   -5.5
6   5    5.5
Program Results 
 UD01DD EXAMPLE PROGRAM RESULTS

  Matrix A ( 6X 5)

            1              2              3              4              5
  1   -0.1100000D+01  0.0000000D+00  0.0000000D+00  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00 -0.2200000D+01  0.0000000D+00  0.0000000D+00  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00 -0.3300000D+01  0.0000000D+00  0.0000000D+00
  4    0.0000000D+00  0.0000000D+00  0.0000000D+00 -0.4400000D+01  0.0000000D+00
  5    0.0000000D+00  0.0000000D+00  0.0000000D+00  0.0000000D+00 -0.5500000D+01
  6    0.1500000D+01  0.2500000D+01  0.3500000D+01  0.4500000D+01  0.5500000D+01

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/UD01MD.html000077500000000000000000000124061201767322700161010ustar00rootroot00000000000000 UD01MD - SLICOT Library Routine Documentation

UD01MD

Printing a real matrix

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To print an M-by-N real matrix A row by row. The elements of A
  are output to 7 significant figures.
Specification 
      SUBROUTINE UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, M, N, NOUT
      CHARACTER*(*)     TEXT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of matrix A to be printed.  M >= 1.

  N       (input) INTEGER
          The number of columns of matrix A to be printed.  N >= 1.

  L       (input) INTEGER
          The number of elements of matrix A to be printed per line.
          1 <= L <= 5.

  NOUT    (input) INTEGER
          The output channel to which the results are sent.
          NOUT >= 0.

  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
          The leading M-by-N part of this array must contain the
          matrix to be printed.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= M.

  TEXT    (input) CHARACTER*72.
          Title caption of the matrix to be printed (up to a
          maximum of 72 characters). For example, TEXT = 'Matrix A'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine first prints the contents of TEXT as a title, followed
  by the elements of the matrix A such that

  (i)  if N <= L, the leading M-by-N part is printed;
  (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of
       consecutive columns of A are printed one after another
       followed by one M-by-p block containing the last p columns
       of A.

  Row numbers are printed on the left of each row and a column
  number appears on top of each column.
  The routine uses 2 + (k + 1)*(m + 1) lines and 8 + 15*c positions
  per line where c is the actual number of columns, (i.e. c = L
  or c = p).
References 
  None.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     UD01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA
      PARAMETER        ( LDA = MMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, L, M, N
      CHARACTER*72     TEXT
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX)
*     .. External Subroutines ..
      EXTERNAL         UD01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, L, TEXT
      IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99996 ) M
      ELSE IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99997 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
*        Print out the matrix A.
         CALL UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO )
         IF ( INFO.NE.0 ) WRITE ( NOUT, FMT = 99998 ) INFO
      END IF
      STOP
*
99999 FORMAT (' UD01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from UD01MD = ',I2)
99997 FORMAT (/' N is out of range.',/' N = ',I5)
99996 FORMAT (/' M is out of range.',/' M = ',I5)
      END
Program Data 
 UD01MD EXAMPLE PROGRAM DATA
   4     4     4     'Matrix A'
   1.0   2.0   3.0   4.0
   5.0   6.0   7.0   8.0
   9.0  10.0  11.0  12.0
  13.0  14.0  15.0  16.0
Program Results 
 UD01MD EXAMPLE PROGRAM RESULTS

 Matrix A ( 4X 4)

            1              2              3              4
  1    0.1000000D+01  0.2000000D+01  0.3000000D+01  0.4000000D+01
  2    0.5000000D+01  0.6000000D+01  0.7000000D+01  0.8000000D+01
  3    0.9000000D+01  0.1000000D+02  0.1100000D+02  0.1200000D+02
  4    0.1300000D+02  0.1400000D+02  0.1500000D+02  0.1600000D+02

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/UD01MZ.html000077500000000000000000000066631201767322700161370ustar00rootroot00000000000000 UD01MZ - SLICOT Library Routine Documentation

UD01MZ

Printing a real matrix (complex case)

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To print an M-by-N real matrix A row by row. The elements of A
  are output to 7 significant figures.
Specification 
      SUBROUTINE UD01MZ( M, N, L, NOUT, A, LDA, TEXT, INFO )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, M, N, NOUT
      CHARACTER*(*)     TEXT
C     .. Array Arguments ..
      COMPLEX*16        A(LDA,*)
Arguments

Input/Output Parameters 

  M       (input) INTEGER
          The number of rows of matrix A to be printed.  M >= 1.

  N       (input) INTEGER
          The number of columns of matrix A to be printed.  N >= 1.

  L       (input) INTEGER
          The number of elements of matrix A to be printed per line.
          1 <= L <= 3.

  NOUT    (input) INTEGER
          The output channel to which the results are sent.
          NOUT >= 0.

  A       (input) COMPLEX*16 array, dimension (LDA,N)
          The leading M-by-N part of this array must contain the
          matrix to be printed.

  LDA     INTEGER
          The leading dimension of array A.  LDA >= M.

  TEXT    (input) CHARACTER*72.
          Title caption of the matrix to be printed (up to a
          maximum of 72 characters). For example, TEXT = 'Matrix A'.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  The routine first prints the contents of TEXT as a title, followed
  by the elements of the matrix A such that

  (i)  if N <= L, the leading M-by-N part is printed;
  (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of
       consecutive columns of A are printed one after another
       followed by one M-by-p block containing the last p columns
       of A.

  Row numbers are printed on the left of each row and a column
  number appears on top of each complex column.
  The routine uses 2 + (k + 1)*(m + 1) lines and 7 + 32*c positions
  per line where c is the actual number of columns, (i.e. c = L
  or c = p).
References 
  None.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/UD01ND.html000077500000000000000000000164641201767322700161120ustar00rootroot00000000000000 UD01ND - SLICOT Library Routine Documentation

UD01ND

Printing a matrix polynomial

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To print the MP-by-NP coefficient matrices of a matrix polynomial
                                                 dp-1           dp
     P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s    + P(dp) * s  .

  The elements of the matrices are output to 7 significant figures.
Specification 
      SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT,
     $                   INFO )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, L, LDP1, LDP2, MP, NP, NOUT
      CHARACTER*(*)     TEXT
C     .. Array Arguments ..
      DOUBLE PRECISION  P(LDP1,LDP2,*)
Arguments

Input/Output Parameters 

  MP      (input) INTEGER
          The number of rows of the matrix polynomial P(s).
          MP >= 1.

  NP      (input) INTEGER
          The number of columns of the matrix polynomial P(s).
          NP >= 1.

  DP      (input) INTEGER
          The degree of the matrix polynomial P(s).  DP >= 0.

  L       (input) INTEGER
          The number of elements of the coefficient matrices to be
          printed per line.  1 <= L <= 5.

  NOUT    (input) INTEGER
          The output channel to which the results are sent.
          NOUT >= 0.

  P       (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1)
          The leading MP-by-NP-by-(DP+1) part of this array must
          contain the coefficients of the matrix polynomial P(s).
          Specifically, P(i,j,k) must contain the coefficient of
          s**(k-1) of the polynomial which is the (i,j)-th element
          of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and
          k = 1,2,...,DP+1.

  LDP1    INTEGER
          The leading dimension of array P.  LDP1 >= MP.

  LDP2    INTEGER
          The second dimension of array P.  LDP2 >= NP.

  TEXT    (input) CHARACTER*72
          Title caption of the coefficient matrices to be printed.
          TEXT is followed by the degree of the coefficient matrix,
          within brackets. If TEXT = ' ', then the coefficient
          matrices are separated by an empty line.
Error Indicator 
  INFO    INTEGER
          = 0:  successful exit;
          < 0:  if INFO = -i, the i-th argument had an illegal
                value.
Method 
  For i = 1, 2, ..., DP + 1 the routine first prints the contents of
  TEXT followed by (i-1) as a title, followed by the elements of the
  MP-by-NP coefficient matrix P(i) such that
  (i)  if NP < L, then the leading MP-by-NP part is printed;
  (ii) if NP = k*L + p (where k, p > 0), then k MP-by-L blocks of
       consecutive columns of P(i) are printed one after another
       followed by one MP-by-p block containing the last p columns
       of P(i).
  Row numbers are printed on the left of each row and a column
  number on top of each column.
References 
  None.
Numerical Aspects 
  None.
Further Comments 
  None
Example

Program Text 

*     UD01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2010 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MPMAX, NPMAX, DPMAX
      PARAMETER        ( MPMAX = 10, NPMAX = 10, DPMAX = 5 )
      INTEGER          LDP1, LDP2
      PARAMETER        ( LDP1 = MPMAX, LDP2 = NPMAX )
*     .. Local Scalars ..
      INTEGER          DP, INFO, L, MP, NP
      CHARACTER*72     TEXT
*     .. Local Arrays ..
      DOUBLE PRECISION P(LDP1,LDP2,DPMAX)
*     .. External Subroutines ..
      EXTERNAL         UD01BD, UD01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) MP, NP, DP, L, TEXT
      IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) MP
      ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NP
      ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DP
      ELSE
*        Read the coefficients of the matrix polynomial P(s).
         CALL UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, 99996 ) MP, NP, DP
*           Write the coefficients of the matrix polynomial P(s).
            CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT,
     $                   INFO )
            IF ( INFO.NE.0 )
     $         WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' UD01ND EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from UD01ND = ',I2)
99997 FORMAT (' INFO on exit from UD01BD = ',I2)
99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2)
99995 FORMAT (/' NP is out of range.',/' NP = ',I5)
99994 FORMAT (/' MP is out of range.',/' MP = ',I5)
99993 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END
Program Data 
UD01ND EXAMPLE PROGRAM DATA
   4     3     2     5   P
P0
 1.0D-00  0.0D-00  0.0D-00
 0.0D-00  2.0D-00  4.0D-00
 0.0D-00  4.0D-00  8.0D-00
 0.0D-00  6.0D-00  1.2D+01
P1
 0.0D-00  1.0D-00  2.0D-00
 1.0D-00  0.0D-00  0.0D-00
 2.0D-00  0.0D-00  0.0D-00
 3.0D-00  0.0D-00  0.0D-00
P2
 1.0D-00  0.0D-00  0.0D-00
 0.0D-00  0.0D-00  0.0D-00
 0.0D-00  0.0D-00  0.0D-00
 0.0D-00  0.0D-00  0.0D-00
Program Results 
 UD01ND EXAMPLE PROGRAM RESULTS

 MP = 4   NP = 3   DP = 2

 P( 0) ( 4X 3)
            1              2              3
  1    0.1000000D+01  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.2000000D+01  0.4000000D+01
  3    0.0000000D+00  0.4000000D+01  0.8000000D+01
  4    0.0000000D+00  0.6000000D+01  0.1200000D+02

 P( 1) ( 4X 3)
            1              2              3
  1    0.0000000D+00  0.1000000D+01  0.2000000D+01
  2    0.1000000D+01  0.0000000D+00  0.0000000D+00
  3    0.2000000D+01  0.0000000D+00  0.0000000D+00
  4    0.3000000D+01  0.0000000D+00  0.0000000D+00

 P( 2) ( 4X 3)
            1              2              3
  1    0.1000000D+01  0.0000000D+00  0.0000000D+00
  2    0.0000000D+00  0.0000000D+00  0.0000000D+00
  3    0.0000000D+00  0.0000000D+00  0.0000000D+00
  4    0.0000000D+00  0.0000000D+00  0.0000000D+00

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/UE01MD.html000077500000000000000000000056761201767322700161150ustar00rootroot00000000000000 UE01MD - SLICOT Library Routine Documentation

UE01MD

Default machine-specific parameters for (skew-)Hamiltonian computation routines

[Specification] [Arguments] [Method] [References] [Comments] [Example]

Purpose 

  To provide an extension of the LAPACK routine ILAENV to
  machine-specific parameters for SLICOT routines.

  The default values in this version aim to give good performance on
  a wide range of computers. For optimal performance, however, the
  user is advised to modify this routine. Note that an optimized
  BLAS is a crucial prerequisite for any speed gains. For further
  details, see ILAENV.
Function Value 
  UE01MD  INTEGER
          The function value set according to ISPEC.
Arguments

Input/Output Parameters 

  ISPEC   (input) INTEGER
          Specifies the parameter to be returned as the value of
          UE01MD, as follows:
          = 1: the optimal blocksize; if the returned value is 1, an
               unblocked algorithm will give the best performance;
          = 2: the minimum block size for which the block routine
               should be used; if the usable block size is less than
               this value, an unblocked routine should be used;
          = 3: the crossover point (in a block routine, for N less
               than this value, an unblocked routine should be used)
          = 4: the number of shifts, used in the product eigenvalue
               routine;
          = 8: the crossover point for the multishift QR method for
               product eigenvalue problems.

  NAME    (input) CHARACTER*(*)
          The name of the calling subroutine, in either upper case
          or lower case.

  OPTS    (input) CHARACTER*(*)
          The character options to the subroutine NAME, concatenated
          into a single character string.

  N1      (input) INTEGER
  N2      (input) INTEGER
  N3      (input) INTEGER
          Problem dimensions for the subroutine NAME; these may not
          all be required.
Further Comments 
  None
Example

Program Text 

  None
Program Data 
  None
Program Results 
  None

Click here to get a compressed (gzip) tar file containing the source code of the routine, the example program, data, documentation, and related files.

Return to index slicot-5.0+20101122/doc/readme000077500000000000000000000017221201767322700155000ustar00rootroot00000000000000SLICOT Library Subdirectory doc ------------------------------- SLICOT Library Subdirectory doc contains documentation files (*.html) for almost all SLICOT Library routines. Omitted are few auxiliary routines, called by other SLICOT routines, but which seem to have no general use. The documentation conforms to the SLICOT standards. Besides function, arguments, and algorithm description, most documents for user-callable rotines include example programs, which could be easily modified, by copying, pasting, etc., to solve related, specific problems. The documentation files could be viewed individually, or via the provided index files: the main SLICOT Library index (libindex.html), stored in the SLICOT root directory, or the auxiliary, supporting routines index (support.html), stored in the subdirectory doc. The second file is also accessible from the first one. These index files are organized according to the SLICOT Library chapters, sections, and subsections. slicot-5.0+20101122/doc/support.html000077500000000000000000000765511201767322700167360ustar00rootroot00000000000000 On-Line SLICOT Supporting Routines Overview

SLICOT SUPPORTING ROUTINES INDEX

To go to the beginning of a chapter click on the appropriate letter below:

A ; B ; C ; D ; F ; I ; M ; N ; S ; T ; U ;

or Return to SLICOT homepage
or Go to SLICOT LIBRARY INDEX

A - Analysis Routines

AB - State-Space Analysis

Poles, Zeros, Gain


AB08NX   Construction of a reduced system with input/output matrix Dr of full 
         row rank, preserving transmission zeros

AB8NXZ   Construction of a reduced system with input/output matrix Dr of full 
         row rank, preserving transmission zeros (complex case)

Model Reduction


AB09AX   Balance & Truncate model reduction with state matrix in real Schur form  

AB09BX   Singular perturbation approximation based model reduction with state
         matrix in real Schur form 

AB09CX   Hankel norm approximation based model reduction with state matrix
         in real Schur form 

AB09HX   Stochastic balancing model reduction of stable systems

AB09HY   Cholesky factors of the controllability and observability Grammians

AB09IX   Accuracy enhanced balancing related model reduction

AB09IY   Cholesky factors of the frequency-weighted controllability and 
         observability Grammians

AB09JV   State-space representation of a projection of a left weighted 
         transfer-function matrix

AB09JW   State-space representation of a projection of a right weighted 
         transfer-function matrix

AB09JX   Check stability/antistability of finite eigenvalues

AB09KX   Stable projection of V*G*W or conj(V)*G*conj(W)

System Norms


AB13AX   Hankel-norm of a stable system with state matrix in real Schur form  

AB13DX   Maximum singular value of a transfer-function matrix

AG - Generalized State-Space Analysis

Poles, Zeros, Gain


AG08BY   Construction of a reduced system with input/output matrix Dr of full 
         row rank, preserving the finite Smith zeros

AG8BYZ   Construction of a reduced system with input/output matrix Dr of full 
         row rank, preserving the finite Smith zeros (complex case)

B - Benchmark and Test Problems

C - Adaptive Control

D - Data Analysis

DE - Covariances

DF - Spectra

DG - Discrete Fourier Transforms

DK - Windowing

F - Filtering

FB - Kalman Filters

I - Identification

IB - Subspace Identification

Time Invariant State-space Systems


IB01MD   Upper triangular factor in QR factorization of a
         block-Hankel-block matrix

IB01MY   Upper triangular factor in fast QR factorization of a 
         block-Hankel-block matrix

IB01ND   Singular value decomposition giving the system order

IB01OD   Estimating the system order

IB01OY   User's confirmation of the system order

IB01PD   Estimating the system matrices and covariances

IB01PX   Estimating the matrices B and D of a system using Kronecker products

IB01PY   Estimating the matrices B and D of a system exploiting the structure

IB01QD   Estimating the initial state and the matrices B and D of a system

IB01RD   Estimating the initial state of a system

M - Mathematical Routines

MA - Auxiliary Routines

Mathematical Scalar Routines


MA01AD   Complex square root of a complex number in real arithmetic

MA01BD   Safely computing the general product of K real scalars

MA01CD   Safely computing the sign of a sum of two real numbers represented
         using integer powers of a base

Mathematical Vector/Matrix Routines


MA02AD   Transpose of a matrix

MA02BD   Reversing the order of rows and/or columns of a matrix

MA02BZ   Reversing the order of rows and/or columns of a matrix (complex case)

MA02CD   Pertranspose of the central band of a square matrix 

MA02CZ   Pertranspose of the central band of a square matrix (complex case)

MA02DD   Pack/unpack the upper or lower triangle of a symmetric matrix 

MA02ED   Construct a triangle of a symmetric matrix, given the other triangle 

MA02FD   Hyperbolic plane rotation 

MA02GD   Column interchanges on the matrix 

MA02HD   Check if a matrix is a scalar multiple of an identity-like matrix

MA02ID   Matrix 1-, Frobenius, or infinity norms of a skew-Hamiltonian matrix

MA02JD   Test if a matrix is an orthogonal symplectic matrix

MB01KD   Rank 2k operation alpha*A*trans(B) - alpha*B*trans(A) + beta*C,
         with A and C skew-symmetric matrices

MB01LD   Computation of matrix expression alpha*R + beta*A*X*trans(A) with 
         skew-symmetric matrices R and X

MB01MD   Matrix-vector operation alpha*A*x + beta*y, with A a skew-symmetric matrix

MB01ND   Rank 2 operation alpha*x*trans(y) - alpha*y*trans(x) + A, with A a 
         skew-symmetric matrix

MB01SD   Rows and/or columns scaling of a matrix

MB - Linear Algebra

Basic Linear Algebra Manipulations


MB01RU   Computation of matrix expression alpha*R + beta*A*X*trans(A)
         (MB01RD variant)

MB01RW   Computation of matrix expression alpha*A*X*trans(A), X symmetric (BLAS 2)

MB01RX   Computing a triangle of the matrix expressions alpha*R + beta*A*B 
         or alpha*R + beta*B*A

MB01RY   Computing a triangle of the matrix expressions alpha*R + beta*H*B 
         or alpha*R + beta*B*H, with H an upper Hessenberg matrix

MB01UW   Computation of matrix expressions alpha*H*A or alpha*A*H,
         overwritting A, with H an upper Hessenberg matrix

MB01VD   Kronecker product of two matrices

MB01XY   Computation of the product U'*U or L*L', with U and L upper and 
         lower triangular matrices (unblock algorithm)

SB03OV   Construction of a complex plane rotation to annihilate a real number,
         modifying a complex number

SG03BY   Computing a complex plane rotation in real arithmetic

Linear Equations and Least Squares


MB02CU   Bringing the first blocks of a generator in proper form
         (extended version of MB02CX)

MB02CV   Applying the MB02CU transformations on other columns / rows of 
         the generator

MB02CX   Bringing the first blocks of a generator in proper form

MB02CY   Applying the MB02CX transformations on other columns / rows of 
         the generator

MB02NY   Separation of a zero singular value of a bidiagonal submatrix

MB02QY   Minimum-norm least squares solution, given a rank-revealing
         QR factorization

MB02UU   Solution of linear equations using LU factorization with complete pivoting

MB02UV   LU factorization with complete pivoting

MB02UW   Solution of linear equations of order at most 2 with possible scaling 
         and perturbation of system matrix

MB02WD   Solution of a positive definite linear system A*x = b, or f(A, x) = b,
         using conjugate gradient algorithm

MB02XD   Solution of a set of positive definite linear systems, A'*A*X = B, or
         f(A)*X = B, using Gaussian elimination

MB02YD   Solution of the linear system A*x = b, D*x = 0, D diagonal

Eigenvalues and Eigenvectors


MB03AD   Reducing the first column of a real Wilkinson shift polynomial for a 
         product of matrices to the first unit vector

MB03BA   Computing maps for Hessenberg index and signature array

MB03BB   Eigenvalues of a 2-by-2 matrix product via a complex single shifted 
         periodic QZ algorithm

MB03BC   Product singular value decomposition of K-1 triangular factors of 
         order 2

MB03BD   Finding eigenvalues of a generalized matrix product in 
         Hessenberg-triangular form

MB03BE   Applying 10 iterations of a real single shifted periodic QZ algorithm 
         to a 2-by-2 matrix product

MB03CD   Exchanging eigenvalues of a real 2-by-2, 3-by-3 or 4-by-4 block upper 
         triangular pencil (factored version)

MB03DD   Exchanging eigenvalues of a real 2-by-2, 3-by-3 or 4-by-4 block upper 
         triangular pencil

MB03ED   Reducing a real 2-by-2 or 4-by-4 block (anti-)diagonal 
         skew-Hamiltonian/Hamiltonian pencil to generalized Schur form and moving 
         eigenvalues with negative real parts to the top (factored version)

MB03FD   Reducing a real 2-by-2 or 4-by-4 block (anti-)diagonal 
         skew-Hamiltonian/Hamiltonian pencil to generalized Schur form and moving 
         eigenvalues with negative real parts to the top

MB03GD   Exchanging eigenvalues of a real 2-by-2 or 4-by-4 block upper 
         triangular skew-Hamiltonian/Hamiltonian pencil (factored version)

MB03HD   Exchanging eigenvalues of a real 2-by-2 or 4-by-4 skew-Hamiltonian/
         Hamiltonian pencil in structured Schur form

MB03ID   Moving eigenvalues with negative real parts of a real 
         skew-Hamiltonian/Hamiltonian pencil in structured Schur form to the 
         leading subpencil (factored version)

MB03JD   Moving eigenvalues with negative real parts of a real 
         skew-Hamiltonian/Hamiltonian pencil in structured Schur form to the 
         leading subpencil

MB03KA   Moving diagonal blocks at a specified position in a formal matrix 
         product to another position

MB03KB   Swapping pairs of adjacent diagonal blocks of sizes 1 and/or 2 in 
         a formal matrix product

MB03KC   Reducing a 2-by-2 formal matrix product to periodic 
         Hessenberg-triangular form

MB03KD   Reordering the diagonal blocks of a formal matrix product using 
         periodic QZ algorithm

MB03KE   Solving periodic Sylvester-like equations with matrices of order 
         at most 2

MB03NY   The smallest singular value of A - jwI

MB03OY   Matrix rank determination by incremental condition estimation, during 
         the pivoted QR factorization process 

MB3OYZ   Matrix rank determination by incremental condition estimation, during 
         the pivoted QR factorization process (complex case) 

MB03PY   Matrix rank determination by incremental condition estimation, during 
         the pivoted RQ factorization process (row pivoting) 

MB3PYZ   Matrix rank determination by incremental condition estimation, during 
         the pivoted RQ factorization process (row pivoting, complex case) 

MB03QX   Eigenvalues of an upper quasi-triangular matrix

MB03QY   Transformation to Schur canonical form of a selected 2-by-2 diagonal
         block of an upper quasi-triangular matrix

MB03RX   Reordering the diagonal blocks of a principal submatrix of a real Schur 
         form matrix

MB03RY   Tentative solution of Sylvester equation -AX + XB = C (A, B in real 
         Schur form)

MB03TS   Swapping two diagonal blocks of a matrix in (skew-)Hamiltonian 
         canonical Schur form

MB03VY   Generating orthogonal matrices for reduction to periodic 
         Hessenberg form of a product of matrices

MB03WA   Swapping two adjacent diagonal blocks in a periodic real Schur canonical form

MB03WX   Eigenvalues of a product of matrices, T = T_1*T_2*...*T_p,
         with T_1 upper quasi-triangular and T_2, ..., T_p upper triangular 

MB03XU   Panel reduction of columns and rows of a real (k+2n)-by-(k+2n) matrix by 
         orthogonal symplectic transformations

MB03YA   Annihilation of one or two entries on the subdiagonal of a Hessenberg matrix 
         corresponding to zero elements on the diagonal of a triangular matrix

MB03YT   Periodic Schur factorization of a real 2-by-2 matrix pair (A,B) 
         with B upper triangular

MB03ZA   Reordering a selected cluster of eigenvalues of a given matrix pair in 
         periodic Schur form

MB05MY   Computing an orthogonal matrix reducing a matrix to real Schur form T, 
         the eigenvalues, and the upper triangular matrix of right eigenvectors 
         of T 

MB05OY   Restoring a matrix after balancing transformations

Decompositions and Transformations


MB04DD   Balancing a real Hamiltonian matrix

MB04DI   Applying the inverse of a balancing transformation for a real Hamiltonian matrix

MB04DS   Balancing a real skew-Hamiltonian matrix

MB04DY   Symplectic scaling of a Hamiltonian matrix

MB04HD   Reducing a special real block (anti-)diagonal skew-Hamiltonian/
         Hamiltonian pencil to generalized Schur form

MB04IY   Applying the product of elementary reflectors used for QR factorization
         of a matrix having a lower left zero triangle

MB04NY   Applying an elementary reflector to a matrix C = ( A  B ), from the right, 
         where A has one column

MB04OY   Applying an elementary reflector to a matrix C = ( A'  B' )', from the 
         left, where A has one row

MB04OW   Rank-one update of a Cholesky factorization for a 2-by-2 block matrix

MB04OX   Rank-one update of a Cholesky factorization

MB04PU   Computation of the Paige/Van Loan (PVL) form of a Hamiltonian matrix 
         (unblocked algorithm)

MB04PY   Applying an elementary reflector to a matrix from the left or right

MB04QB   Applying a product of symplectic reflectors and Givens rotators to two 
         general real matrices

MB04QC   Premultiplying a real matrix with an orthogonal symplectic block reflector

MB04QF   Forming the triangular block factors of a symplectic block reflector

MB04QU   Applying a product of symplectic reflectors and Givens rotators to two 
         general real matrices (unblocked algorithm)

MB04SU   Symplectic QR decomposition of a real 2M-by-N matrix

MB04TS   Symplectic URV decomposition of a real 2N-by-2N matrix (unblocked version)

MB04TU   Applying a row-permuted Givens transformation to two row vectors

MB04WD   Generating an orthogonal basis spanning an isotropic subspace

MB04WP   Generating an orthogonal symplectic matrix which performed the reduction 
         in MB04PU

MB04WR   Generating orthogonal symplectic matrices defined as products of symplectic 
         reflectors and Givens rotators

MB04WU   Generating an orthogonal basis spanning an isotropic subspace 
         (unblocked version)

MB04XY   Applying Householder transformations for bidiagonalization (stored 
         in factored form) to one or two matrices, from the left

MB04YW   One QR or QL iteration step onto an unreduced bidiagonal submatrix 
         of a bidiagonal matrix

MC - Polynomial and Rational Function Manipulation

Scalar Polynomials


MC01PY   Coefficients of a real polynomial, stored in decreasing order, 
         given its zeros

Polynomial Matrices


MC03NX   Construction of a pencil sE-A related to a given polynomial matrix

MD - Optimization

Unconstrained Nonlinear Least Squares


MD03BX   QR factorization with column pivoting and error vector 
         transformation

MD03BY   Finding the Levenberg-Marquardt parameter

N - Nonlinear Systems

NF - Wiener Systems

Wiener Systems Identification


NF01AD   Computing the output of a Wiener system  

NF01AY   Computing the output of a set of neural networks

NF01BD   Computing the Jacobian of a Wiener system  

NF01BP   Finding the Levenberg-Marquardt parameter

NF01BQ   Solution of the linear system J*x = b, D*x = 0, D diagonal

NF01BR   Solution of the linear system op(R)*x = b, R block upper 
         triangular stored in a compressed form

NF01BS   QR factorization of a structured Jacobian matrix

NF01BU   Computing J'*J + c*I, for the Jacobian J given in a
         compressed form

NF01BV   Computing J'*J + c*I, for a full Jacobian J (one output
         variable)

NF01BW   Matrix-vector product x <-- (J'*J + c*I)*x, for J in a
         compressed form

NF01BX   Matrix-vector product x <-- (A'*A + c*I)*x, for a
         full matrix A

NF01BY   Computing the Jacobian of the error function for a neural 
         network (for one output variable)

S - Synthesis Routines

SB - State-Space Synthesis

Eigenvalue/Eigenvector Assignment


SB01BX   Choosing the closest real (complex conjugate) eigenvalue(s) to
         a given real (complex) value

SB01BY   Pole placement for systems of order 1 or 2

SB01FY   Inner denominator of a right-coprime factorization of an unstable system
         of order 1 or 2

Riccati Equations


SB02MU   Constructing the 2n-by-2n Hamiltonian or symplectic matrix for
         linear-quadratic optimization problems

SB02RU   Constructing the 2n-by-2n Hamiltonian or symplectic matrix for
         linear-quadratic optimization problems (efficient and accurate
         version of SB02MU)

SB02OY   Constructing and compressing the extended Hamiltonian or symplectic 
         matrix pairs for linear-quadratic optimization problems

Lyapunov Equations


SB03MV   Solving a discrete-time Lyapunov equation for a 2-by-2 matrix

SB03MW   Solving a continuous-time Lyapunov equation for a 2-by-2 matrix

SB03MX   Solving a discrete-time Lyapunov equation with matrix A quasi-triangular

SB03MY   Solving a continuous-time Lyapunov equation with matrix A quasi-triangular

SB03OT   Solving (for Cholesky factor) stable continuous- or discrete-time 
         Lyapunov equations, with A quasi-triangular and R triangular

SB03OU   Solving (for Cholesky factor) stable continuous- or discrete-time 
         Lyapunov equations, with A in real Schur form and B rectangular

SB03OY   Solving (for Cholesky factor) stable 2-by-2 continuous- or discrete-time
         Lyapunov equations, with matrix A having complex conjugate eigenvalues

SB03QX   Forward error bound for continuous-time Lyapunov equations

SB03QY   Separation and Theta norm for continuous-time Lyapunov equations

SB03SX   Forward error bound for discrete-time Lyapunov equations

SB03SY   Separation and Theta norm for discrete-time Lyapunov equations

Sylvester Equations


SB03MU   Solving a discrete-time Sylvester equation for an m-by-n matrix X, 
         1 <= m,n <= 2

SB03OR   Solving quasi-triangular continuous- or discrete-time Sylvester equations, 
         for an n-by-m matrix X, 1 <= m <= 2

SB04MR   Solving a linear algebraic system whose coefficient matrix (stored 
         compactly) has zeros below the second subdiagonal

SB04MU   Constructing and solving a linear algebraic system whose coefficient 
         matrix (stored compactly) has zeros below the second subdiagonal 

SB04MW   Solving a linear algebraic system whose coefficient matrix (stored 
         compactly) has zeros below the first subdiagonal

SB04MY   Constructing and solving a linear algebraic system whose coefficient 
         matrix (stored compactly) has zeros below the first subdiagonal

SB04NV   Constructing right-hand sides for a system of equations in 
         Hessenberg form solved via SB04NX

SB04NW   Constructing the right-hand side for a system of equations in 
         Hessenberg form solved via SB04NY 

SB04NX   Solving a system of equations in Hessenberg form with two consecutive 
         offdiagonals and two right-hand sides 

SB04NY   Solving a system of equations in Hessenberg form with one offdiagonal 
         and one right-hand side 

SB04OW   Solving a periodic Sylvester equation with matrices in periodic Schur form

SB04PX   Solving a discrete-time Sylvester equation for matrices of order <= 2

SB04PY   Solving a discrete-time Sylvester equation with matrices in Schur form

SB04QR   Solving a linear algebraic system whose coefficient matrix (stored 
         compactly) has zeros below the third subdiagonal

SB04QU   Constructing and solving a linear algebraic system whose coefficient 
         matrix (stored compactly) has zeros below the third subdiagonal

SB04QY   Constructing and solving a linear algebraic system whose coefficient 
         matrix (stored compactly) has zeros below the first subdiagonal
         (discrete-time case)

SB04RV   Constructing right-hand sides for a system of equations in 
         Hessenberg form solved via SB04RX

SB04RW   Constructing the right-hand side for a system of equations in 
         Hessenberg form solved via SB04RY 

SB04RX   Solving a system of equations in Hessenberg form with two consecutive 
         offdiagonals and two right-hand sides (discrete-time case) 

SB04RY   Solving a system of equations in Hessenberg form with one offdiagonal 
         and one right-hand side (discrete-time case)

Optimal Regulator Problems


SB10JD    Conversion of a descriptor state-space system into regular 
          state-space form

SB10LD    Closed-loop system matrices for a system with robust controller

SB10PD    Normalization of a system for H-infinity controller design

SB10QD    State feedback and output injection matrices for an H-infinity
          (sub)optimal state controller (continuous-time)

SB10RD    H-infinity (sub)optimal controller matrices using state feedback
          and output injection matrices (continuous-time)

SB10SD    H2 optimal controller matrices for a normalized discrete-time system

SB10TD    H2 optimal controller matrices for a discrete-time system

SB10UD    Normalization of a system for H2 controller design

SB10VD    State feedback and output injection matrices for an H2 optimal
          state controller (continuous-time)

SB10WD    H2 optimal controller matrices using state feedback and
          output injection matrices (continuous-time)

SB10YD    Fitting frequency response data with a stable, minimum phase
          SISO system

SB10ZP    Transforming a SISO system into a stable and minimum phase one

Controller Reduction


SB16AY    Cholesky factors of the frequency-weighted controllability and 
          observability Grammians for controller reduction

SB16CY    Cholesky factors of controllability and observability Grammians
          of coprime factors of a state-feedback controller

SG - Generalized State-Space Synthesis

Generalized Lyapunov Equations


SG03AX   Solving a generalized discrete-time Lyapunov equation with 
         A quasi-triangular and E upper triangular

SG03AY   Solving a generalized continuous-time Lyapunov equation with 
         A quasi-triangular and E upper triangular

SG03BU   Solving (for Cholesky factor) stable generalized discrete-time 
         Lyapunov equations with A quasi-triangular, and E, B upper triangular

SG03BV   Solving (for Cholesky factor) stable generalized continuous-time 
         Lyapunov equations with A quasi-triangular, and E, B upper triangular

SG03BX   Solving (for Cholesky factor) stable generalized 2-by-2 Lyapunov equations

Generalized Sylvester Equations


SG03BW   Solving a generalized Sylvester equation with A quasi-triangular 
         and E upper triangular, for X m-by-n, n = 1 or 2

T - Transformation Routines

TB - State-Space

State-Space Transformations


TB01VD   Conversion of a discrete-time system to output normal form

TB01VY   Conversion of the output normal form of a discrete-time system 
         to a state-space representation

TB01XD   Special similarity transformation of the dual state-space system

TB01XZ   Special similarity transformation of the dual state-space system 
         (complex case)

TB01YD   Special similarity transformation of a state-space system

State-Space to Rational Matrix Conversion


TB04BV   Strictly proper part of a proper transfer function matrix 

TB04BW   Sum of a rational matrix and a real matrix 

TB04BX   Gain of a SISO linear system, given (A,b,c,d), its poles and zeros

TC - Polynomial Matrix

TD - Rational Matrix

TF - Time Response


TF01MX   Output response of a linear discrete-time system, given a 
         general system matrix (each output is a column of the result)

TF01MY   Output response of a linear discrete-time system, given the
         system matrices (each output is a column of the result)

TG - Generalized State-space

Generalized State-space Transformations


TG01HX   Orthogonal reduction of a descriptor system to a system with
         the same transfer-function matrix and without uncontrollable finite 
         eigenvalues

U - Utility Routines

UD - Numerical Data Handling

slicot-5.0+20101122/examples/000077500000000000000000000000001201767322700153645ustar00rootroot00000000000000slicot-5.0+20101122/examples/AB01MD.dat000077500000000000000000000001741201767322700167270ustar00rootroot00000000000000 AB01MD EXAMPLE PROGRAM DATA 3 0.0 I 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/AB01MD.res000077500000000000000000000007201201767322700167450ustar00rootroot00000000000000 AB01MD EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 3 The state dynamics matrix A of a controllable realization is 1.0000 1.4142 0.0000 2.8284 -1.0000 2.8284 0.0000 1.4142 1.0000 The input/state vector B of a controllable realization is -1.4142 0.0000 0.0000 The similarity transformation matrix Z is -0.7071 0.0000 -0.7071 0.0000 -1.0000 0.0000 -0.7071 0.0000 0.7071 slicot-5.0+20101122/examples/AB01ND.dat000077500000000000000000000002251201767322700167250ustar00rootroot00000000000000 AB01ND EXAMPLE PROGRAM DATA 3 2 0.0 I -1.0 0.0 0.0 -2.0 -2.0 -2.0 -1.0 0.0 -3.0 1.0 0.0 0.0 0.0 2.0 1.0 slicot-5.0+20101122/examples/AB01ND.res000077500000000000000000000010771201767322700167540ustar00rootroot00000000000000 AB01ND EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 2 The transformed state dynamics matrix of a controllable realization is -3.0000 2.2361 0.0000 -1.0000 and the dimensions of its diagonal blocks are 2 The transformed input/state matrix B of a controllable realization is 0.0000 -2.2361 1.0000 0.0000 The controllability index of the transformed system representation = 1 The similarity transformation matrix Z is 0.0000 1.0000 0.0000 -0.8944 0.0000 -0.4472 -0.4472 0.0000 0.8944 slicot-5.0+20101122/examples/AB01OD.dat000077500000000000000000000005011201767322700167230ustar00rootroot00000000000000 AB01OD EXAMPLE PROGRAM DATA 5 2 0.0 F N N 17.0 24.0 1.0 8.0 15.0 23.0 5.0 7.0 14.0 16.0 4.0 6.0 13.0 20.0 22.0 10.0 12.0 19.0 21.0 3.0 11.0 18.0 25.0 2.0 9.0 -1.0 -4.0 4.0 9.0 -9.0 -16.0 16.0 25.0 -25.0 -36.0 slicot-5.0+20101122/examples/AB01OD.res000077500000000000000000000010331201767322700167450ustar00rootroot00000000000000 AB01OD EXAMPLE PROGRAM RESULTS The transformed state transition matrix is 12.8848 3.2345 11.8211 3.3758 -0.8982 4.4741 -12.5544 5.3509 5.9403 1.4360 14.4576 7.6855 23.1452 26.3872 -29.9557 0.0000 1.4805 27.4668 22.6564 -0.0072 0.0000 0.0000 -30.4822 0.6745 18.8680 The transformed input matrix is 31.1199 47.6865 3.2480 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The number of stairs in the staircase form = 3 The dimensions of the stairs are 2 2 1 slicot-5.0+20101122/examples/AB04MD.dat000077500000000000000000000002501201767322700167250ustar00rootroot00000000000000 AB04MD EXAMPLE PROGRAM DATA 2 2 2 C 1.0D0 1.0D0 1.0 0.5 0.5 1.0 0.0 -1.0 1.0 0.0 -1.0 0.0 0.0 1.0 1.0 0.0 0.0 -1.0 slicot-5.0+20101122/examples/AB04MD.res000077500000000000000000000005141201767322700167510ustar00rootroot00000000000000 AB04MD EXAMPLE PROGRAM RESULTS The transformed state matrix is -1.0000 -4.0000 -4.0000 -1.0000 The transformed input matrix is 2.8284 0.0000 0.0000 -2.8284 The transformed output matrix is 0.0000 2.8284 -2.8284 0.0000 The transformed input/output matrix is -1.0000 0.0000 0.0000 -3.0000 slicot-5.0+20101122/examples/AB05MD.dat000077500000000000000000000005701201767322700167330ustar00rootroot00000000000000 AB05MD EXAMPLE PROGRAM DATA 3 2 2 3 2 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/AB05MD.res000077500000000000000000000015071201767322700167550ustar00rootroot00000000000000 AB05MD EXAMPLE PROGRAM RESULTS The state transition matrix of the cascaded system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 -3.0000 0.0000 0.0000 -3.0000 2.0000 -1.0000 1.0000 0.0000 1.0000 0.0000 2.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the cascaded system is 1.0000 2.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 -1.0000 0.0000 0.0000 2.0000 The state/output matrix of the cascaded system is 3.0000 -1.0000 1.0000 1.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the cascaded system is 1.0000 1.0000 0.0000 1.0000 slicot-5.0+20101122/examples/AB05ND.dat000077500000000000000000000005621201767322700167350ustar00rootroot00000000000000 AB05ND EXAMPLE PROGRAM DATA 3 2 2 3 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/AB05ND.res000077500000000000000000000015121201767322700167520ustar00rootroot00000000000000 AB05ND EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is -0.5000 -0.2500 -1.5000 -1.2500 -1.2500 0.7500 -1.5000 -0.2500 0.5000 -0.2500 -0.2500 -0.2500 1.0000 0.5000 2.0000 -0.5000 -0.5000 0.5000 0.0000 0.5000 0.0000 -3.5000 -0.5000 0.5000 -1.5000 1.2500 -0.5000 1.2500 0.2500 1.2500 0.0000 1.0000 0.0000 -1.0000 -2.0000 3.0000 The input/state matrix of the connected system is 0.5000 0.7500 0.5000 -0.2500 0.0000 0.5000 0.0000 0.5000 -0.5000 0.2500 0.0000 1.0000 The state/output matrix of the connected system is 1.5000 -1.2500 0.5000 -0.2500 -0.2500 -0.2500 0.0000 0.5000 0.0000 -0.5000 -0.5000 0.5000 The input/output matrix of the connected system is 0.5000 -0.2500 0.0000 0.5000 slicot-5.0+20101122/examples/AB05OD.dat000077500000000000000000000005701201767322700167350ustar00rootroot00000000000000 AB05OD EXAMPLE PROGRAM DATA 3 2 2 3 2 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/AB05OD.res000077500000000000000000000017321201767322700167570ustar00rootroot00000000000000 AB05OD EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the connected system is 1.0000 2.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 2.0000 The state/output matrix of the connected system is 3.0000 -2.0000 1.0000 1.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the connected system is 1.0000 0.0000 1.0000 1.0000 0.0000 1.0000 0.0000 1.0000 slicot-5.0+20101122/examples/AB05PD.dat000077500000000000000000000005741201767322700167420ustar00rootroot00000000000000 AB05PD EXAMPLE PROGRAM DATA 3 2 2 3 1.0D0 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/AB05PD.res000077500000000000000000000015121201767322700167540ustar00rootroot00000000000000 AB05PD EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the connected system is 1.0000 2.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 -1.0000 0.0000 0.0000 2.0000 The state/output matrix of the connected system is 3.0000 -2.0000 1.0000 1.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the connected system is 2.0000 1.0000 0.0000 2.0000 slicot-5.0+20101122/examples/AB05QD.dat000077500000000000000000000005761201767322700167450ustar00rootroot00000000000000 AB05QD EXAMPLE PROGRAM DATA 3 2 2 3 2 2 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/AB05QD.res000077500000000000000000000022221201767322700167540ustar00rootroot00000000000000 AB05QD EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the connected system is 1.0000 2.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 2.0000 The state/output matrix of the connected system is 3.0000 -2.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the connected system is 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/AB05RD.dat000077500000000000000000000005441201767322700167410ustar00rootroot00000000000000 AB05RD EXAMPLE PROGRAM DATA 3 2 2 2 2 1.0 1.0 O D 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 2.0 1.0 0.0 1.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 1.0 2.0 3.0 4.0 1.0 1.0 0.0 1.0 4.0 3.0 2.0 1.0 slicot-5.0+20101122/examples/AB05RD.res000077500000000000000000000010671201767322700167630ustar00rootroot00000000000000 AB05RD EXAMPLE PROGRAM RESULTS The reciprocal condition number of the matrix I - alpha*D*F is 0.2000 The state transition matrix of the closed-loop system is -4.8333 0.1667 -2.8333 -0.8333 0.1667 0.1667 -1.5000 0.5000 1.5000 The input/state matrix of the closed-loop system is -0.5000 -0.8333 0.5000 0.1667 -0.5000 -0.5000 The state/output matrix of the closed-loop system is 1.1667 -1.8333 -0.8333 1.8333 -1.1667 -0.1667 The input/output matrix of the closed-loop system is 0.5000 -0.8333 0.5000 -0.1667 slicot-5.0+20101122/examples/AB07MD.dat000077500000000000000000000002631201767322700167340ustar00rootroot00000000000000 AB07MD EXAMPLE PROGRAM DATA 3 1 2 D 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/AB07MD.res000077500000000000000000000005601201767322700167550ustar00rootroot00000000000000 AB07MD EXAMPLE PROGRAM RESULTS The dual state dynamics matrix is 1.0000 4.0000 0.0000 2.0000 -1.0000 0.0000 0.0000 0.0000 1.0000 The dual input/state matrix is 0.0000 0.0000 1.0000 0.0000 -1.0000 1.0000 The dual state/output matrix is 1.0000 0.0000 1.0000 The dual direct transmission matrix is 0.0000 1.0000 slicot-5.0+20101122/examples/AB07ND.dat000077500000000000000000000003101201767322700167260ustar00rootroot00000000000000 AB07ND EXAMPLE PROGRAM DATA 3 2 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 0.0 1.0 1.0 0.0 0.0 1.0 -1.0 0.0 0.0 1.0 4.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/AB07ND.res000077500000000000000000000007331201767322700167600ustar00rootroot00000000000000 AB07ND EXAMPLE PROGRAM RESULTS The state dynamics matrix of the inverse system is 1.0000 1.7500 0.2500 4.0000 -1.0000 -1.0000 0.0000 -0.2500 1.2500 The input/state matrix of the inverse system is -0.2500 0.0000 0.0000 -1.0000 -0.2500 0.0000 The state/output matrix of the inverse system is 0.0000 0.2500 -0.2500 0.0000 0.0000 1.0000 The feedthrough matrix of the inverse system is 0.2500 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/AB08ND.dat000077500000000000000000000007761201767322700167470ustar00rootroot00000000000000 AB08ND EXAMPLE PROGRAM DATA 6 2 3 0.0 N 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 3.0 0.0 0.0 0.0 0.0 0.0 0.0 -4.0 0.0 0.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 0.0 0.0 3.0 0.0 -1.0 -1.0 0.0 1.0 -1.0 0.0 0.0 0.0 1.0 -1.0 -1.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 slicot-5.0+20101122/examples/AB08ND.res000077500000000000000000000015551201767322700167640ustar00rootroot00000000000000 AB08ND EXAMPLE PROGRAM RESULTS The left Kronecker indices of (A,C) are 1 2 2 The dimension of the observable subspace = 5 The output decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -1.0000 The right Kronecker indices of (A,B) are 2 3 The dimension of the controllable subspace = 5 The input decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -4.0000 The number of finite invariant zeros = 2 The finite invariant zeros are real part imag part 2.0000 -1.0000 which correspond to the generalized eigenvalues of (lambda*BF - AF). The number of infinite zeros = 2 The orders of the infinite zeros are 1 1 The number of right Kronecker indices = 0 The number of left Kronecker indices = 1 The left Kronecker (row) indices of (A,B,C,D) are 2 slicot-5.0+20101122/examples/AB08NZ.dat000077500000000000000000000015441201767322700167670ustar00rootroot00000000000000 AB08NZ EXAMPLE PROGRAM DATA 6 2 3 0.0 N (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (3.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-4.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (3.0,0.0) (0.0,0.0) (-1.0,0.0) (-1.0,0.0) (0.0,0.0) (1.0,0.0) (-1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (-1.0,0.0) (-1.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) slicot-5.0+20101122/examples/AB08NZ.res000077500000000000000000000016331201767322700170070ustar00rootroot00000000000000 AB08NZ EXAMPLE PROGRAM RESULTS The left Kronecker indices of (A,C) are 1 2 2 The dimension of the observable subspace = 5 The output decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -1.0000 +0.0000i The right Kronecker indices of (A,B) are 2 3 The dimension of the controllable subspace = 5 The input decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -4.0000 +0.0000i The number of finite invariant zeros = 2 The finite invariant zeros are real part imag part 2.0000 +0.0000i -1.0000 +0.0000i which correspond to the generalized eigenvalues of (lambda*BF - AF). The number of infinite zeros = 2 The orders of the infinite zeros are 1 1 The number of right Kronecker indices = 0 The number of left Kronecker indices = 1 The left Kronecker (row) indices of (A,B,C,D) are 2 slicot-5.0+20101122/examples/AB09AD.dat000077500000000000000000000014641201767322700167260ustar00rootroot00000000000000 AB09AD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 1.E-1 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09AD.res000077500000000000000000000013621201767322700167440ustar00rootroot00000000000000 AB09AD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values HSV are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 The reduced state dynamics matrix Ar is 1.3451 5.0399 0.0000 0.0000 4.5315 -4.0214 -3.6604 0.0000 0.0000 -0.9056 0.0000 0.0000 0.5124 1.7910 0.0000 0.0000 0.0000 -4.2167 -2.9900 0.0000 1.2402 1.6416 0.0000 0.0000 -0.0586 The reduced input/state matrix Br is -0.3857 0.3857 -3.1753 3.1753 -0.7447 -0.7447 -3.6872 -3.6872 1.8197 -1.8197 The reduced state/output matrix Cr is -0.6704 0.1828 -0.6582 0.2222 -0.0104 0.1089 0.4867 0.0000 0.0000 0.8651 0.6704 -0.1828 -0.6582 0.2222 0.0104 slicot-5.0+20101122/examples/AB09BD.dat000077500000000000000000000015701201767322700167250ustar00rootroot00000000000000 AB09BD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 1.E-1 1.E-14 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09BD.res000077500000000000000000000015201201767322700167410ustar00rootroot00000000000000 AB09BD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 The reduced state dynamics matrix Ar is 1.3960 5.1248 0.0000 0.0000 4.4331 -4.1411 -3.8605 0.0000 0.0000 -0.6738 0.0000 0.0000 0.5847 1.9230 0.0000 0.0000 0.0000 -4.3823 -3.2922 0.0000 1.3261 1.7851 0.0000 0.0000 -0.2249 The reduced input/state matrix Br is -0.2901 0.2901 -3.4004 3.4004 -0.6379 -0.6379 -3.9315 -3.9315 1.9813 -1.9813 The reduced state/output matrix Cr is -0.6570 0.2053 -0.6416 0.2526 -0.0364 0.1094 0.4875 0.0000 0.0000 0.8641 0.6570 -0.2053 -0.6416 0.2526 0.0364 The reduced input/output matrix Dr is 0.0498 -0.0007 0.0010 -0.0010 -0.0007 0.0498 slicot-5.0+20101122/examples/AB09CD.dat000077500000000000000000000015541201767322700167300ustar00rootroot00000000000000 AB09CD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 1.E-1 1.E-14 C N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09CD.res000077500000000000000000000015201201767322700167420ustar00rootroot00000000000000 AB09CD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 The reduced state dynamics matrix Ar is -0.5038 -5.3070 -3.2250 0.0000 0.0000 1.8355 -0.5038 -2.6289 0.0000 0.0000 0.0000 0.0000 -1.5171 0.0000 0.0000 0.0000 0.0000 0.0000 -1.2925 -9.0718 0.0000 0.0000 0.0000 0.5047 -1.2925 The reduced input/state matrix Br is -1.5343 1.5343 -0.3614 0.3614 -1.1096 1.1096 -4.5325 -4.5325 -0.7396 -0.7396 The reduced state/output matrix Cr is 1.8971 -0.3055 -2.1124 0.4421 -2.1023 -0.0394 1.1112 -0.3119 0.0000 0.0000 -1.8971 0.3055 2.1124 0.4421 -2.1023 The reduced input/output matrix Dr is 0.0126 -0.0126 0.0005 -0.0005 -0.0126 0.0126 slicot-5.0+20101122/examples/AB09DD.dat000077500000000000000000000016371201767322700167330ustar00rootroot00000000000000 AB09DD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 5 C -0.04165 4.9200 -4.9200 0 0 0 0 0 -3.3300 0 0 0 3.3300 0 0.5450 0 0 -0.5450 0 0 0 0 0 4.9200 -0.04165 4.9200 0 0 0 0 0 0 -3.3300 0 3.3300 -5.2100 0 0 0 0 -12.5000 0 0 0 0 -5.2100 0 0 -12.5000 0 0 0 0 0 0 0 0 0 0 12.5000 0 0 12.5000 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 slicot-5.0+20101122/examples/AB09DD.res000077500000000000000000000014071201767322700167470ustar00rootroot00000000000000 AB09DD EXAMPLE PROGRAM RESULTS The computed reciprocal condition number = 1.00000D+00 The reduced state dynamics matrix Ar is -0.0416 4.9200 -4.9200 0.0000 0.0000 -1.3879 -3.3300 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 4.9200 -0.0416 4.9200 0.0000 0.0000 0.0000 -1.3879 -3.3300 The reduced input/state matrix Br is 0.0000 0.0000 3.3300 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 The reduced state/output matrix Cr is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 The reduced input/output matrix Dr is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09ED.dat000077500000000000000000000015411201767322700167260ustar00rootroot00000000000000 AB09ED EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -0.6D0 1.E-1 1.E-14 C N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09ED.res000077500000000000000000000015231201767322700167470ustar00rootroot00000000000000 AB09ED EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of ALPHA-stable part are 1.9178 0.8621 0.7666 0.0336 0.0246 The reduced state dynamics matrix Ar is -0.5181 -1.1084 0.0000 0.0000 0.0000 8.8157 -0.5181 0.0000 0.0000 0.0000 0.0000 0.0000 -1.2769 7.3264 0.0000 0.0000 0.0000 -0.6203 -1.2769 0.0000 0.0000 0.0000 0.0000 0.0000 -1.5496 The reduced input/state matrix Br is -1.2837 1.2837 -0.7522 0.7522 3.2016 3.2016 -0.7640 -0.7640 1.3415 -1.3415 The reduced state/output matrix Cr is -0.1380 -0.6445 -0.6247 -2.0857 -0.8964 0.6246 0.0196 0.0000 0.0000 0.6131 0.1380 0.6445 -0.6247 -2.0857 0.8964 The reduced input/output matrix Dr is 0.0168 -0.0168 0.0008 -0.0008 -0.0168 0.0168 slicot-5.0+20101122/examples/AB09FD.dat000077500000000000000000000014571201767322700167350ustar00rootroot00000000000000 AB08FD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -1.e-1 .1 1.E-10 C L I B S A -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09FD.res000077500000000000000000000014011201767322700167430ustar00rootroot00000000000000 AB09FD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of coprime factors are 13.6047 9.4106 1.7684 0.7456 0.6891 0.0241 0.0230 The reduced state dynamics matrix Ar is 0.0520 -0.1491 0.0037 -0.0232 0.0168 0.2340 0.2618 0.0010 -0.0153 -0.0318 0.1197 0.0075 -0.5752 2.0119 -0.7779 0.1571 -0.2019 -2.1282 -2.1192 -0.3618 0.0368 -0.4810 0.8395 -0.2790 -2.8796 The reduced input/state matrix Br is 1.0454 0.5860 -0.0489 -1.9194 -1.4282 0.0541 -1.6144 -0.7533 0.5916 -1.9242 The reduced state/output matrix Cr is 0.4368 0.1122 -1.2917 1.5888 -0.6354 1.1170 0.3963 0.6115 0.1249 -0.0859 0.0756 -1.8904 0.0144 0.7964 1.9085 slicot-5.0+20101122/examples/AB09GD.dat000077500000000000000000000015621201767322700167330ustar00rootroot00000000000000 AB08GD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -1.e-1 .1 1.E-10 1.E-10 C L I B S A -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09GD.res000077500000000000000000000015431201767322700167530ustar00rootroot00000000000000 AB09GD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of coprime factors are 13.6047 9.4106 1.7684 0.7456 0.6891 0.0241 0.0230 The reduced state dynamics matrix Ar is 0.0521 -0.1491 0.0032 -0.0242 0.0181 0.2341 0.2615 0.0009 -0.0171 -0.0362 0.1170 0.0076 -0.5471 2.0904 -0.8098 0.1675 -0.2122 -2.2113 -2.4097 -0.4139 0.0390 -0.5061 0.8787 -0.3166 -3.2955 The reduced input/state matrix Br is 1.0449 0.5863 -0.0490 -1.9210 -1.3930 0.0540 -1.7206 -0.8039 0.6358 -2.0542 The reduced state/output matrix Cr is 0.4331 0.1125 -1.2534 1.6965 -0.6773 1.1171 0.3963 0.6102 0.1213 -0.0841 0.0736 -1.8815 0.0134 0.8457 2.0413 The reduced input/output matrix Dr is 0.0480 0.0003 -0.0017 0.0001 0.0005 0.0460 slicot-5.0+20101122/examples/AB09HD.dat000077500000000000000000000015621201767322700167340ustar00rootroot00000000000000 AB09HD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 0.0 1.0 0.1E0 0.0 C F N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09HD.res000077500000000000000000000015601201767322700167530ustar00rootroot00000000000000 AB09HD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The stochastic Hankel singular values of ALPHA-stable part are 0.8803 0.8506 0.8038 0.4494 0.3973 0.0214 0.0209 The reduced state dynamics matrix Ar is 1.2729 0.0000 6.5947 0.0000 -3.4229 0.0000 0.8169 0.0000 2.4821 0.0000 -2.9889 0.0000 -2.9028 0.0000 -0.3692 0.0000 -3.3921 0.0000 -3.1126 0.0000 -1.4767 0.0000 -2.0339 0.0000 -0.6107 The reduced input/state matrix Br is 0.1331 -0.1331 -0.0862 -0.0862 -2.6777 2.6777 -3.5767 -3.5767 -2.3033 2.3033 The reduced state/output matrix Cr is -0.6907 -0.6882 0.0779 0.0958 -0.0038 0.0676 0.0000 0.6532 0.0000 -0.7522 0.6907 -0.6882 -0.0779 0.0958 0.0038 The reduced input/output matrix Dr is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09ID.dat000077500000000000000000000013401201767322700167270ustar00rootroot00000000000000 AB09ID EXAMPLE PROGRAM DATA (Continuous system) 3 1 1 6 1 0 0 2 0.0 0.0 0.0 0.1E0 0.0 C S S F L S F -26.4000 6.4023 4.3868 32.0000 0 0 0 8.0000 0 16 0 0 9.2994 1.1624 0.1090 0 -1.0000 0 4.0000 -9.2994 -1.1624 -0.1090 0 2.0000 0 -9.2994 -1.1624 -0.1090 0 0 -3.0000 -9.2994 -1.1624 -0.1090 16.0000 16.0000 16.0000 -26.4000 6.4023 4.3868 0 0 0 32.0000 0 0 0 0 0 0 8.0000 0 1 1 1 0 0 0 1 1 1 0 0 0 0 slicot-5.0+20101122/examples/AB09ID.res000077500000000000000000000006211201767322700167510ustar00rootroot00000000000000 AB09ID EXAMPLE PROGRAM RESULTS The order of reduced model = 2 The Hankel singular values of weighted ALPHA-stable part are 3.8253 0.2005 The reduced state dynamics matrix Ar is 9.1900 0.0000 0.0000 -34.5297 The reduced input/state matrix Br is 11.9593 16.9329 The reduced state/output matrix Cr is 2.8955 6.9152 The reduced input/output matrix Dr is 0.0000 slicot-5.0+20101122/examples/AB09JD.dat000077500000000000000000000013141201767322700167310ustar00rootroot00000000000000 AB09JD EXAMPLE PROGRAM DATA (Continuous system) 6 1 1 2 0 0 0.0 1.E-1 1.E-14 V N I C S A -3.8637 -7.4641 -9.1416 -7.4641 -3.8637 -1.0000 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0.2000 -1.0000 1.0000 0 1 0 -1.8000 0 1 slicot-5.0+20101122/examples/AB09JD.res000077500000000000000000000011111201767322700167450ustar00rootroot00000000000000 AB09JD EXAMPLE PROGRAM RESULTS The order of reduced model = 4 The Hankel singular values of weighted ALPHA-stable part are 2.6790 2.1589 0.8424 0.1929 0.0219 0.0011 The reduced state dynamics matrix Ar is -0.2391 0.3072 1.1630 1.1967 -2.9709 -0.2391 2.6270 3.1027 0.0000 0.0000 -0.5137 -1.2842 0.0000 0.0000 0.1519 -0.5137 The reduced input/state matrix Br is -1.0497 -3.7052 0.8223 0.7435 The reduced state/output matrix Cr is -0.4466 0.0143 -0.4780 -0.2013 The reduced input/output matrix Dr is 0.0219 slicot-5.0+20101122/examples/AB09KD.dat000077500000000000000000000013111201767322700167270ustar00rootroot00000000000000 AB09KD EXAMPLE PROGRAM DATA (Continuous system) 6 1 1 2 0 0 0.0 1.E-1 1.E-14 N C L S A -3.8637 -7.4641 -9.1416 -7.4641 -3.8637 -1.0000 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0.2000 -1.0000 1.0000 0 1 0 -1.8000 0 1 slicot-5.0+20101122/examples/AB09KD.res000077500000000000000000000011111201767322700167460ustar00rootroot00000000000000 AB09KD EXAMPLE PROGRAM RESULTS The order of reduced model = 4 The Hankel singular values of weighted ALPHA-stable part are 2.6790 2.1589 0.8424 0.1929 0.0219 0.0011 The reduced state dynamics matrix Ar is -0.2391 0.3072 1.1630 1.1967 -2.9709 -0.2391 2.6270 3.1027 0.0000 0.0000 -0.5137 -1.2842 0.0000 0.0000 0.1519 -0.5137 The reduced input/state matrix Br is -1.0497 -3.7052 0.8223 0.7435 The reduced state/output matrix Cr is -0.4466 0.0143 -0.4780 -0.2013 The reduced input/output matrix Dr is 0.0219 slicot-5.0+20101122/examples/AB09MD.dat000077500000000000000000000014471201767322700167430ustar00rootroot00000000000000 AB09MD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -.6D0 1.D-1 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09MD.res000077500000000000000000000013611201767322700167570ustar00rootroot00000000000000 AB09MD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of ALPHA-stable part are 1.9178 0.8621 0.7666 0.0336 0.0246 The reduced state dynamics matrix Ar is -0.5181 -1.1084 0.0000 0.0000 0.0000 8.8157 -0.5181 0.0000 0.0000 0.0000 0.0000 0.0000 0.5124 0.0000 1.7910 0.0000 0.0000 0.0000 -1.4460 0.0000 0.0000 0.0000 -4.2167 0.0000 -2.9900 The reduced input/state matrix Br is -1.2837 1.2837 -0.7522 0.7522 -0.7447 -0.7447 1.9275 -1.9275 -3.6872 -3.6872 The reduced state/output matrix Cr is -0.1380 -0.6445 -0.6582 -0.5771 0.2222 0.6246 0.0196 0.0000 0.4131 0.0000 0.1380 0.6445 -0.6582 0.5771 0.2222 slicot-5.0+20101122/examples/AB09ND.dat000077500000000000000000000015531201767322700167420ustar00rootroot00000000000000 AB09ND EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -.6D0 1.D-1 1.E-14 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB09ND.res000077500000000000000000000015231201767322700167600ustar00rootroot00000000000000 AB09ND EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of ALPHA-stable part are 1.9178 0.8621 0.7666 0.0336 0.0246 The reduced state dynamics matrix Ar is -0.5181 -1.1084 0.0000 0.0000 0.0000 8.8157 -0.5181 0.0000 0.0000 0.0000 0.0000 0.0000 0.5847 0.0000 1.9230 0.0000 0.0000 0.0000 -1.6606 0.0000 0.0000 0.0000 -4.3823 0.0000 -3.2922 The reduced input/state matrix Br is -1.2837 1.2837 -0.7522 0.7522 -0.6379 -0.6379 2.0656 -2.0656 -3.9315 -3.9315 The reduced state/output matrix Cr is -0.1380 -0.6445 -0.6416 -0.6293 0.2526 0.6246 0.0196 0.0000 0.4107 0.0000 0.1380 0.6445 -0.6416 0.6293 0.2526 The reduced input/output matrix Dr is 0.0582 -0.0090 0.0015 -0.0015 -0.0090 0.0582 slicot-5.0+20101122/examples/AB13AD.dat000077500000000000000000000014231201767322700167140ustar00rootroot00000000000000 AB13AD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0.0 C N -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB13AD.res000077500000000000000000000003201201767322700167300ustar00rootroot00000000000000 AB13AD EXAMPLE PROGRAM RESULTS The Hankel-norm of the ALPHA-projection = 2.51388D+00 The Hankel singular values of ALPHA-projection are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 slicot-5.0+20101122/examples/AB13BD.dat000077500000000000000000000015271201767322700167220ustar00rootroot00000000000000 AB13BD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 1.E-10 C L -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/AB13BD.res000077500000000000000000000001151201767322700167330ustar00rootroot00000000000000 AB13BD EXAMPLE PROGRAM RESULTS The L2-norm of the system = 7.93948D+00 slicot-5.0+20101122/examples/AB13CD.dat000077500000000000000000000006121201767322700167150ustar00rootroot00000000000000 AB13CD EXAMPLE PROGRAM DATA 6 1 1 0.0 1.0 0.0 0.0 0.0 0.0 -0.5 -0.0002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -1.0 -0.00002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -2.0 -0.000002 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 0.000000001 slicot-5.0+20101122/examples/AB13CD.res000077500000000000000000000002031201767322700167320ustar00rootroot00000000000000 AB13CD EXAMPLE PROGRAM RESULTS The H_infty norm of the system is 0.5000000006D+06 The peak frequency is 0.1414213562D+01 slicot-5.0+20101122/examples/AB13DD.dat000077500000000000000000000006641201767322700167250ustar00rootroot00000000000000 AB13CD EXAMPLE PROGRAM DATA 6 1 1 0.0 1.0 0.000000001 C I N D 0.0 1.0 0.0 0.0 0.0 0.0 -0.5 -0.0002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -1.0 -0.00002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -2.0 -0.000002 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 slicot-5.0+20101122/examples/AB13DD.res000077500000000000000000000002031201767322700167330ustar00rootroot00000000000000 AB13DD EXAMPLE PROGRAM RESULTS The L_infty norm of the system is 0.5000000001D+06 The peak frequency is 0.1414213562D+01 slicot-5.0+20101122/examples/AB13ED.dat000077500000000000000000000004011201767322700167130ustar00rootroot00000000000000AB13ED EXAMPLE PROGRAM DATA 5, 9.0D0 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 slicot-5.0+20101122/examples/AB13ED.res000077500000000000000000000011431201767322700167400ustar00rootroot00000000000000 AB13ED EXAMPLE PROGRAM RESULTS N = 5 TOL = 0.900D+01 Matrix A ( 5X 5) 1 2 3 4 5 1 0.1000000D+00 0.1000000D+01 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.1000000D+00 0.1000000D+01 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.1000000D+00 0.1000000D+01 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+00 0.1000000D+01 5 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+00 LOW = 0.20929379255D-05 HIGH = 0.20793050504D-04 slicot-5.0+20101122/examples/AB13FD.dat000077500000000000000000000004321201767322700167200ustar00rootroot00000000000000AB13FD EXAMPLE PROGRAM DATA 4 0.0D-00 0.0D-00 246.500 242.500 202.500 -197.500 -252.500 -248.500 -207.500 202.500 -302.500 -297.500 -248.500 242.500 -307.500 -302.500 -252.500 246.500 slicot-5.0+20101122/examples/AB13FD.res000077500000000000000000000007271201767322700167500ustar00rootroot00000000000000 AB13FD EXAMPLE PROGRAM RESULTS N = 4 TOL = 0.000D+00 A ( 4X 4) 1 2 3 4 1 0.2465000D+03 0.2425000D+03 0.2025000D+03 -0.1975000D+03 2 -0.2525000D+03 -0.2485000D+03 -0.2075000D+03 0.2025000D+03 3 -0.3025000D+03 -0.2975000D+03 -0.2485000D+03 0.2425000D+03 4 -0.3075000D+03 -0.3025000D+03 -0.2525000D+03 0.2465000D+03 Stability radius : 0.39196472317D-02 Minimizing omega : 0.98966520430D+00 slicot-5.0+20101122/examples/AB13MD.dat000077500000000000000000000012741201767322700167340ustar00rootroot00000000000000 AB13MD EXAMPLE PROGRAM DATA 6 5 1 1 2 1 1 1 1 2 2 2 (-1.0D0,6.0D0) (2.0D0,-3.0D0) (3.0D0,8.0D0) (3.0D0,8.0D0) (-5.0D0,-9.0D0) (-6.0D0,2.0D0) (4.0D0,2.0D0) (-2.0D0,5.0D0) (-6.0D0,-7.0D0) (-4.0D0,11.0D0) (8.0D0,-7.0D0) (12.0D0,-1.0D0) (5.0D0,-4.0D0) (-4.0D0,-8.0D0) (1.0D0,-3.0D0) (-6.0D0,14.0D0) (2.0D0,-5.0D0) (4.0D0,16.0D0) (-1.0D0,6.0D0) (2.0D0,-3.0D0) (3.0D0,8.0D0) (3.0D0,8.0D0) (-5.0D0,-9.0D0) (-6.0D0,2.0D0) (4.0D0,2.0D0) (-2.0D0,5.0D0) (-6.0D0,-7.0D0) (-4.0D0,11.0D0) (8.0D0,-7.0D0) (12.0D0,-1.0D0) (5.0D0,-4.0D0) (-4.0D0,-8.0D0) (1.0D0,-3.0D0) (-6.0D0,14.0D0) (2.0D0,-5.0D0) (4.0D0,16.0D0) slicot-5.0+20101122/examples/AB13MD.res000077500000000000000000000001431201767322700167470ustar00rootroot00000000000000 AB13MD EXAMPLE PROGRAM RESULTS The value of the structured singular value is 0.4174753408D+02 slicot-5.0+20101122/examples/AG08BD.dat000077500000000000000000000026521201767322700167330ustar00rootroot00000000000000 AG08BD EXAMPLE PROGRAM DATA 9 9 3 3 1.e-7 N 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 -1 0 0 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 1 1 0 3 4 0 0 2 0 1 0 0 4 0 0 2 0 0 0 1 0 -1 4 0 -2 2 1 2 -2 0 -1 -2 0 0 0 slicot-5.0+20101122/examples/AG08BD.res000077500000000000000000000032451201767322700167530ustar00rootroot00000000000000 AG08BD EXAMPLE PROGRAM RESULTS The number of infinite poles = 6 0 infinite pole(s) of order 1 3 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of A-lambda*E are 3 3 3 The system has no finite poles The number of unobservable infinite poles = 4 0 infinite pole(s) of order 1 2 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E;C] are 1 3 3 The left Kronecker indices of [A-lambda*E;C] are 0 1 1 The system (A-lambda*E,C) has no finite output decoupling zeros The number of uncontrollable infinite poles = 0 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E,B] are 1 1 1 The right Kronecker indices of [A-lambda*E,B] are 2 2 2 The system (A-lambda*E,B) has no finite input decoupling zeros Normal rank of transfer function matrix = 2 The number of finite zeros = 1 The finite zeros are the eigenvalues of the pair (Af,Ef) The matrix Af is 0.7705 The matrix Ef is 0.7705 Finite zeros real part imag part 1.0000 The number of infinite zeros = 2 0 infinite zero(s) of order 1 1 infinite zero(s) of order 2 The number of infinite Kronecker blocks = 5 Multiplicities of infinite eigenvalues of [A-lambda*E,B;C,D] are 1 1 1 1 3 The number of right Kronecker indices = 1 Right Kronecker indices of [A-lambda*E,B;C,D] are 2 The number of left Kronecker indices = 1 The left Kronecker indices of [A-lambda*E,B;C,D] are 1 slicot-5.0+20101122/examples/AG08BZ.dat000077500000000000000000000036261201767322700167630ustar00rootroot00000000000000 AG08BZ EXAMPLE PROGRAM DATA 9 9 3 3 1.e-7 N (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (-1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (-1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (-1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (1,0) (0,0) (3,0) (4,0) (0,0) (0,0) (2,0) (0,0) (1,0) (0,0) (0,0) (4,0) (0,0) (0,0) (2,0) (0,0) (0,0) (0,0) (1,0) (0,0) (-1,0) (4,0) (0,0) (-2,0) (2,0) (1,0) (2,0) (-2,0) (0,0) (-1,0) (-2,0) (0,0) (0,0) (0,0) slicot-5.0+20101122/examples/AG08BZ.res000077500000000000000000000033101201767322700167720ustar00rootroot00000000000000 AG08BZ EXAMPLE PROGRAM RESULTS The number of infinite poles = 6 0 infinite pole(s) of order 1 3 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of A-lambda*E are 3 3 3 The system has no finite poles The number of unobservable infinite poles = 4 0 infinite pole(s) of order 1 2 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E;C] are 1 3 3 The left Kronecker indices of [A-lambda*E;C] are 0 1 1 The system (A-lambda*E,C) has no finite output decoupling zeros The number of uncontrollable infinite poles = 0 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E,B] are 1 1 1 The right Kronecker indices of [A-lambda*E,B] are 2 2 2 The system (A-lambda*E,B) has no finite input decoupling zeros Normal rank of transfer function matrix = 2 The number of finite zeros = 1 The finite zeros are the eigenvalues of the pair (Af,Ef) The matrix Af is -0.7705 +0.0000i The matrix Ef is -0.7705 +0.0000i Finite zeros real part imag part 1.0000 +0.0000i The number of infinite zeros = 2 0 infinite zero(s) of order 1 1 infinite zero(s) of order 2 The number of infinite Kronecker blocks = 5 Multiplicities of infinite eigenvalues of [A-lambda*E,B;C,D] are 1 1 1 1 3 The number of right Kronecker indices = 1 Right Kronecker indices of [A-lambda*E,B;C,D] are 2 The number of left Kronecker indices = 1 The left Kronecker indices of [A-lambda*E,B;C,D] are 1 slicot-5.0+20101122/examples/BB01AD.dat000077500000000000000000000001101201767322700167020ustar00rootroot00000000000000BB01AD EXAMPLE PROGRAM DATA N 2 3 6 .T. .T. .T. .F. .F. .T. 1 .1234 0 slicot-5.0+20101122/examples/BB01AD.res000077500000000000000000000010051201767322700167270ustar00rootroot00000000000000 BB01AD EXAMPLE PROGRAM RESULTS Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 2 A = 0.0000 0.1234 0.0000 0.0000 B is not provided. C = 1.0000 0.0000 0.0000 1.0000 G = 0.0000 0.0000 0.0000 1.0000 Q is not provided. W = 1.0000 0.0000 0.0000 1.0000 R is not provided. X = 9.0486 1.0000 1.0000 1.1166 slicot-5.0+20101122/examples/BB02AD.dat000077500000000000000000000001121201767322700167050ustar00rootroot00000000000000BB02AD EXAMPLE PROGRAM DATA N 2 3 7 .T. .T. .T. .F. .F. .T. .T. 1 .1234 0 slicot-5.0+20101122/examples/BB02AD.res000077500000000000000000000007631201767322700167420ustar00rootroot00000000000000 BB02AD EXAMPLE PROGRAM RESULTS increasingly bad scaled system as eps -> oo Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 2 A = 0.0000 0.1234 0.0000 0.0000 B = 0.0000 1.0000 C is not provided. G is not provided. Q = 1.0000 0.0000 0.0000 1.0000 Q0 is not provided. R = 1.0000 S = 0.0000 0.0000 X = 1.0000 0.0000 0.0000 1.0152 slicot-5.0+20101122/examples/BB03AD.dat000077500000000000000000000000641201767322700167140ustar00rootroot00000000000000BB03AD EXAMPLE PROGRAM DATA N 4 1 2 .15D1 .15D1 1 5 slicot-5.0+20101122/examples/BB03AD.res000077500000000000000000000017461201767322700167450ustar00rootroot00000000000000 BB03AD EXAMPLE PROGRAM RESULTS CTLEX: Example 4.1 Order of matrix A: N = 5 Number of rows in matrix B: M = 1 E is the identity matrix. A = -3.6360 -0.6921 -1.1933 -0.8137 0.3507 0.1406 -2.9375 0.9063 0.1562 0.3438 -2.5735 -1.4421 -2.8183 -1.1887 1.2257 -0.3779 0.0810 0.5544 -1.5891 0.0660 0.8961 1.1586 1.6279 0.5631 -2.2066 B = -3.6914 -3.9753 -0.0247 -1.9012 1.1111 Y = -13.6261 -14.6743 -0.0911 -7.0181 4.1015 -14.6743 -15.8031 -0.0982 -7.5580 4.4170 -0.0911 -0.0982 -0.0006 -0.0469 0.0274 -7.0181 -7.5580 -0.0469 -3.6147 2.1125 4.1015 4.4170 0.0274 2.1125 -1.2346 X = 1.7737 1.9307 -0.0703 1.0497 -0.4681 1.9307 2.1036 -0.0752 1.1489 -0.5069 -0.0703 -0.0752 0.0076 -0.0428 0.0178 1.0497 1.1489 -0.0428 0.6509 -0.2651 -0.4681 -0.5069 0.0178 -0.2651 0.1284 U is not provided. slicot-5.0+20101122/examples/BB04AD.dat000077500000000000000000000000641201767322700167150ustar00rootroot00000000000000BB04AD EXAMPLE PROGRAM DATA N 4 1 2 .15D1 .15D1 1 5 slicot-5.0+20101122/examples/BB04AD.res000077500000000000000000000017461201767322700167460ustar00rootroot00000000000000 BB04AD EXAMPLE PROGRAM RESULTS DTLEX: Example 4.1 Order of matrix A: N = 5 Number of rows in matrix B: M = 1 E is the identity matrix. A = 0.4562 0.0308 0.1990 0.0861 0.0217 0.0637 0.5142 -0.1828 0.0096 -0.1148 0.3139 0.1287 0.3484 0.1653 -0.1975 0.1500 0.0053 -0.1838 0.2501 -0.0687 0.0568 -0.1006 -0.3735 -0.0202 0.2285 B = 0.3086 0.0247 -0.4691 0.1728 -0.3704 Y = -0.0953 -0.0076 0.1448 -0.0533 0.1143 -0.0076 -0.0006 0.0116 -0.0043 0.0091 0.1448 0.0116 -0.2201 0.0811 -0.1738 -0.0533 -0.0043 0.0811 -0.0299 0.0640 0.1143 0.0091 -0.1738 0.0640 -0.1372 X = 0.0953 0.0076 -0.1448 0.0533 -0.1143 0.0076 0.0006 -0.0116 0.0043 -0.0091 -0.1448 -0.0116 0.2201 -0.0811 0.1738 0.0533 0.0043 -0.0811 0.0299 -0.0640 -0.1143 -0.0091 0.1738 -0.0640 0.1372 U is not provided. slicot-5.0+20101122/examples/BD01AD.dat000077500000000000000000000000421201767322700167100ustar00rootroot00000000000000BD01AD EXAMPLE PROGRAM DATA D 1 1 slicot-5.0+20101122/examples/BD01AD.res000077500000000000000000000006141201767322700167360ustar00rootroot00000000000000 BD01AD EXAMPLE PROGRAM RESULTS Laub 1979, Ex.1 Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 2 E is the identity matrix. A = 0.0000 1.0000 0.0000 0.0000 B = 0.0000 1.0000 C = 1.0000 0.0000 0.0000 1.0000 D is of zeros. slicot-5.0+20101122/examples/BD02AD.dat000077500000000000000000000000421201767322700167110ustar00rootroot00000000000000BD02AD EXAMPLE PROGRAM DATA D 1 1 slicot-5.0+20101122/examples/BD02AD.res000077500000000000000000000005711201767322700167410ustar00rootroot00000000000000 BD02AD EXAMPLE PROGRAM RESULTS Laub 1979, Ex. 2: uncontrollable-unobservable data Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 1 E is the identity matrix. A = 4.0000 3.0000 -4.5000 -3.5000 B = 1.0000 -1.0000 C = 3.0000 2.0000 D is of zeros. slicot-5.0+20101122/examples/DE01OD.dat000077500000000000000000000003001201767322700167260ustar00rootroot00000000000000 DE01OD EXAMPLE PROGRAM DATA 8 C 0.4862 0.2288 0.1948 0.3671 0.5788 0.6417 -0.5861 0.3875 0.8254 0.2380 0.1815 0.4682 0.2904 0.5312 -0.3599 0.6116 slicot-5.0+20101122/examples/DE01OD.res000077500000000000000000000002601201767322700167540ustar00rootroot00000000000000 DE01OD EXAMPLE PROGRAM RESULTS Convolution i A(i) 1 0.5844 2 0.5769 3 0.6106 4 1.0433 5 0.6331 6 0.4531 7 0.7027 8 0.9929 slicot-5.0+20101122/examples/DE01PD.dat000077500000000000000000000003061201767322700167350ustar00rootroot00000000000000 DE01PD EXAMPLE PROGRAM DATA 8 C N 0.4862 0.2288 0.1948 0.3671 0.5788 0.6417 -0.5861 0.3875 0.8254 0.2380 0.1815 0.4682 0.2904 0.5312 -0.3599 0.6116 slicot-5.0+20101122/examples/DE01PD.res000077500000000000000000000002601201767322700167550ustar00rootroot00000000000000 DE01PD EXAMPLE PROGRAM RESULTS Convolution i A(i) 1 0.5844 2 0.5769 3 0.6106 4 1.0433 5 0.6331 6 0.4531 7 0.7027 8 0.9929 slicot-5.0+20101122/examples/DF01MD.dat000077500000000000000000000003321201767322700167320ustar00rootroot00000000000000 DF01MD EXAMPLE PROGRAM DATA 17 1.0 C -0.1862 0.1288 0.3948 0.0671 0.6788 -0.2417 0.1861 0.8875 0.7254 0.9380 0.5815 -0.2682 0.4904 0.9312 -0.9599 -0.3116 0.8743 slicot-5.0+20101122/examples/DF01MD.res000077500000000000000000000005461201767322700167620ustar00rootroot00000000000000 DF01MD EXAMPLE PROGRAM RESULTS Components of cosine transform are i A(i) 1 28.0536 2 3.3726 3 -20.8158 4 6.0566 5 5.7317 6 -3.9347 7 -12.8074 8 -6.8780 9 16.2892 10 -17.0788 11 21.7836 12 -20.8203 13 -7.3277 14 -2.5325 15 -0.3636 16 7.8792 17 11.0048 slicot-5.0+20101122/examples/DG01MD.dat000077500000000000000000000003001201767322700167260ustar00rootroot00000000000000 DG01MD EXAMPLE PROGRAM DATA 8 D -0.1862 0.1288 0.3948 0.0671 0.6788 -0.2417 0.1861 0.8875 0.7254 0.9380 0.5815 -0.2682 0.4904 0.9312 -0.9599 -0.3116 slicot-5.0+20101122/examples/DG01MD.res000077500000000000000000000004731201767322700167620ustar00rootroot00000000000000 DG01MD EXAMPLE PROGRAM RESULTS Components of Fourier transform are i XR(i) XI(i) 1 1.9109 2.1311 2 -1.9419 -2.2867 3 -1.4070 -1.3728 4 2.2886 -0.6883 5 1.5059 1.3815 6 -2.2271 0.2915 7 0.1470 2.1274 8 -1.7660 -0.5533 slicot-5.0+20101122/examples/DG01ND.dat000077500000000000000000000003101201767322700167300ustar00rootroot00000000000000 DG01ND EXAMPLE PROGRAM DATA 8 D -0.1862 0.1288 0.3948 0.0671 0.6788 -0.2417 0.1861 0.8875 0.7254 0.9380 0.5815 -0.2682 0.4904 0.9312 -0.9599 -0.3116 slicot-5.0+20101122/examples/DG01ND.res000077500000000000000000000005261201767322700167620ustar00rootroot00000000000000 DG01ND EXAMPLE PROGRAM RESULTS Components of Fourier transform are i XR(i) XI(i) 1 4.0420 0.0000 2 -3.1322 -0.2421 3 0.1862 -1.4675 4 -2.1312 -1.1707 5 1.5059 -1.3815 6 2.1927 -0.1908 7 -1.4462 2.0327 8 -0.5757 1.4914 9 -0.2202 0.0000 slicot-5.0+20101122/examples/DG01OD.dat000077500000000000000000000001631201767322700167370ustar00rootroot00000000000000 DG01OD EXAMPLE 16 N N 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 slicot-5.0+20101122/examples/DG01OD.res000077500000000000000000000004461201767322700167640ustar00rootroot00000000000000 DG01OD EXAMPLE PROGRAM RESULTS Hartley transform i A(i) 1 136.0000 2 -48.2187 3 -27.3137 4 -19.9728 5 -16.0000 6 -13.3454 7 -11.3137 8 -9.5913 9 -8.0000 10 -6.4087 11 -4.6863 12 -2.6546 13 0.0000 14 3.9728 15 11.3137 16 32.2187 slicot-5.0+20101122/examples/DK01MD.dat000077500000000000000000000001701201767322700167370ustar00rootroot00000000000000 DK01MD EXAMPLE PROGRAM DATA 8 M 0.3262 0.8723 -0.7972 0.6673 -0.1722 0.3237 0.5263 -0.3275 slicot-5.0+20101122/examples/DK01MD.res000077500000000000000000000003341201767322700167620ustar00rootroot00000000000000 DK01MD EXAMPLE PROGRAM RESULTS Components of the windowing function are k A(k) 1 0.3262 2 0.8326 3 -0.6591 4 0.4286 5 -0.0754 6 0.0820 7 0.0661 8 -0.0262 slicot-5.0+20101122/examples/FB01QD.dat000077500000000000000000000010461201767322700167370ustar00rootroot00000000000000 FB01QD EXAMPLE PROGRAM DATA 4 2 2 K 0.0 N 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.2113 0.8497 0.7263 0.8833 0.7560 0.6857 0.1985 0.6525 0.0002 0.8782 0.5442 0.3076 0.3303 0.0683 0.2320 0.9329 0.5618 0.5042 0.5896 0.3493 0.6853 0.3873 0.8906 0.9222 1.0000 0.0000 0.0000 1.0000 0.3616 0.5664 0.5015 0.2693 0.2922 0.4826 0.4368 0.6325 0.9488 0.0000 0.3760 0.7340 slicot-5.0+20101122/examples/FB01QD.res000077500000000000000000000005221201767322700167560ustar00rootroot00000000000000 FB01QD EXAMPLE PROGRAM RESULTS The square root of the state covariance matrix is -1.2936 0.0000 0.0000 0.0000 -1.1382 -0.2579 0.0000 0.0000 -0.9622 -0.1529 0.2974 0.0000 -1.3076 0.0936 0.4508 -0.4897 The Kalman gain matrix is 0.3638 0.9469 0.3532 0.8179 0.2471 0.5542 0.1982 0.6471 slicot-5.0+20101122/examples/FB01RD.dat000077500000000000000000000010461201767322700167400ustar00rootroot00000000000000 FB01RD EXAMPLE PROGRAM DATA 4 2 2 K 0.0 N 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.2113 0.8497 0.7263 0.0000 0.7560 0.6857 0.1985 0.6525 0.0002 0.8782 0.5442 0.3076 0.3303 0.0683 0.2320 0.9329 0.5618 0.5042 0.5896 0.3493 0.6853 0.3873 0.8906 0.9222 1.0000 0.0000 0.0000 1.0000 0.3616 0.0000 0.0000 0.0000 0.2922 0.4826 0.0000 0.0000 0.9488 0.0000 0.3760 0.7340 slicot-5.0+20101122/examples/FB01RD.res000077500000000000000000000005221201767322700167570ustar00rootroot00000000000000 FB01RD EXAMPLE PROGRAM RESULTS The square root of the state covariance matrix is -1.7223 0.0000 0.0000 0.0000 -2.1073 0.5467 0.0000 0.0000 -1.7649 0.1412 -0.1710 0.0000 -1.8291 0.2058 -0.1497 0.7760 The Kalman gain matrix is -0.2135 1.6649 -0.2345 2.1442 -0.2147 1.7069 -0.1345 1.4777 slicot-5.0+20101122/examples/FB01SD.dat000077500000000000000000000011741201767322700167430ustar00rootroot00000000000000 FB01SD EXAMPLE PROGRAM DATA 4 2 2 X 0.0 P N 0.2113 0.7560 0.0002 0.3303 0.8497 0.6857 0.8782 0.0683 0.7263 0.1985 0.5442 0.2320 0.8833 0.6525 0.3076 0.9329 0.3616 0.5664 0.5015 0.2693 0.2922 0.4826 0.4368 0.6325 1.0000 0.0000 0.0000 1.0000 -0.8805 1.3257 2.1039 0.5207 -0.6075 1.0386 -0.8531 1.1688 1.1159 0.2305 0.0000 0.6597 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0019 0.5075 0.4076 0.8408 0.5017 0.9128 0.2129 0.5591 slicot-5.0+20101122/examples/FB01SD.res000077500000000000000000000006001201767322700167550ustar00rootroot00000000000000 FB01SD EXAMPLE PROGRAM RESULTS The inverse of the square root of the state covariance matrix is 0.6897 0.7721 0.7079 0.6102 0.0000 -0.3363 -0.2252 -0.2642 0.0000 0.0000 -0.1650 0.0319 0.0000 0.0000 0.0000 0.3708 The components of the estimated filtered state are k X(k) 1 -0.7125 2 -1.8324 3 1.7500 4 1.5854 slicot-5.0+20101122/examples/FB01TD.dat000077500000000000000000000011661201767322700167450ustar00rootroot00000000000000 FB01TD EXAMPLE PROGRAM DATA 4 2 2 X 0.0 N 0.2113 0.7560 0.0002 0.3303 0.8497 0.6857 0.8782 0.0683 0.7263 0.1985 0.5442 0.2320 0.0000 0.6525 0.3076 0.9329 0.3616 0.5664 0.5015 0.2693 0.2922 0.4826 0.4368 0.6325 1.0000 0.0000 0.0000 1.0000 -0.8805 1.3257 0.0000 0.5207 0.0000 0.0000 0.0000 0.0000 1.1159 0.2305 0.0000 0.6597 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0019 0.5075 0.4076 0.8408 0.5017 0.9128 0.2129 0.5591 slicot-5.0+20101122/examples/FB01TD.res000077500000000000000000000006001201767322700167560ustar00rootroot00000000000000 FB01TD EXAMPLE PROGRAM RESULTS The inverse of the square root of the state covariance matrix is -0.8731 -1.1461 -1.0260 -0.8901 0.0000 -0.2763 -0.1929 -0.3763 0.0000 0.0000 -0.1110 -0.1051 0.0000 0.0000 0.0000 0.3120 The components of the estimated filtered state are k X(k) 1 -2.0688 2 -0.7814 3 2.2181 4 0.9298 slicot-5.0+20101122/examples/FB01VD.dat000077500000000000000000000011441201767322700167430ustar00rootroot00000000000000 FB01VD EXAMPLE PROGRAM DATA 4 3 2 0.0 0.5015 0.4368 0.2693 0.6325 0.4368 0.4818 0.2639 0.4148 0.2693 0.2639 0.1121 0.6856 0.6325 0.4148 0.6856 0.8906 0.2113 0.8497 0.7263 0.8833 0.7560 0.6857 0.1985 0.6525 0.0002 0.8782 0.5442 0.3076 0.3303 0.0683 0.2320 0.9329 0.0437 0.7783 0.5618 0.4818 0.2119 0.5896 0.2639 0.1121 0.6853 0.4148 0.6856 0.8906 0.9329 0.2146 0.3126 0.2146 0.2922 0.5664 0.3126 0.5664 0.5935 0.3873 0.9488 0.3760 0.0881 0.9222 0.3435 0.7340 0.4498 1.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/FB01VD.res000077500000000000000000000006561201767322700167730ustar00rootroot00000000000000 FB01VD EXAMPLE PROGRAM RESULTS The state covariance matrix is 1.6007 1.3283 1.1153 1.7177 1.3283 1.2763 1.0132 1.5137 1.1153 1.0132 0.8222 1.2722 1.7177 1.5137 1.2722 2.1562 The Kalman filter gain matrix is 0.1648 0.2241 0.2115 0.1610 0.0728 0.1673 0.1304 0.3892 The square root of the covariance matrix of the innovations is 1.5091 1.1543 0.0000 1.5072 slicot-5.0+20101122/examples/FD01AD.dat000077500000000000000000000000621201767322700167160ustar00rootroot00000000000000 FD01AD EXAMPLE PROGRAM DATA 2 1.0D-2 B slicot-5.0+20101122/examples/FD01AD.res000077500000000000000000000003371201767322700167440ustar00rootroot00000000000000 FD01AD EXAMPLE PROGRAM RESULTS i XF(i) YQ(i) EPSBCK(i) 1 4.880088 12.307615 -0.140367 2 -1.456881 2.914057 -0.140367 3 0.980099 EFOR = 0.197D-02 slicot-5.0+20101122/examples/IB01AD.dat000077500000000000000000000472141201767322700167310ustar00rootroot00000000000000 IB01AD EXAMPLE PROGRAM DATA 15 0 1 1 1000 0.0 -1.0 M C N O N N 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 4.766099 4.763659 4.839359 5.002979 5.017629 5.056699 5.154379 5.361949 5.425439 5.569519 5.681849 5.742899 5.803949 5.918729 5.821049 5.447419 5.061589 4.629349 4.267939 4.011519 3.850349 3.711159 3.569519 3.518239 3.652549 3.818609 3.862559 4.011519 4.353409 4.705049 5.083559 5.344859 5.274039 5.127519 4.761219 4.451089 4.221539 4.045709 3.874769 3.730689 3.662319 3.576849 3.542659 3.479169 3.454749 3.359509 3.298459 3.225199 3.200779 3.225199 3.227639 3.274039 3.457189 3.867449 4.321659 4.492599 4.431549 4.243519 4.050599 3.857679 3.730689 3.791739 3.921169 3.955359 3.847909 3.725809 3.611039 3.716039 4.092109 4.480389 4.814939 5.054259 5.303339 5.486489 5.672089 5.779529 5.799069 5.664759 5.291129 4.880879 4.558529 4.184909 3.889419 3.708719 3.623249 3.569519 3.718479 4.033499 4.412009 4.629349 4.558529 4.394919 4.180019 4.197119 4.431549 4.714819 4.961459 5.300899 5.567079 5.681849 5.545099 5.188569 4.883319 4.600049 4.270379 4.038389 3.838139 3.711159 3.591499 3.535329 3.486489 3.476729 3.425439 3.381489 3.369279 3.364389 3.347299 3.381489 3.420559 3.413229 3.452309 3.635459 4.038389 4.375379 4.727029 5.056699 5.298459 5.532889 5.466959 5.195899 4.885759 4.763659 4.875989 5.042049 5.283809 5.491379 5.596379 5.672089 5.772209 5.830819 5.933379 5.899189 5.935819 5.894309 5.918729 5.994429 5.957799 6.031059 6.062809 6.040829 6.096999 6.123859 6.162929 6.040829 5.845469 5.772209 5.799069 5.923609 5.928499 6.001759 6.001759 6.060369 5.882099 5.510909 5.322879 5.371719 5.454749 5.437649 5.159269 4.902859 4.587839 4.502369 4.595159 4.824709 5.064029 5.271599 5.466959 5.615919 5.528009 5.254499 4.883319 4.517019 4.197119 4.001759 3.806399 3.904079 3.923609 3.869889 3.806399 3.720929 3.818609 4.140949 4.529229 4.805179 5.086009 5.339969 5.532889 5.576849 5.667199 5.791739 5.850349 5.923609 5.921169 5.977339 5.740459 5.388809 5.000539 4.849129 4.944369 5.173919 5.369279 5.447419 5.603709 5.730689 5.850349 5.979779 5.991989 6.084789 5.940709 5.803949 5.791739 5.603709 5.264269 4.946809 4.619579 4.514579 4.433989 4.285029 4.121419 3.945589 3.984659 4.219099 4.546319 4.873549 5.154379 5.388809 5.613479 5.835699 5.884539 5.955359 5.762439 5.459629 5.061589 4.707499 4.458409 4.267939 4.053039 3.943149 3.825929 3.967569 4.280149 4.480389 4.492599 4.390039 4.197119 4.111649 3.982219 3.867449 3.767319 3.872329 4.236189 4.663539 4.971229 5.066469 4.902859 4.675749 4.392479 4.099439 4.114089 4.326539 4.643999 4.971229 5.159269 5.388809 5.576849 5.652549 5.803949 5.913839 5.886979 5.799069 5.730689 5.762439 5.813719 5.821049 5.928499 6.013969 5.764879 5.413229 5.098219 4.678189 4.372939 4.392479 4.590279 4.919949 5.017629 4.858899 4.675749 4.619579 4.834479 5.090889 5.376599 5.681849 5.823489 5.952919 6.062809 6.089669 6.075019 6.026179 5.994429 6.077459 5.857679 5.701389 5.730689 5.784419 5.823489 5.894309 5.762439 5.415679 4.961459 4.595159 4.331429 4.297239 4.582949 4.861339 5.173919 5.166589 4.919949 4.607369 4.370499 4.182469 4.038389 4.145839 4.431549 4.556089 4.480389 4.375379 4.370499 4.558529 4.858899 4.895529 4.741679 4.744129 4.875989 5.105539 5.239849 5.518239 5.652549 5.723369 5.855239 5.962679 5.984659 5.984659 6.055479 6.062809 6.055479 6.070129 5.784419 5.440099 5.056699 4.941929 5.010299 5.134849 5.313109 5.479169 5.623249 5.562199 5.330209 5.010299 4.665979 4.414459 4.201999 4.048159 4.079899 4.189789 4.131179 4.004199 3.916289 3.960239 4.199559 4.624469 4.883319 5.137289 5.379049 5.623249 5.762439 5.833259 5.686739 5.366839 5.225199 5.239849 5.354629 5.508469 5.596379 5.752669 5.874769 5.906519 5.894309 5.742899 5.447419 5.024959 4.883319 4.885759 4.893089 4.714819 4.451089 4.233749 4.043269 3.864999 3.757559 3.669639 3.593939 3.547539 3.506029 3.454749 3.398579 3.361949 3.339969 3.374159 3.520679 3.713599 3.757559 3.779529 3.696509 3.777089 3.886979 3.904079 3.850349 3.965129 4.282589 4.521899 4.714819 4.971229 5.220319 5.532889 5.652549 5.781979 5.955359 6.035939 6.118969 6.133629 6.153159 6.192229 6.143389 6.167809 5.991989 5.652549 5.459629 5.437649 5.339969 5.098219 4.785639 4.492599 4.236189 4.067689 3.933379 3.823489 3.730689 3.611039 3.564639 3.549989 3.557309 3.513359 3.515799 3.694059 4.072579 4.480389 4.705049 4.612259 4.385149 4.201999 4.026179 3.904079 3.774649 3.691619 3.845469 4.201999 4.585399 4.902859 5.256949 5.510909 5.640339 5.843029 5.974889 5.935819 5.821049 5.528009 5.171479 4.810059 4.453529 4.380269 4.565859 4.805179 5.125079 5.354629 5.589059 5.764879 5.923609 5.940709 5.857679 5.694059 5.486489 5.149499 4.844249 4.541439 4.267939 4.060369 3.960239 3.789299 3.642779 3.525569 3.498699 3.454749 3.408349 3.379049 3.376599 3.361949 3.359509 3.369279 3.398579 3.579289 3.948029 4.412009 4.585399 4.514579 4.343639 4.155599 3.984659 4.043269 4.307009 4.421779 4.353409 4.223979 4.053039 3.940709 3.838139 3.730689 3.652549 3.611039 3.564639 3.496259 3.462069 3.454749 3.425439 3.379049 3.432769 3.623249 3.974889 4.380269 4.714819 5.073799 5.369279 5.603709 5.745349 5.652549 5.401019 5.015189 4.709939 4.416899 4.236189 4.236189 4.248399 4.221539 4.297239 4.590279 4.893089 5.134849 5.427889 5.379049 5.364389 5.452309 5.567079 5.672089 5.769769 5.830819 5.923609 5.965129 6.057919 6.050599 6.072579 6.111649 6.070129 5.896749 5.755109 5.718479 5.821049 6.001759 6.001759 5.901629 5.557309 5.173919 4.800289 4.431549 4.194679 4.006639 3.850349 3.747789 3.642779 3.591499 3.569519 3.528009 3.537779 3.554869 3.493819 3.447419 3.440099 3.408349 3.410789 3.452309 3.681849 4.060369 4.441319 4.854019 5.154379 5.425439 5.596379 5.586619 5.354629 5.027399 4.863779 4.761219 4.570739 4.368059 4.397359 4.573189 4.841809 5.203219 5.452309 5.652549 5.855239 5.906519 5.952919 5.828369 5.791739 5.799069 5.813719 5.877209 5.955359 5.781979 5.518239 5.127519 4.763659 4.492599 4.233749 4.011519 3.855239 3.691619 3.635459 3.818609 4.155599 4.590279 4.988329 5.076239 4.907739 4.648889 4.377829 4.216649 4.287469 4.590279 4.846689 5.139729 5.388809 5.689179 5.884539 6.043269 6.170259 6.211769 6.250839 6.209329 6.013969 5.701389 5.469399 5.479169 5.557309 5.728249 5.882099 5.984659 5.901629 5.581729 5.371719 5.418119 5.510909 5.667199 5.791739 5.698949 5.484049 5.154379 4.980999 5.061589 5.195899 5.359509 5.615919 5.762439 5.857679 5.948029 5.835699 5.706269 5.498699 5.188569 5.117749 5.191009 5.315549 5.532889 5.444979 5.396139 5.274039 5.027399 4.744129 4.668419 4.651329 4.514579 4.267939 4.260609 4.263049 4.189789 4.277699 4.600049 4.932159 5.283809 5.528009 5.740459 5.874769 5.955359 5.991989 5.845469 5.528009 5.061589 4.734359 4.534109 4.534109 4.697729 4.744129 4.619579 4.643999 4.832039 5.132399 5.410789 5.625689 5.603709 5.315549 4.961459 4.619579 4.358289 4.155599 4.033499 3.886979 3.772209 3.640339 3.532889 3.435209 3.427889 3.422999 3.398579 3.603709 4.023729 4.451089 4.792969 4.902859 4.780759 4.590279 4.336309 4.145839 4.216649 4.433989 4.714819 5.098219 5.359509 5.569519 5.772209 5.921169 6.055479 5.962679 5.642779 5.435209 5.388809 5.537779 5.681849 5.701389 5.615919 5.667199 5.740459 5.803949 5.882099 5.950469 6.072579 6.148279 6.116529 6.177579 6.201999 6.206889 5.991989 5.564639 5.178799 4.998089 5.051819 5.232529 5.484049 5.686739 5.899189 5.869889 5.977339 6.053039 6.079899 6.128739 6.079899 6.167809 6.194679 6.236189 6.053039 5.652549 5.274039 4.858899 4.534109 4.455969 4.619579 4.866229 5.117749 5.166589 5.056699 5.002979 5.098219 5.325319 5.567079 5.466959 5.252059 4.946809 4.880879 4.980999 5.225199 5.459629 5.723369 5.791739 5.906519 5.991989 5.835699 5.528009 5.142169 4.775869 4.490159 4.236189 4.023729 3.886979 3.752669 3.681849 3.806399 4.145839 4.600049 5.002979 5.303339 5.552429 5.615919 5.523119 5.611039 5.713599 5.845469 5.899189 5.994429 6.092109 6.092109 6.143389 6.153159 6.233749 6.187349 6.013969 5.835699 5.774649 5.686739 5.537779 5.327759 5.054259 4.700169 4.394919 4.180019 4.043269 3.877209 3.752669 3.728249 3.869889 4.206889 4.355849 4.426669 4.453529 4.521899 4.392479 4.155599 3.965129 3.877209 3.970009 4.258169 4.421779 4.336309 4.299679 4.392479 4.675749 4.761219 4.658659 4.490159 4.307009 4.126299 3.972449 4.077459 4.372939 4.741679 5.088449 5.186129 5.037169 4.785639 4.563419 4.534109 4.705049 4.741679 4.648889 4.431549 4.238629 4.065249 3.943149 3.811279 3.691619 3.652549 3.825929 4.223979 4.424219 4.429109 4.319219 4.138509 3.965129 3.886979 3.801509 3.701389 3.640339 3.767319 4.150719 4.648889 4.990769 5.088449 5.022509 4.783199 4.685519 4.665979 4.707499 4.912619 5.195899 5.415679 5.623249 5.740459 5.899189 5.928499 6.050599 6.153159 5.965129 5.586619 5.381489 5.371719 5.486489 5.567079 5.821049 5.913839 5.994429 6.011519 5.999309 6.018849 5.821049 5.728249 5.740459 5.764879 5.882099 5.926049 5.750229 5.415679 4.995649 4.861339 4.902859 5.103099 5.364389 5.596379 5.752669 5.845469 5.928499 6.006639 5.840579 5.518239 5.173919 4.739239 4.458409 4.426669 4.602489 4.822269 5.183689 5.430329 5.652549 5.821049 5.706269 5.369279 5.027399 4.705049 4.414459 4.145839 3.965129 4.033499 4.372939 4.683079 slicot-5.0+20101122/examples/IB01AD.res000077500000000000000000000003461201767322700167450ustar00rootroot00000000000000 IB01AD EXAMPLE PROGRAM RESULTS The order of the system is 4 The singular values are 69.8841 14.9963 3.6675 1.9677 0.3000 0.2078 0.1651 0.1373 0.1133 0.1059 0.0856 0.0784 0.0733 0.0678 0.0571 slicot-5.0+20101122/examples/IB01BD.dat000077500000000000000000000472271201767322700167360ustar00rootroot00000000000000 IB01BD EXAMPLE PROGRAM DATA 15 0 1 1 1000 0.0 -1.0 C C N O N N A K 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 4.766099 4.763659 4.839359 5.002979 5.017629 5.056699 5.154379 5.361949 5.425439 5.569519 5.681849 5.742899 5.803949 5.918729 5.821049 5.447419 5.061589 4.629349 4.267939 4.011519 3.850349 3.711159 3.569519 3.518239 3.652549 3.818609 3.862559 4.011519 4.353409 4.705049 5.083559 5.344859 5.274039 5.127519 4.761219 4.451089 4.221539 4.045709 3.874769 3.730689 3.662319 3.576849 3.542659 3.479169 3.454749 3.359509 3.298459 3.225199 3.200779 3.225199 3.227639 3.274039 3.457189 3.867449 4.321659 4.492599 4.431549 4.243519 4.050599 3.857679 3.730689 3.791739 3.921169 3.955359 3.847909 3.725809 3.611039 3.716039 4.092109 4.480389 4.814939 5.054259 5.303339 5.486489 5.672089 5.779529 5.799069 5.664759 5.291129 4.880879 4.558529 4.184909 3.889419 3.708719 3.623249 3.569519 3.718479 4.033499 4.412009 4.629349 4.558529 4.394919 4.180019 4.197119 4.431549 4.714819 4.961459 5.300899 5.567079 5.681849 5.545099 5.188569 4.883319 4.600049 4.270379 4.038389 3.838139 3.711159 3.591499 3.535329 3.486489 3.476729 3.425439 3.381489 3.369279 3.364389 3.347299 3.381489 3.420559 3.413229 3.452309 3.635459 4.038389 4.375379 4.727029 5.056699 5.298459 5.532889 5.466959 5.195899 4.885759 4.763659 4.875989 5.042049 5.283809 5.491379 5.596379 5.672089 5.772209 5.830819 5.933379 5.899189 5.935819 5.894309 5.918729 5.994429 5.957799 6.031059 6.062809 6.040829 6.096999 6.123859 6.162929 6.040829 5.845469 5.772209 5.799069 5.923609 5.928499 6.001759 6.001759 6.060369 5.882099 5.510909 5.322879 5.371719 5.454749 5.437649 5.159269 4.902859 4.587839 4.502369 4.595159 4.824709 5.064029 5.271599 5.466959 5.615919 5.528009 5.254499 4.883319 4.517019 4.197119 4.001759 3.806399 3.904079 3.923609 3.869889 3.806399 3.720929 3.818609 4.140949 4.529229 4.805179 5.086009 5.339969 5.532889 5.576849 5.667199 5.791739 5.850349 5.923609 5.921169 5.977339 5.740459 5.388809 5.000539 4.849129 4.944369 5.173919 5.369279 5.447419 5.603709 5.730689 5.850349 5.979779 5.991989 6.084789 5.940709 5.803949 5.791739 5.603709 5.264269 4.946809 4.619579 4.514579 4.433989 4.285029 4.121419 3.945589 3.984659 4.219099 4.546319 4.873549 5.154379 5.388809 5.613479 5.835699 5.884539 5.955359 5.762439 5.459629 5.061589 4.707499 4.458409 4.267939 4.053039 3.943149 3.825929 3.967569 4.280149 4.480389 4.492599 4.390039 4.197119 4.111649 3.982219 3.867449 3.767319 3.872329 4.236189 4.663539 4.971229 5.066469 4.902859 4.675749 4.392479 4.099439 4.114089 4.326539 4.643999 4.971229 5.159269 5.388809 5.576849 5.652549 5.803949 5.913839 5.886979 5.799069 5.730689 5.762439 5.813719 5.821049 5.928499 6.013969 5.764879 5.413229 5.098219 4.678189 4.372939 4.392479 4.590279 4.919949 5.017629 4.858899 4.675749 4.619579 4.834479 5.090889 5.376599 5.681849 5.823489 5.952919 6.062809 6.089669 6.075019 6.026179 5.994429 6.077459 5.857679 5.701389 5.730689 5.784419 5.823489 5.894309 5.762439 5.415679 4.961459 4.595159 4.331429 4.297239 4.582949 4.861339 5.173919 5.166589 4.919949 4.607369 4.370499 4.182469 4.038389 4.145839 4.431549 4.556089 4.480389 4.375379 4.370499 4.558529 4.858899 4.895529 4.741679 4.744129 4.875989 5.105539 5.239849 5.518239 5.652549 5.723369 5.855239 5.962679 5.984659 5.984659 6.055479 6.062809 6.055479 6.070129 5.784419 5.440099 5.056699 4.941929 5.010299 5.134849 5.313109 5.479169 5.623249 5.562199 5.330209 5.010299 4.665979 4.414459 4.201999 4.048159 4.079899 4.189789 4.131179 4.004199 3.916289 3.960239 4.199559 4.624469 4.883319 5.137289 5.379049 5.623249 5.762439 5.833259 5.686739 5.366839 5.225199 5.239849 5.354629 5.508469 5.596379 5.752669 5.874769 5.906519 5.894309 5.742899 5.447419 5.024959 4.883319 4.885759 4.893089 4.714819 4.451089 4.233749 4.043269 3.864999 3.757559 3.669639 3.593939 3.547539 3.506029 3.454749 3.398579 3.361949 3.339969 3.374159 3.520679 3.713599 3.757559 3.779529 3.696509 3.777089 3.886979 3.904079 3.850349 3.965129 4.282589 4.521899 4.714819 4.971229 5.220319 5.532889 5.652549 5.781979 5.955359 6.035939 6.118969 6.133629 6.153159 6.192229 6.143389 6.167809 5.991989 5.652549 5.459629 5.437649 5.339969 5.098219 4.785639 4.492599 4.236189 4.067689 3.933379 3.823489 3.730689 3.611039 3.564639 3.549989 3.557309 3.513359 3.515799 3.694059 4.072579 4.480389 4.705049 4.612259 4.385149 4.201999 4.026179 3.904079 3.774649 3.691619 3.845469 4.201999 4.585399 4.902859 5.256949 5.510909 5.640339 5.843029 5.974889 5.935819 5.821049 5.528009 5.171479 4.810059 4.453529 4.380269 4.565859 4.805179 5.125079 5.354629 5.589059 5.764879 5.923609 5.940709 5.857679 5.694059 5.486489 5.149499 4.844249 4.541439 4.267939 4.060369 3.960239 3.789299 3.642779 3.525569 3.498699 3.454749 3.408349 3.379049 3.376599 3.361949 3.359509 3.369279 3.398579 3.579289 3.948029 4.412009 4.585399 4.514579 4.343639 4.155599 3.984659 4.043269 4.307009 4.421779 4.353409 4.223979 4.053039 3.940709 3.838139 3.730689 3.652549 3.611039 3.564639 3.496259 3.462069 3.454749 3.425439 3.379049 3.432769 3.623249 3.974889 4.380269 4.714819 5.073799 5.369279 5.603709 5.745349 5.652549 5.401019 5.015189 4.709939 4.416899 4.236189 4.236189 4.248399 4.221539 4.297239 4.590279 4.893089 5.134849 5.427889 5.379049 5.364389 5.452309 5.567079 5.672089 5.769769 5.830819 5.923609 5.965129 6.057919 6.050599 6.072579 6.111649 6.070129 5.896749 5.755109 5.718479 5.821049 6.001759 6.001759 5.901629 5.557309 5.173919 4.800289 4.431549 4.194679 4.006639 3.850349 3.747789 3.642779 3.591499 3.569519 3.528009 3.537779 3.554869 3.493819 3.447419 3.440099 3.408349 3.410789 3.452309 3.681849 4.060369 4.441319 4.854019 5.154379 5.425439 5.596379 5.586619 5.354629 5.027399 4.863779 4.761219 4.570739 4.368059 4.397359 4.573189 4.841809 5.203219 5.452309 5.652549 5.855239 5.906519 5.952919 5.828369 5.791739 5.799069 5.813719 5.877209 5.955359 5.781979 5.518239 5.127519 4.763659 4.492599 4.233749 4.011519 3.855239 3.691619 3.635459 3.818609 4.155599 4.590279 4.988329 5.076239 4.907739 4.648889 4.377829 4.216649 4.287469 4.590279 4.846689 5.139729 5.388809 5.689179 5.884539 6.043269 6.170259 6.211769 6.250839 6.209329 6.013969 5.701389 5.469399 5.479169 5.557309 5.728249 5.882099 5.984659 5.901629 5.581729 5.371719 5.418119 5.510909 5.667199 5.791739 5.698949 5.484049 5.154379 4.980999 5.061589 5.195899 5.359509 5.615919 5.762439 5.857679 5.948029 5.835699 5.706269 5.498699 5.188569 5.117749 5.191009 5.315549 5.532889 5.444979 5.396139 5.274039 5.027399 4.744129 4.668419 4.651329 4.514579 4.267939 4.260609 4.263049 4.189789 4.277699 4.600049 4.932159 5.283809 5.528009 5.740459 5.874769 5.955359 5.991989 5.845469 5.528009 5.061589 4.734359 4.534109 4.534109 4.697729 4.744129 4.619579 4.643999 4.832039 5.132399 5.410789 5.625689 5.603709 5.315549 4.961459 4.619579 4.358289 4.155599 4.033499 3.886979 3.772209 3.640339 3.532889 3.435209 3.427889 3.422999 3.398579 3.603709 4.023729 4.451089 4.792969 4.902859 4.780759 4.590279 4.336309 4.145839 4.216649 4.433989 4.714819 5.098219 5.359509 5.569519 5.772209 5.921169 6.055479 5.962679 5.642779 5.435209 5.388809 5.537779 5.681849 5.701389 5.615919 5.667199 5.740459 5.803949 5.882099 5.950469 6.072579 6.148279 6.116529 6.177579 6.201999 6.206889 5.991989 5.564639 5.178799 4.998089 5.051819 5.232529 5.484049 5.686739 5.899189 5.869889 5.977339 6.053039 6.079899 6.128739 6.079899 6.167809 6.194679 6.236189 6.053039 5.652549 5.274039 4.858899 4.534109 4.455969 4.619579 4.866229 5.117749 5.166589 5.056699 5.002979 5.098219 5.325319 5.567079 5.466959 5.252059 4.946809 4.880879 4.980999 5.225199 5.459629 5.723369 5.791739 5.906519 5.991989 5.835699 5.528009 5.142169 4.775869 4.490159 4.236189 4.023729 3.886979 3.752669 3.681849 3.806399 4.145839 4.600049 5.002979 5.303339 5.552429 5.615919 5.523119 5.611039 5.713599 5.845469 5.899189 5.994429 6.092109 6.092109 6.143389 6.153159 6.233749 6.187349 6.013969 5.835699 5.774649 5.686739 5.537779 5.327759 5.054259 4.700169 4.394919 4.180019 4.043269 3.877209 3.752669 3.728249 3.869889 4.206889 4.355849 4.426669 4.453529 4.521899 4.392479 4.155599 3.965129 3.877209 3.970009 4.258169 4.421779 4.336309 4.299679 4.392479 4.675749 4.761219 4.658659 4.490159 4.307009 4.126299 3.972449 4.077459 4.372939 4.741679 5.088449 5.186129 5.037169 4.785639 4.563419 4.534109 4.705049 4.741679 4.648889 4.431549 4.238629 4.065249 3.943149 3.811279 3.691619 3.652549 3.825929 4.223979 4.424219 4.429109 4.319219 4.138509 3.965129 3.886979 3.801509 3.701389 3.640339 3.767319 4.150719 4.648889 4.990769 5.088449 5.022509 4.783199 4.685519 4.665979 4.707499 4.912619 5.195899 5.415679 5.623249 5.740459 5.899189 5.928499 6.050599 6.153159 5.965129 5.586619 5.381489 5.371719 5.486489 5.567079 5.821049 5.913839 5.994429 6.011519 5.999309 6.018849 5.821049 5.728249 5.740459 5.764879 5.882099 5.926049 5.750229 5.415679 4.995649 4.861339 4.902859 5.103099 5.364389 5.596379 5.752669 5.845469 5.928499 6.006639 5.840579 5.518239 5.173919 4.739239 4.458409 4.426669 4.602489 4.822269 5.183689 5.430329 5.652549 5.821049 5.706269 5.369279 5.027399 4.705049 4.414459 4.145839 3.965129 4.033499 4.372939 4.683079 slicot-5.0+20101122/examples/IB01BD.res000077500000000000000000000014341201767322700167450ustar00rootroot00000000000000 IB01BD EXAMPLE PROGRAM RESULTS The system state matrix A is 0.8924 0.3887 0.1285 0.1716 -0.0837 0.6186 -0.6273 -0.4582 0.0052 0.1307 0.6685 -0.6755 0.0055 0.0734 -0.2148 0.4788 The system output matrix C is -0.4442 0.6663 0.3961 0.4102 The system input matrix B is -0.2142 -0.1968 0.0525 0.0361 The system input-output matrix D is -0.0041 The Kalman gain matrix K is -1.9513 -0.1867 0.6348 -0.3486 The state covariance matrix Q is 0.0052 0.0005 -0.0017 0.0009 0.0005 0.0000 -0.0002 0.0001 -0.0017 -0.0002 0.0006 -0.0003 0.0009 0.0001 -0.0003 0.0002 The output covariance matrix Ry is 0.0012 The state-output cross-covariance matrix S is -0.0025 -0.0002 0.0008 -0.0005 slicot-5.0+20101122/examples/IB01CD.dat000077500000000000000000000472351201767322700167360ustar00rootroot00000000000000 IB01CD EXAMPLE PROGRAM DATA 15 0 1 1 1000 0.0 -1.0 C C N O N N A C X 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 4.766099 4.763659 4.839359 5.002979 5.017629 5.056699 5.154379 5.361949 5.425439 5.569519 5.681849 5.742899 5.803949 5.918729 5.821049 5.447419 5.061589 4.629349 4.267939 4.011519 3.850349 3.711159 3.569519 3.518239 3.652549 3.818609 3.862559 4.011519 4.353409 4.705049 5.083559 5.344859 5.274039 5.127519 4.761219 4.451089 4.221539 4.045709 3.874769 3.730689 3.662319 3.576849 3.542659 3.479169 3.454749 3.359509 3.298459 3.225199 3.200779 3.225199 3.227639 3.274039 3.457189 3.867449 4.321659 4.492599 4.431549 4.243519 4.050599 3.857679 3.730689 3.791739 3.921169 3.955359 3.847909 3.725809 3.611039 3.716039 4.092109 4.480389 4.814939 5.054259 5.303339 5.486489 5.672089 5.779529 5.799069 5.664759 5.291129 4.880879 4.558529 4.184909 3.889419 3.708719 3.623249 3.569519 3.718479 4.033499 4.412009 4.629349 4.558529 4.394919 4.180019 4.197119 4.431549 4.714819 4.961459 5.300899 5.567079 5.681849 5.545099 5.188569 4.883319 4.600049 4.270379 4.038389 3.838139 3.711159 3.591499 3.535329 3.486489 3.476729 3.425439 3.381489 3.369279 3.364389 3.347299 3.381489 3.420559 3.413229 3.452309 3.635459 4.038389 4.375379 4.727029 5.056699 5.298459 5.532889 5.466959 5.195899 4.885759 4.763659 4.875989 5.042049 5.283809 5.491379 5.596379 5.672089 5.772209 5.830819 5.933379 5.899189 5.935819 5.894309 5.918729 5.994429 5.957799 6.031059 6.062809 6.040829 6.096999 6.123859 6.162929 6.040829 5.845469 5.772209 5.799069 5.923609 5.928499 6.001759 6.001759 6.060369 5.882099 5.510909 5.322879 5.371719 5.454749 5.437649 5.159269 4.902859 4.587839 4.502369 4.595159 4.824709 5.064029 5.271599 5.466959 5.615919 5.528009 5.254499 4.883319 4.517019 4.197119 4.001759 3.806399 3.904079 3.923609 3.869889 3.806399 3.720929 3.818609 4.140949 4.529229 4.805179 5.086009 5.339969 5.532889 5.576849 5.667199 5.791739 5.850349 5.923609 5.921169 5.977339 5.740459 5.388809 5.000539 4.849129 4.944369 5.173919 5.369279 5.447419 5.603709 5.730689 5.850349 5.979779 5.991989 6.084789 5.940709 5.803949 5.791739 5.603709 5.264269 4.946809 4.619579 4.514579 4.433989 4.285029 4.121419 3.945589 3.984659 4.219099 4.546319 4.873549 5.154379 5.388809 5.613479 5.835699 5.884539 5.955359 5.762439 5.459629 5.061589 4.707499 4.458409 4.267939 4.053039 3.943149 3.825929 3.967569 4.280149 4.480389 4.492599 4.390039 4.197119 4.111649 3.982219 3.867449 3.767319 3.872329 4.236189 4.663539 4.971229 5.066469 4.902859 4.675749 4.392479 4.099439 4.114089 4.326539 4.643999 4.971229 5.159269 5.388809 5.576849 5.652549 5.803949 5.913839 5.886979 5.799069 5.730689 5.762439 5.813719 5.821049 5.928499 6.013969 5.764879 5.413229 5.098219 4.678189 4.372939 4.392479 4.590279 4.919949 5.017629 4.858899 4.675749 4.619579 4.834479 5.090889 5.376599 5.681849 5.823489 5.952919 6.062809 6.089669 6.075019 6.026179 5.994429 6.077459 5.857679 5.701389 5.730689 5.784419 5.823489 5.894309 5.762439 5.415679 4.961459 4.595159 4.331429 4.297239 4.582949 4.861339 5.173919 5.166589 4.919949 4.607369 4.370499 4.182469 4.038389 4.145839 4.431549 4.556089 4.480389 4.375379 4.370499 4.558529 4.858899 4.895529 4.741679 4.744129 4.875989 5.105539 5.239849 5.518239 5.652549 5.723369 5.855239 5.962679 5.984659 5.984659 6.055479 6.062809 6.055479 6.070129 5.784419 5.440099 5.056699 4.941929 5.010299 5.134849 5.313109 5.479169 5.623249 5.562199 5.330209 5.010299 4.665979 4.414459 4.201999 4.048159 4.079899 4.189789 4.131179 4.004199 3.916289 3.960239 4.199559 4.624469 4.883319 5.137289 5.379049 5.623249 5.762439 5.833259 5.686739 5.366839 5.225199 5.239849 5.354629 5.508469 5.596379 5.752669 5.874769 5.906519 5.894309 5.742899 5.447419 5.024959 4.883319 4.885759 4.893089 4.714819 4.451089 4.233749 4.043269 3.864999 3.757559 3.669639 3.593939 3.547539 3.506029 3.454749 3.398579 3.361949 3.339969 3.374159 3.520679 3.713599 3.757559 3.779529 3.696509 3.777089 3.886979 3.904079 3.850349 3.965129 4.282589 4.521899 4.714819 4.971229 5.220319 5.532889 5.652549 5.781979 5.955359 6.035939 6.118969 6.133629 6.153159 6.192229 6.143389 6.167809 5.991989 5.652549 5.459629 5.437649 5.339969 5.098219 4.785639 4.492599 4.236189 4.067689 3.933379 3.823489 3.730689 3.611039 3.564639 3.549989 3.557309 3.513359 3.515799 3.694059 4.072579 4.480389 4.705049 4.612259 4.385149 4.201999 4.026179 3.904079 3.774649 3.691619 3.845469 4.201999 4.585399 4.902859 5.256949 5.510909 5.640339 5.843029 5.974889 5.935819 5.821049 5.528009 5.171479 4.810059 4.453529 4.380269 4.565859 4.805179 5.125079 5.354629 5.589059 5.764879 5.923609 5.940709 5.857679 5.694059 5.486489 5.149499 4.844249 4.541439 4.267939 4.060369 3.960239 3.789299 3.642779 3.525569 3.498699 3.454749 3.408349 3.379049 3.376599 3.361949 3.359509 3.369279 3.398579 3.579289 3.948029 4.412009 4.585399 4.514579 4.343639 4.155599 3.984659 4.043269 4.307009 4.421779 4.353409 4.223979 4.053039 3.940709 3.838139 3.730689 3.652549 3.611039 3.564639 3.496259 3.462069 3.454749 3.425439 3.379049 3.432769 3.623249 3.974889 4.380269 4.714819 5.073799 5.369279 5.603709 5.745349 5.652549 5.401019 5.015189 4.709939 4.416899 4.236189 4.236189 4.248399 4.221539 4.297239 4.590279 4.893089 5.134849 5.427889 5.379049 5.364389 5.452309 5.567079 5.672089 5.769769 5.830819 5.923609 5.965129 6.057919 6.050599 6.072579 6.111649 6.070129 5.896749 5.755109 5.718479 5.821049 6.001759 6.001759 5.901629 5.557309 5.173919 4.800289 4.431549 4.194679 4.006639 3.850349 3.747789 3.642779 3.591499 3.569519 3.528009 3.537779 3.554869 3.493819 3.447419 3.440099 3.408349 3.410789 3.452309 3.681849 4.060369 4.441319 4.854019 5.154379 5.425439 5.596379 5.586619 5.354629 5.027399 4.863779 4.761219 4.570739 4.368059 4.397359 4.573189 4.841809 5.203219 5.452309 5.652549 5.855239 5.906519 5.952919 5.828369 5.791739 5.799069 5.813719 5.877209 5.955359 5.781979 5.518239 5.127519 4.763659 4.492599 4.233749 4.011519 3.855239 3.691619 3.635459 3.818609 4.155599 4.590279 4.988329 5.076239 4.907739 4.648889 4.377829 4.216649 4.287469 4.590279 4.846689 5.139729 5.388809 5.689179 5.884539 6.043269 6.170259 6.211769 6.250839 6.209329 6.013969 5.701389 5.469399 5.479169 5.557309 5.728249 5.882099 5.984659 5.901629 5.581729 5.371719 5.418119 5.510909 5.667199 5.791739 5.698949 5.484049 5.154379 4.980999 5.061589 5.195899 5.359509 5.615919 5.762439 5.857679 5.948029 5.835699 5.706269 5.498699 5.188569 5.117749 5.191009 5.315549 5.532889 5.444979 5.396139 5.274039 5.027399 4.744129 4.668419 4.651329 4.514579 4.267939 4.260609 4.263049 4.189789 4.277699 4.600049 4.932159 5.283809 5.528009 5.740459 5.874769 5.955359 5.991989 5.845469 5.528009 5.061589 4.734359 4.534109 4.534109 4.697729 4.744129 4.619579 4.643999 4.832039 5.132399 5.410789 5.625689 5.603709 5.315549 4.961459 4.619579 4.358289 4.155599 4.033499 3.886979 3.772209 3.640339 3.532889 3.435209 3.427889 3.422999 3.398579 3.603709 4.023729 4.451089 4.792969 4.902859 4.780759 4.590279 4.336309 4.145839 4.216649 4.433989 4.714819 5.098219 5.359509 5.569519 5.772209 5.921169 6.055479 5.962679 5.642779 5.435209 5.388809 5.537779 5.681849 5.701389 5.615919 5.667199 5.740459 5.803949 5.882099 5.950469 6.072579 6.148279 6.116529 6.177579 6.201999 6.206889 5.991989 5.564639 5.178799 4.998089 5.051819 5.232529 5.484049 5.686739 5.899189 5.869889 5.977339 6.053039 6.079899 6.128739 6.079899 6.167809 6.194679 6.236189 6.053039 5.652549 5.274039 4.858899 4.534109 4.455969 4.619579 4.866229 5.117749 5.166589 5.056699 5.002979 5.098219 5.325319 5.567079 5.466959 5.252059 4.946809 4.880879 4.980999 5.225199 5.459629 5.723369 5.791739 5.906519 5.991989 5.835699 5.528009 5.142169 4.775869 4.490159 4.236189 4.023729 3.886979 3.752669 3.681849 3.806399 4.145839 4.600049 5.002979 5.303339 5.552429 5.615919 5.523119 5.611039 5.713599 5.845469 5.899189 5.994429 6.092109 6.092109 6.143389 6.153159 6.233749 6.187349 6.013969 5.835699 5.774649 5.686739 5.537779 5.327759 5.054259 4.700169 4.394919 4.180019 4.043269 3.877209 3.752669 3.728249 3.869889 4.206889 4.355849 4.426669 4.453529 4.521899 4.392479 4.155599 3.965129 3.877209 3.970009 4.258169 4.421779 4.336309 4.299679 4.392479 4.675749 4.761219 4.658659 4.490159 4.307009 4.126299 3.972449 4.077459 4.372939 4.741679 5.088449 5.186129 5.037169 4.785639 4.563419 4.534109 4.705049 4.741679 4.648889 4.431549 4.238629 4.065249 3.943149 3.811279 3.691619 3.652549 3.825929 4.223979 4.424219 4.429109 4.319219 4.138509 3.965129 3.886979 3.801509 3.701389 3.640339 3.767319 4.150719 4.648889 4.990769 5.088449 5.022509 4.783199 4.685519 4.665979 4.707499 4.912619 5.195899 5.415679 5.623249 5.740459 5.899189 5.928499 6.050599 6.153159 5.965129 5.586619 5.381489 5.371719 5.486489 5.567079 5.821049 5.913839 5.994429 6.011519 5.999309 6.018849 5.821049 5.728249 5.740459 5.764879 5.882099 5.926049 5.750229 5.415679 4.995649 4.861339 4.902859 5.103099 5.364389 5.596379 5.752669 5.845469 5.928499 6.006639 5.840579 5.518239 5.173919 4.739239 4.458409 4.426669 4.602489 4.822269 5.183689 5.430329 5.652549 5.821049 5.706269 5.369279 5.027399 4.705049 4.414459 4.145839 3.965129 4.033499 4.372939 4.683079 slicot-5.0+20101122/examples/IB01CD.res000077500000000000000000000007331201767322700167470ustar00rootroot00000000000000 IB01CD EXAMPLE PROGRAM RESULTS The system state matrix A is 0.8924 0.3887 0.1285 0.1716 -0.0837 0.6186 -0.6273 -0.4582 0.0052 0.1307 0.6685 -0.6755 0.0055 0.0734 -0.2148 0.4788 The system output matrix C is -0.4442 0.6663 0.3961 0.4102 The system input matrix B is -0.2150 -0.1962 0.0511 0.0373 The system input-output matrix D is -0.0018 The initial state vector x0 is -11.4329 -0.6767 0.0472 0.3600 slicot-5.0+20101122/examples/IB03AD.dat000077500000000000000000001042121201767322700167230ustar00rootroot00000000000000 IB03AD EXAMPLE PROGRAM DATA 10 1 1 1024 4 12 500 1000 0 .00001 .00001 B D F 2.2183165e-01 3.9027807e-02 -5.0295887e-02 8.5386224e-03 7.2431159e-02 -1.7082198e-03 -1.7176287e-01 -2.6198104e-01 -1.7194108e-01 1.8566868e-02 1.5625362e-01 1.7463811e-01 1.1564450e-01 2.8779248e-02 -8.4265993e-02 -2.0978501e-01 -2.6591828e-01 -1.7268680e-01 2.1525013e-02 1.4363602e-01 7.3101431e-02 -1.0259212e-01 -1.6380473e-01 -1.0021167e-02 2.0263451e-01 2.1983417e-01 -2.1636523e-02 -3.0986057e-01 -3.8521982e-01 -2.1785179e-01 -1.4761096e-02 3.7005180e-02 -2.8119028e-02 -4.2167901e-02 5.2117694e-02 1.2023747e-01 1.8863385e-02 -1.9506434e-01 -3.0192175e-01 -1.7000747e-01 8.0740471e-02 2.0188076e-01 8.5108288e-02 -1.3270970e-01 -2.3646822e-01 -1.6505385e-01 -4.7448014e-02 -2.7886815e-02 -1.0152026e-01 -1.4155374e-01 -6.1650823e-02 8.3519614e-02 1.5926650e-01 8.6142760e-02 -9.4385381e-02 -2.6609066e-01 -3.2883874e-01 -2.5908050e-01 -1.1648940e-01 -3.0653766e-03 1.0326675e-02 -5.3445909e-02 -9.2412724e-02 -3.0279541e-02 8.4846832e-02 1.1133075e-01 -3.2135250e-02 -2.5308181e-01 -3.5670882e-01 -2.4458860e-01 -2.5254261e-02 9.3714332e-02 1.8643667e-02 -1.4592119e-01 -2.2730880e-01 -1.7140060e-01 -7.4131665e-02 -3.9669515e-02 -5.1266129e-02 -1.1752833e-02 1.0785565e-01 2.0665525e-01 1.6117322e-01 -2.6938653e-02 -2.1941152e-01 -2.7753567e-01 -1.8805912e-01 -4.6845025e-02 5.8585698e-02 1.2218407e-01 1.7838638e-01 2.2169815e-01 1.9825589e-01 8.0215288e-02 -7.2135308e-02 -1.4381520e-01 -6.8724371e-02 1.0191205e-01 2.3766633e-01 2.3876101e-01 1.1678077e-01 -2.0428168e-02 -5.8973233e-02 3.1326900e-02 1.7391495e-01 2.4558570e-01 1.7650262e-01 1.2444292e-02 -1.1538234e-01 -9.5917970e-02 6.4762165e-02 2.4258524e-01 3.0102251e-01 2.1222960e-01 7.8706189e-02 3.1500466e-02 1.0297577e-01 1.9875173e-01 1.9434906e-01 5.8146667e-02 -1.1941921e-01 -2.1038478e-01 -1.5594967e-01 1.8552198e-03 1.6878529e-01 2.5937416e-01 2.2516346e-01 6.6144472e-02 -1.5623019e-01 -3.3161105e-01 -3.6695732e-01 -2.6565333e-01 -1.3254832e-01 -8.0101064e-02 -1.2531889e-01 -1.8843171e-01 -1.9038956e-01 -1.3230055e-01 -7.0889306e-02 -3.9679280e-02 -2.6286077e-02 -2.3630770e-02 -6.0652834e-02 -1.4929250e-01 -2.2155095e-01 -1.7331044e-01 5.2693564e-03 1.7683919e-01 1.8244690e-01 2.5118458e-02 -1.1051051e-01 -5.1764984e-02 1.6342054e-01 3.1563281e-01 2.3808751e-01 -4.4871135e-03 -1.8778679e-01 -1.6017584e-01 2.3481991e-02 1.9209185e-01 2.4281065e-01 2.1224192e-01 1.8825017e-01 1.9811718e-01 2.0202486e-01 1.6812825e-01 1.1444796e-01 7.2452475e-02 4.0090973e-02 -6.7139529e-03 -6.8721730e-02 -1.1460099e-01 -1.1914168e-01 -8.9852521e-02 -4.5942222e-02 1.0932686e-02 8.1900393e-02 1.3092374e-01 9.0790221e-02 -6.3538148e-02 -2.5119963e-01 -3.2585173e-01 -2.0850925e-01 1.7922009e-02 1.6783753e-01 1.2518317e-01 -4.3517162e-02 -1.5783138e-01 -1.0686847e-01 4.4782565e-02 1.3893172e-01 9.8691579e-02 2.6311282e-03 -1.6073049e-02 7.8512306e-02 1.9453537e-01 2.2504627e-01 1.6121235e-01 7.8124056e-02 2.9774586e-02 -5.3899280e-03 -6.5745322e-02 -1.2329059e-01 -9.5096521e-02 5.5471394e-02 2.5017082e-01 3.4773286e-01 2.6656242e-01 5.3705965e-02 -1.6135006e-01 -2.7310977e-01 -2.6814818e-01 -2.1074926e-01 -1.7743213e-01 -1.9796482e-01 -2.4059041e-01 -2.4663820e-01 -1.8780129e-01 -9.8317382e-02 -4.7848155e-02 -7.3425069e-02 -1.3529842e-01 -1.4739094e-01 -6.2482366e-02 6.8729554e-02 1.3251322e-01 6.1482940e-02 -8.5065014e-02 -1.6074078e-01 -6.7974104e-02 1.3976672e-01 2.9838081e-01 2.8233998e-01 1.1391411e-01 -7.1966946e-02 -1.5876983e-01 -1.3805556e-01 -8.2998592e-02 -5.7864811e-02 -6.5300733e-02 -7.0590592e-02 -5.5847027e-02 -4.1219301e-02 -6.1578267e-02 -1.3176243e-01 -2.2968907e-01 -3.0193311e-01 -2.8770451e-01 -1.5729276e-01 5.4414593e-02 2.5362617e-01 3.4482230e-01 3.0119122e-01 1.8534835e-01 9.6712488e-02 9.3385279e-02 1.6057572e-01 2.4424680e-01 3.0164891e-01 3.1693510e-01 2.8441517e-01 1.9948758e-01 7.3600888e-02 -5.4291337e-02 -1.3721320e-01 -1.5626045e-01 -1.3464149e-01 -1.1510541e-01 -1.2587072e-01 -1.6605420e-01 -2.1242088e-01 -2.3059410e-01 -1.8785957e-01 -7.8188380e-02 5.0484398e-02 1.0697957e-01 2.7421051e-02 -1.4419852e-01 -2.5888039e-01 -1.8018121e-01 7.8519535e-02 3.4009981e-01 4.0793257e-01 2.3842529e-01 -2.7029751e-02 -1.9919385e-01 -2.0420528e-01 -1.1389043e-01 -3.5602606e-02 5.7385906e-04 3.8759790e-02 1.0691941e-01 1.6303496e-01 1.4314046e-01 4.7786789e-02 -4.1030659e-02 -3.5960232e-02 7.0498851e-02 2.0120383e-01 2.6638170e-01 2.3249669e-01 1.2937468e-01 1.3309043e-02 -6.2770099e-02 -5.8936178e-02 3.4143049e-02 1.6425689e-01 2.2228910e-01 1.2062705e-01 -1.0832755e-01 -3.0711352e-01 -3.2002334e-01 -1.4072879e-01 7.6263091e-02 1.6385270e-01 1.0093887e-01 1.7269577e-02 4.3458474e-02 1.6769625e-01 2.4967945e-01 1.7314220e-01 -2.7519776e-02 -1.9806822e-01 -2.1140982e-01 -7.2758850e-02 1.1057470e-01 2.3440218e-01 2.5956640e-01 1.9629970e-01 7.2200120e-02 -6.6390448e-02 -1.4805958e-01 -1.1487691e-01 1.3561014e-02 1.3146288e-01 1.3205007e-01 1.5159726e-02 -9.9141126e-02 -7.9831031e-02 8.4487631e-02 2.6348526e-01 2.9617209e-01 1.3322758e-01 -1.1642178e-01 -2.7289866e-01 -2.2996687e-01 -3.5143323e-02 1.5983180e-01 2.3035457e-01 1.7179773e-01 7.3333592e-02 1.1653452e-02 -1.8499701e-02 -6.7962911e-02 -1.4361094e-01 -1.7665147e-01 -9.1259528e-02 9.8323111e-02 2.6912800e-01 2.8047779e-01 9.9377687e-02 -1.5436535e-01 -2.9569363e-01 -2.3017874e-01 -4.1007324e-02 8.2484352e-02 2.1760384e-02 -1.5212456e-01 -2.4257965e-01 -1.2641528e-01 1.0676585e-01 2.2865135e-01 1.0211687e-01 -1.6408728e-01 -3.0761461e-01 -1.7309336e-01 1.2302931e-01 3.0157576e-01 1.9992664e-01 -6.5766948e-02 -2.2490680e-01 -1.3209725e-01 9.1452627e-02 1.9707770e-01 7.0972862e-02 -1.6016460e-01 -2.7859962e-01 -2.0288880e-01 -4.9817844e-02 1.3587087e-02 -5.2447125e-02 -1.4164147e-01 -1.3776729e-01 -3.9470574e-02 5.4688171e-02 5.9780155e-02 -2.0666265e-02 -1.2306679e-01 -1.9150051e-01 -1.9953793e-01 -1.3072099e-01 1.7129752e-02 1.9139299e-01 2.8015628e-01 1.9737258e-01 -1.0273734e-02 -1.6921879e-01 -1.2914132e-01 8.3866166e-02 2.8290870e-01 3.0288568e-01 1.5939055e-01 1.4121758e-02 -8.0309556e-03 5.7046152e-02 7.8808779e-02 -4.0300321e-04 -9.3021531e-02 -6.6955916e-02 1.0073094e-01 2.8905786e-01 3.4946321e-01 2.4220689e-01 5.3331283e-02 -1.0609621e-01 -1.9358889e-01 -2.2728166e-01 -2.1680862e-01 -1.4144032e-01 -5.2173696e-03 1.1701944e-01 1.2668247e-01 4.8375112e-03 -1.4889224e-01 -1.9905951e-01 -9.9563224e-02 6.4580042e-02 1.5505008e-01 9.7617503e-02 -6.4905019e-02 -2.1769152e-01 -2.6787937e-01 -2.0919394e-01 -1.1033568e-01 -4.3266567e-02 -1.8066266e-02 1.3641281e-02 9.0806946e-02 1.8645977e-01 2.3150216e-01 1.9334856e-01 1.1238648e-01 4.9498545e-02 1.3155560e-02 -3.5876844e-02 -1.0537074e-01 -1.2612890e-01 -1.8934023e-02 1.8850628e-01 3.4290627e-01 3.0108912e-01 9.0554124e-02 -9.4812468e-02 -8.8842381e-02 6.3160674e-02 1.4646977e-01 1.7441277e-02 -2.2104173e-01 -3.1862778e-01 -1.5530235e-01 1.1291463e-01 2.1663682e-01 7.1521680e-02 -1.2722266e-01 -1.3147084e-01 6.8036453e-02 2.2914846e-01 1.4875917e-01 -8.5725554e-02 -1.9280127e-01 -3.7053987e-02 1.9484616e-01 2.0627194e-01 -5.0290692e-02 -2.9703694e-01 -2.4262627e-01 7.3980280e-02 3.1209111e-01 2.0500085e-01 -1.4678863e-01 -3.9620361e-01 -3.3299784e-01 -8.5315346e-02 7.0026906e-02 3.1783466e-02 -5.6224174e-02 -3.8238612e-02 4.1162402e-02 1.4020902e-02 -1.6267337e-01 -3.2229719e-01 -2.8405914e-01 -8.0208074e-02 7.7279407e-02 5.2461001e-02 -5.6931255e-02 -5.7081867e-02 8.4722273e-02 1.8989091e-01 9.1251490e-02 -1.4913841e-01 -3.0047660e-01 -2.2924644e-01 -4.5027749e-02 4.5847665e-02 -1.0582268e-02 -7.0165157e-02 8.8253349e-03 1.7968871e-01 2.6336655e-01 1.6274839e-01 -3.4038513e-02 -1.6866975e-01 -1.7822821e-01 -1.1212378e-01 -2.2511191e-02 9.2633595e-02 2.2273027e-01 2.8312792e-01 1.8855450e-01 -1.3339719e-02 -1.4451328e-01 -7.9411873e-02 9.5243626e-02 1.5825934e-01 8.6924573e-03 -1.9762612e-01 -2.0963986e-01 3.0881541e-02 3.1088543e-01 3.7605990e-01 2.0371110e-01 3.1659734e-03 -4.2255731e-02 2.7937777e-02 4.3768827e-02 -5.0975761e-02 -1.2013869e-01 -1.9514056e-02 1.9409077e-01 3.0061057e-01 1.6772761e-01 -8.4377993e-02 -2.0596833e-01 -8.8137439e-02 1.3053768e-01 2.3231724e-01 1.5592782e-01 3.3546556e-02 1.2609146e-02 8.8143918e-02 1.3076425e-01 5.2445727e-02 -9.1540218e-02 -1.6532665e-01 -8.9700956e-02 9.2256458e-02 2.6287064e-01 3.2206114e-01 2.4782579e-01 1.0180547e-01 -1.2653507e-02 -2.4053903e-02 4.5165362e-02 9.2697417e-02 3.9645255e-02 -7.0244568e-02 -9.7812594e-02 4.0489353e-02 2.5706426e-01 3.5970764e-01 2.4838839e-01 2.8758245e-02 -9.2051146e-02 -1.8531616e-02 1.4540527e-01 2.2483594e-01 1.6366159e-01 6.0613849e-02 2.6700790e-02 4.8805007e-02 2.4088984e-02 -8.7776563e-02 -1.9182802e-01 -1.5875230e-01 2.1332672e-02 2.1574747e-01 2.8121193e-01 1.9605244e-01 5.2140821e-02 -6.0594054e-02 -1.3111027e-01 -1.9003660e-01 -2.3031943e-01 -1.9896872e-01 -7.1576527e-02 8.7126470e-02 1.5966083e-01 8.0700885e-02 -9.6050487e-02 -2.3768453e-01 -2.4174619e-01 -1.1781079e-01 2.4058534e-02 6.3114157e-02 -3.4924911e-02 -1.8708629e-01 -2.5777811e-01 -1.7457598e-01 2.3256558e-03 1.2615984e-01 9.1298660e-02 -7.2869748e-02 -2.3064584e-01 -2.6487668e-01 -1.7896622e-01 -8.1019614e-02 -7.2160218e-02 -1.5109102e-01 -2.2270453e-01 -1.9311631e-01 -5.5949947e-02 1.0558527e-01 1.9015867e-01 1.5010510e-01 9.3491571e-03 -1.6206410e-01 -2.7872156e-01 -2.6789883e-01 -1.0908763e-01 1.3219241e-01 3.2581004e-01 3.6597785e-01 2.5860903e-01 1.1593033e-01 5.3232658e-02 8.9253999e-02 1.5038178e-01 1.6325136e-01 1.2516262e-01 8.1000365e-02 5.6249003e-02 4.1260796e-02 3.6021307e-02 7.0909773e-02 1.5431016e-01 2.1909293e-01 1.6946538e-01 1.3913978e-03 -1.5472276e-01 -1.5445369e-01 -6.5114694e-03 1.1511921e-01 5.3537688e-02 -1.4926948e-01 -2.8563000e-01 -2.0489020e-01 2.2256191e-02 1.8089745e-01 1.3686717e-01 -4.3194077e-02 -1.9185844e-01 -2.2260927e-01 -1.8688905e-01 -1.7299493e-01 -1.9552456e-01 -2.0311384e-01 -1.6521655e-01 -1.1035364e-01 -7.5596967e-02 -5.2167223e-02 -5.0648414e-03 6.7754101e-02 1.2412118e-01 1.2838133e-01 9.0308482e-02 4.0708671e-02 -1.2463102e-02 -7.6325303e-02 -1.2432208e-01 -9.0380523e-02 5.7426602e-02 2.4318485e-01 3.1839858e-01 2.0029814e-01 -2.6893656e-02 -1.7351791e-01 -1.2458940e-01 4.6580380e-02 1.5624992e-01 9.9382689e-02 -5.1882624e-02 -1.4100610e-01 -1.0040874e-01 -1.2845131e-02 -3.6737447e-03 -9.7637188e-02 -2.0172142e-01 -2.1938378e-01 -1.5223806e-01 -7.5818447e-02 -3.6932476e-02 -8.3361793e-03 4.9321106e-02 1.0828653e-01 8.6261922e-02 -5.6487106e-02 -2.4839500e-01 -3.5078033e-01 -2.7598256e-01 -6.2963150e-02 1.5901166e-01 2.7685307e-01 2.7164897e-01 2.1079033e-01 1.7714997e-01 2.0086813e-01 2.4438441e-01 2.4570310e-01 1.8078261e-01 9.0365447e-02 4.4844498e-02 7.6311118e-02 1.4103984e-01 1.5313326e-01 6.6678933e-02 -6.7720328e-02 -1.3565971e-01 -6.6316159e-02 8.3832277e-02 1.6588475e-01 7.6147385e-02 -1.3444251e-01 -2.9759248e-01 -2.8274479e-01 -1.1318459e-01 7.1421886e-02 1.5414324e-01 1.3182338e-01 8.0829372e-02 6.0814130e-02 6.6565578e-02 6.1490382e-02 3.4525574e-02 1.4709018e-02 3.9340413e-02 1.1733787e-01 2.1846966e-01 2.8684125e-01 2.6688313e-01 1.3632576e-01 -6.7370697e-02 -2.5502586e-01 -3.3949317e-01 -3.0013913e-01 -1.9871892e-01 -1.2610649e-01 -1.2941580e-01 -1.8923457e-01 -2.5813995e-01 -3.0533743e-01 -3.1970649e-01 -2.8788006e-01 -1.9500297e-01 -5.4155345e-02 8.1116905e-02 1.5269009e-01 1.4976106e-01 1.1681611e-01 1.0728712e-01 1.3670700e-01 1.8344060e-01 2.2041268e-01 2.2972773e-01 1.9334746e-01 9.8734288e-02 -2.6231283e-02 -9.9070456e-02 -4.1644202e-02 1.2360480e-01 2.5212308e-01 1.9060093e-01 -6.5066267e-02 -3.3581971e-01 -4.0871250e-01 -2.3222990e-01 4.0796545e-02 2.0553146e-01 1.9047036e-01 8.7982654e-02 2.1078714e-02 1.1947834e-02 -7.4158796e-03 -8.0649898e-02 -1.5932177e-01 -1.5963498e-01 -6.7654645e-02 3.3754864e-02 4.5488264e-02 -5.1656648e-02 -1.8439778e-01 -2.5821552e-01 -2.3168258e-01 -1.3075945e-01 -1.4319768e-02 6.0276859e-02 5.2808278e-02 -4.2009846e-02 -1.6857834e-01 -2.1862301e-01 -1.0815610e-01 1.2758494e-01 3.3007803e-01 3.4236071e-01 1.5606744e-01 -7.3906241e-02 -1.7487103e-01 -1.1779263e-01 -2.8797157e-02 -4.2649366e-02 -1.5603253e-01 -2.3465677e-01 -1.6213440e-01 3.1155521e-02 1.9455902e-01 2.0308035e-01 6.4105637e-02 -1.1373221e-01 -2.2912186e-01 -2.4930244e-01 -1.8794162e-01 -6.9023299e-02 6.6894859e-02 1.4860950e-01 1.1319286e-01 -2.1622177e-02 -1.4430675e-01 -1.4139382e-01 -1.4679189e-02 1.0606471e-01 8.3987908e-02 -8.6549724e-02 -2.6473902e-01 -2.8787546e-01 -1.1665499e-01 1.3032718e-01 2.7649250e-01 2.2886289e-01 4.1972959e-02 -1.4166947e-01 -2.1351821e-01 -1.7294568e-01 -9.5242426e-02 -3.9988034e-02 6.0215518e-04 6.4278100e-02 1.4411085e-01 1.7008073e-01 7.6346726e-02 -1.1397897e-01 -2.7942868e-01 -2.8837790e-01 -1.1356283e-01 1.2995490e-01 2.6791352e-01 2.1050936e-01 3.2758432e-02 -8.8492035e-02 -3.6187051e-02 1.3102808e-01 2.2789768e-01 1.2664599e-01 -9.9240525e-02 -2.3008477e-01 -1.1958430e-01 1.3943384e-01 2.8863442e-01 1.6130336e-01 -1.3747854e-01 -3.2522857e-01 -2.2524885e-01 5.3864511e-02 2.3305883e-01 1.5177574e-01 -7.4373920e-02 -1.8870441e-01 -6.7093573e-02 1.6495747e-01 2.8369836e-01 2.0511206e-01 5.1011236e-02 -6.5929875e-03 6.8964562e-02 1.6340844e-01 1.5740112e-01 5.4023734e-02 -4.3471011e-02 -5.1346211e-02 2.3145779e-02 1.1745308e-01 1.8212689e-01 1.9584070e-01 1.4022670e-01 5.9022790e-03 -1.6079919e-01 -2.4935419e-01 -1.7100378e-01 3.1256057e-02 1.8605482e-01 1.4297623e-01 -7.3243962e-02 -2.7593402e-01 -2.9797544e-01 -1.5307840e-01 -4.0914832e-03 2.1269662e-02 -4.1497170e-02 -5.9046655e-02 2.7976789e-02 1.2846949e-01 1.0303296e-01 -7.5938937e-02 -2.8392411e-01 -3.6123552e-01 -2.5664252e-01 -5.3262494e-02 1.2879625e-01 2.3255706e-01 2.6842403e-01 2.5122050e-01 1.7087253e-01 3.4014290e-02 -9.3227815e-02 -1.2001867e-01 -2.1139059e-02 1.2023890e-01 1.7758447e-01 9.6606085e-02 -5.2792108e-02 -1.3892628e-01 -8.4350032e-02 7.1620365e-02 2.1524576e-01 2.5910116e-01 2.0627091e-01 1.2532985e-01 7.1727643e-02 3.8319163e-02 -1.9240088e-02 -1.1662856e-01 -2.1107703e-01 -2.4258539e-01 -1.9809090e-01 -1.2271124e-01 -6.5266079e-02 -2.6001544e-02 2.6587042e-02 8.9979857e-02 1.0112134e-01 -1.6495775e-03 -1.8712095e-01 -3.2285436e-01 -2.8769737e-01 -1.0373843e-01 6.3283390e-02 6.4192144e-02 -6.9141383e-02 -1.4546154e-01 -2.2743165e-02 2.1671482e-01 3.3495240e-01 1.9730942e-01 -6.4245098e-02 -1.8430371e-01 -5.9313975e-02 1.3285821e-01 1.3988590e-01 -6.3313853e-02 -2.3781208e-01 -1.6565753e-01 7.8634007e-02 2.0643470e-01 6.3051903e-02 -1.7337120e-01 -1.9553447e-01 5.8877424e-02 3.1320739e-01 2.6455767e-01 -5.6738794e-02 -3.0614673e-01 -2.0738949e-01 1.4261991e-01 3.9321755e-01 3.3131011e-01 8.6485026e-02 -6.3943179e-02 -2.3354764e-02 5.9552949e-02 3.1845636e-02 -5.2189216e-02 -1.8514555e-02 1.7050716e-01 3.3649462e-01 2.9310084e-01 7.8582244e-02 -8.5200138e-02 -5.9242022e-02 5.3629257e-02 5.3919799e-02 -9.1290610e-02 -1.9983794e-01 -1.0236954e-01 1.3831631e-01 2.9035137e-01 -1.7703630e-01 -1.1470789e-01 -1.7257803e-02 7.3360924e-02 1.2806267e-01 1.3650217e-01 1.0539571e-01 5.4901306e-02 1.0347593e-02 -1.4210364e-02 -2.9316079e-02 -5.9818410e-02 -1.1287079e-01 -1.5651256e-01 -1.3759239e-01 -3.1325918e-02 1.2118952e-01 2.2925439e-01 2.1688928e-01 8.3280850e-02 -9.0968958e-02 -1.9863421e-01 -1.7919413e-01 -5.4874063e-02 9.1323774e-02 1.7241745e-01 1.4973591e-01 5.1202694e-02 -5.0722214e-02 -8.6474562e-02 -3.6675604e-02 5.0794719e-02 9.2852996e-02 3.5475423e-02 -9.8019853e-02 -2.1560266e-01 -2.2054921e-01 -8.4207430e-02 1.2773783e-01 2.9411889e-01 3.1432928e-01 1.7183620e-01 -5.3673166e-02 -2.3087548e-01 -2.5206313e-01 -9.9556443e-02 1.3579254e-01 3.0302360e-01 2.8345210e-01 6.9698019e-02 -2.2311064e-01 -4.2606792e-01 -4.1979542e-01 -2.0235411e-01 1.1680679e-01 3.8269042e-01 4.7499251e-01 3.6130151e-01 1.0698485e-01 -1.5666457e-01 -2.9684785e-01 -2.5130444e-01 -6.7456399e-02 1.2329504e-01 1.8968350e-01 8.9456729e-02 -1.0185072e-01 -2.4339863e-01 -2.2562726e-01 -4.5215735e-02 1.9190737e-01 3.3930982e-01 3.0360010e-01 1.0486525e-01 -1.3364785e-01 -2.6276635e-01 -2.0355127e-01 -1.0514338e-03 2.0109829e-01 2.5410141e-01 1.0538640e-01 -1.6182684e-01 -3.7724711e-01 -3.8906986e-01 -1.6075631e-01 2.0065197e-01 5.0030087e-01 5.6260189e-01 3.3306758e-01 -8.1981699e-02 -4.6637054e-01 -6.1157444e-01 -4.3578631e-01 -3.4787751e-02 3.6943357e-01 5.5331393e-01 4.1651911e-01 3.8203811e-02 -3.6624642e-01 -5.6531588e-01 -4.4111547e-01 -5.7977077e-02 3.6800859e-01 5.8749279e-01 4.6334166e-01 5.9154789e-02 -3.8817476e-01 -6.0585734e-01 -4.5438072e-01 -2.1770889e-02 4.2269933e-01 5.9388393e-01 3.7277877e-01 -1.1367643e-01 -5.6785416e-01 -7.0538273e-01 -4.3261293e-01 9.5667577e-02 5.7311674e-01 7.2849359e-01 4.8697304e-01 9.0040534e-03 -4.1643634e-01 -5.5375692e-01 -3.6053568e-01 1.0675442e-03 2.8391467e-01 3.2050851e-01 1.2014875e-01 -1.5499683e-01 -3.0636590e-01 -2.2845450e-01 3.0168597e-02 3.0447079e-01 4.1814633e-01 2.9408146e-01 3.3795396e-03 -2.8043536e-01 -3.9163122e-01 -2.7524621e-01 -1.6330862e-02 2.2338646e-01 3.1163298e-01 2.1884631e-01 2.0034460e-02 -1.6244160e-01 -2.3122765e-01 -1.5928083e-01 4.5460308e-03 1.6378113e-01 2.2566835e-01 1.5187573e-01 -1.8633628e-02 -1.8835877e-01 -2.5597784e-01 -1.7568160e-01 1.6144538e-02 2.1796548e-01 3.1334397e-01 2.3350541e-01 9.9054075e-04 -2.7139443e-01 -4.3349329e-01 -3.8409180e-01 -1.3941008e-01 1.6850242e-01 3.6865127e-01 3.5669633e-01 1.5962938e-01 -8.6421861e-02 -2.2603591e-01 -1.7879992e-01 1.5608870e-02 2.2316774e-01 2.9540664e-01 1.5777130e-01 -1.3932674e-01 -4.3707134e-01 -5.5308393e-01 -3.9056636e-01 -6.9866596e-03 4.0342788e-01 6.1470960e-01 5.0478901e-01 1.3556472e-01 -2.7661265e-01 -4.8754120e-01 -3.7410263e-01 -1.0933935e-02 3.7332700e-01 5.3265415e-01 3.5296792e-01 -7.5112937e-02 -5.0630963e-01 -6.8543131e-01 -5.0254861e-01 -6.3204556e-02 3.7616490e-01 5.6861420e-01 4.2839911e-01 7.7256895e-02 -2.4286013e-01 -3.2974149e-01 -1.4621212e-01 1.6396591e-01 3.7227253e-01 3.1398669e-01 -1.5203951e-03 -3.8826155e-01 -5.9422715e-01 -4.6290884e-01 -4.4082503e-02 4.2614489e-01 6.6944646e-01 5.4057059e-01 1.1914310e-01 -3.4186097e-01 -5.7361170e-01 -4.5144665e-01 -6.3037624e-02 3.5015696e-01 5.3940241e-01 3.9354970e-01 6.6063109e-05 -4.0735798e-01 -5.8396114e-01 -4.1610263e-01 1.0313382e-02 4.5449701e-01 6.5638620e-01 4.8903578e-01 3.8482894e-02 -4.3952337e-01 -6.6436421e-01 -4.9492372e-01 -1.7915270e-02 4.9445240e-01 7.3828446e-01 5.5772875e-01 4.3827397e-02 -5.1216643e-01 -7.8827423e-01 -6.2373284e-01 -1.1577453e-01 4.4053448e-01 7.3121649e-01 6.0691719e-01 1.6037942e-01 -3.4101558e-01 -6.1837622e-01 -5.3898039e-01 -1.7955555e-01 2.3296574e-01 4.6098842e-01 3.9204767e-01 9.4586522e-02 -2.3425494e-01 -3.9383077e-01 -2.9901136e-01 -2.1727093e-02 2.6290754e-01 3.8667642e-01 2.8641038e-01 3.4299620e-02 -2.1199530e-01 -3.0703990e-01 -2.0539827e-01 1.3733625e-02 1.9989717e-01 2.2856610e-01 8.0442398e-02 -1.4924794e-01 -3.1635143e-01 -3.2043874e-01 -1.6226330e-01 6.7449386e-02 2.5253008e-01 3.1855044e-01 2.6051993e-01 1.2699840e-01 -1.6342455e-02 -1.1750854e-01 -1.5094063e-01 -1.1699324e-01 -3.6407066e-02 5.7070826e-02 1.2470744e-01 1.3295525e-01 6.7237676e-02 -5.6199791e-02 -1.8928499e-01 -2.6860491e-01 -2.4751370e-01 -1.2546869e-01 4.7269068e-02 1.9379936e-01 2.5012057e-01 1.9757699e-01 6.9603172e-02 -6.6884197e-02 -1.4260360e-01 -1.1800895e-01 -4.5690911e-03 1.3505757e-01 2.1176910e-01 1.5667518e-01 -2.9715225e-02 -2.6058872e-01 -4.0072162e-01 -3.4636170e-01 -1.0002597e-01 2.1522385e-01 4.2116592e-01 3.9178740e-01 1.3552073e-01 -2.0194672e-01 -4.2193015e-01 -3.9351670e-01 -1.3365470e-01 2.0423921e-01 4.2544835e-01 4.1162219e-01 1.8730580e-01 -1.0283670e-01 -2.8986993e-01 -2.8756628e-01 -1.3866788e-01 2.8290398e-02 9.5513335e-02 3.5118646e-02 -8.2724881e-02 -1.5147446e-01 -1.0799938e-01 2.6949604e-02 1.6959254e-01 2.3358015e-01 1.8482066e-01 5.6424609e-02 -7.8806247e-02 -1.5583364e-01 -1.5299245e-01 -9.3729273e-02 -1.9708548e-02 3.8600307e-02 7.1469845e-02 7.8472613e-02 5.5625386e-02 -1.0621857e-03 -8.0782039e-02 -1.5057837e-01 -1.6705428e-01 -1.0304932e-01 2.9389143e-02 1.7801990e-01 2.7318425e-01 2.6234323e-01 1.3834554e-01 -5.4215912e-02 -2.3593270e-01 -3.2392000e-01 -2.6898405e-01 -8.5844039e-02 1.4215609e-01 2.9652172e-01 2.8801270e-01 1.1683545e-01 -1.1688760e-01 -2.6947626e-01 -2.4573958e-01 -6.4329645e-02 1.5353975e-01 2.6653313e-01 2.0755588e-01 2.4602079e-02 -1.5772495e-01 -2.2567844e-01 -1.4875573e-01 9.9414396e-03 1.4397851e-01 1.7486115e-01 9.6314112e-02 -3.2169687e-02 -1.2887854e-01 -1.3861783e-01 -5.9693947e-02 6.1826068e-02 1.6117670e-01 1.8758542e-01 1.2643056e-01 4.7038639e-03 -1.2089033e-01 -1.8936563e-01 -1.6676448e-01 -6.8240952e-02 4.6702545e-02 1.0911959e-01 8.7135042e-02 1.1538006e-02 -4.4789930e-02 -2.4262269e-02 6.5437901e-02 1.5116338e-01 1.4886934e-01 3.3820535e-02 -1.3097789e-01 -2.3522600e-01 -2.0099760e-01 -4.2018915e-02 1.4060900e-01 2.2430878e-01 1.4698003e-01 -4.9334401e-02 -2.4015379e-01 -2.9449301e-01 -1.5978257e-01 9.9469238e-02 3.3553927e-01 4.0432846e-01 2.5275189e-01 -4.8157255e-02 -3.4363559e-01 -4.8101858e-01 -3.9093124e-01 -1.2065446e-01 1.9561509e-01 4.0816957e-01 4.2449571e-01 2.4947873e-01 -2.2290220e-02 -2.5535821e-01 -3.3965313e-01 -2.4442241e-01 -3.2717407e-02 1.7386538e-01 2.6131002e-01 1.8344736e-01 -1.4617105e-02 -2.2004617e-01 -3.0989410e-01 -2.1648361e-01 2.9614296e-02 3.0600899e-01 4.6010027e-01 3.9585763e-01 1.3407054e-01 -1.9445050e-01 -4.2254041e-01 -4.4190341e-01 -2.6148822e-01 2.4561144e-03 1.9639531e-01 2.2058130e-01 8.8618067e-02 -8.2771773e-02 -1.5145974e-01 -4.8116921e-02 1.7081593e-01 3.5448643e-01 3.5655964e-01 1.3834184e-01 -1.9528570e-01 -4.5613811e-01 -4.9089820e-01 -2.7873232e-01 5.5837539e-02 3.2156811e-01 3.7683870e-01 2.1007687e-01 -6.1195486e-02 -2.6670692e-01 -2.8529736e-01 -1.1252984e-01 1.4069959e-01 3.1548805e-01 3.0070613e-01 1.0177110e-01 -1.6096596e-01 -3.2711612e-01 -2.9842835e-01 -9.9492033e-02 1.4305421e-01 2.8418081e-01 2.4879424e-01 7.0440776e-02 -1.3708347e-01 -2.5105923e-01 -2.1001593e-01 -4.5285982e-02 1.4155737e-01 2.4209754e-01 2.0725941e-01 7.3959838e-02 -6.6466455e-02 -1.3533231e-01 -1.1722667e-01 -5.6247689e-02 -8.2151160e-03 4.6646596e-03 -5.3013327e-05 6.4836935e-03 3.4885521e-02 7.2093769e-02 9.6085499e-02 9.0621414e-02 5.0063443e-02 -1.9216694e-02 -9.5194586e-02 -1.4177512e-01 -1.2554939e-01 -4.1561203e-02 7.4612994e-02 1.6458119e-01 1.8370169e-01 1.2694288e-01 2.5574339e-02 -7.6209464e-02 -1.4292208e-01 -1.5717793e-01 -1.2150507e-01 -5.7465582e-02 3.0433319e-03 3.8135050e-02 5.3444515e-02 7.4126764e-02 1.1232692e-01 1.4266966e-01 1.1713381e-01 1.2919877e-02 -1.3094351e-01 -2.2903887e-01 -2.1083457e-01 -7.7741149e-02 9.2251468e-02 1.9732652e-01 1.8027267e-01 6.1530912e-02 -8.1015797e-02 -1.6435623e-01 -1.4922825e-01 -5.8874212e-02 3.9408110e-02 7.8379546e-02 3.6886774e-02 -4.2241134e-02 -8.1505612e-02 -2.9557008e-02 9.2798034e-02 2.0055247e-01 2.0414883e-01 7.6944227e-02 -1.2029199e-01 -2.7519345e-01 -2.9408814e-01 -1.6081545e-01 5.1070794e-02 2.1840144e-01 2.3874816e-01 9.4335060e-02 -1.2904879e-01 -2.8774773e-01 -2.6899028e-01 -6.6408095e-02 2.1071698e-01 4.0356249e-01 3.9994180e-01 1.9633323e-01 -1.0730235e-01 -3.6601054e-01 -4.6248715e-01 -3.5922221e-01 -1.1354600e-01 1.4870456e-01 2.9521055e-01 2.5966678e-01 8.3040302e-02 -1.0914113e-01 -1.8742442e-01 -1.0478464e-01 7.3317409e-02 2.1546569e-01 2.1382067e-01 5.6531581e-02 -1.6427012e-01 -3.1183656e-01 -2.9186150e-01 -1.1383004e-01 1.1231696e-01 2.4506533e-01 2.0292544e-01 1.9811075e-02 -1.7391062e-01 -2.3677906e-01 -1.1242105e-01 1.2953875e-01 3.3467916e-01 3.5946938e-01 1.6169418e-01 -1.6880410e-01 -4.5538345e-01 -5.3000472e-01 -3.2991559e-01 5.7588162e-02 4.3386984e-01 5.9508457e-01 4.4813661e-01 6.8860243e-02 -3.3635714e-01 -5.4527976e-01 -4.4370745e-01 -8.9647493e-02 3.1753702e-01 5.4673805e-01 4.6318145e-01 1.0733728e-01 -3.1949400e-01 -5.6446899e-01 -4.7269412e-01 -8.8269356e-02 3.6150197e-01 5.9965309e-01 4.7275161e-01 5.2712510e-02 -4.0097128e-01 -6.0010920e-01 -4.1032807e-01 6.1089052e-02 5.2877389e-01 7.0388838e-01 4.7272792e-01 -3.2841140e-02 -5.1806125e-01 -7.0615746e-01 -5.0443062e-01 -5.3964611e-02 3.6781621e-01 5.2531916e-01 3.6514315e-01 3.1895267e-02 -2.4276338e-01 -2.9561167e-01 -1.2568333e-01 1.2380832e-01 2.6979551e-01 2.0920891e-01 -2.0179145e-02 -2.6980104e-01 -3.7620139e-01 -2.6519009e-01 -1.4966321e-04 2.5905182e-01 3.5875119e-01 2.4783584e-01 5.4317821e-03 -2.1770753e-01 -2.9814845e-01 -2.0810260e-01 -1.7395596e-02 1.5890290e-01 2.2758901e-01 1.6085463e-01 3.3576307e-03 -1.5297196e-01 -2.1737064e-01 -1.5023570e-01 1.2479222e-02 1.7606639e-01 2.4089523e-01 1.6216345e-01 -2.3230254e-02 -2.1504218e-01 -3.0098784e-01 -2.1779026e-01 8.8067567e-03 2.6812984e-01 4.1695437e-01 3.6159556e-01 1.2203070e-01 -1.7147580e-01 -3.5437470e-01 -3.3058973e-01 -1.3341351e-01 9.9954914e-02 2.1969740e-01 1.5589313e-01 -4.1996520e-02 -2.3771826e-01 -2.9083527e-01 -1.4002506e-01 1.5548285e-01 4.3862419e-01 5.3769302e-01 3.6811228e-01 -6.9569482e-03 -3.9769165e-01 -5.8956799e-01 -4.7193386e-01 -1.1138894e-01 2.8025332e-01 4.6943948e-01 3.4372376e-01 -1.6555081e-02 -3.8429530e-01 -5.2185674e-01 -3.2705351e-01 1.0055685e-01 5.1629500e-01 6.7570174e-01 4.8204840e-01 4.6679399e-02 -3.7892485e-01 -5.5799051e-01 -4.1189337e-01 -6.3130989e-02 2.4927425e-01 3.2624429e-01 1.3391859e-01 -1.7899014e-01 -3.7999275e-01 -3.0718591e-01 1.9919795e-02 4.0587411e-01 5.9872071e-01 4.5200311e-01 2.6827172e-02 -4.3774484e-01 -6.7014857e-01 -5.3423365e-01 -1.1312830e-01 3.4367827e-01 5.7281717e-01 4.5156693e-01 6.5481027e-02 -3.4683106e-01 -5.3783781e-01 -3.9562633e-01 -5.2304328e-03 4.0256826e-01 5.8408144e-01 4.2300297e-01 -1.8218267e-04 -4.4833216e-01 -6.5943295e-01 -5.0033881e-01 -5.1578103e-02 4.3192551e-01 6.6545648e-01 5.0237264e-01 2.6477477e-02 -4.8897549e-01 -7.3697545e-01 -5.5960739e-01 -4.7597748e-02 5.0867228e-01 7.8911527e-01 6.3269313e-01 1.3197226e-01 -4.2464681e-01 -7.2603682e-01 -6.1784801e-01 -1.8264666e-01 3.2014735e-01 6.1135123e-01 5.4895999e-01 1.9768580e-01 -2.2062099e-01 -4.6220719e-01 -4.0211731e-01 -9.9950534e-02 2.4465654e-01 4.1872319e-01 3.2500596e-01 3.2810917e-02 -2.7440750e-01 -4.1536442e-01 -3.1832701e-01 -5.5989066e-02 2.0726049e-01 3.1798239e-01 2.2484797e-01 5.1703651e-03 -1.8889751e-01 -2.2927380e-01 -9.1914974e-02 1.3314428e-01 3.0513495e-01 3.2224987e-01 1.7778028e-01 -4.7100451e-02 -2.4007922e-01 -3.2145867e-01 -2.7615883e-01 -1.4545755e-01 4.2822900e-03 1.1399372e-01 1.5138712e-01 1.1530153e-01 3.0234280e-02 -6.4234624e-02 -1.2615802e-01 -1.2407054e-01 -4.9317670e-02 7.5619816e-02 2.0015044e-01 2.6472178e-01 2.3118708e-01 1.0699863e-01 -5.5412012e-02 -1.8550876e-01 -2.3096135e-01 -1.8218227e-01 -7.2615500e-02 4.0881922e-02 1.0372451e-01 8.6362391e-02 -1.1351454e-03 -1.0889033e-01 -1.6548976e-01 -1.1405709e-01 4.6560657e-02 2.4386985e-01 3.6111476e-01 3.0662373e-01 8.1468123e-02 -2.0497551e-01 -3.9165036e-01 -3.6309524e-01 -1.2535574e-01 1.8954273e-01 3.9793935e-01 3.7486538e-01 1.3124068e-01 -1.9174474e-01 -4.0848802e-01 -4.0149539e-01 -1.8960477e-01 9.0301438e-02 2.7507284e-01 2.7972729e-01 1.4341274e-01 -1.2566755e-02 -7.8032703e-02 -2.7425697e-02 7.5351759e-02 1.3487633e-01 9.5488652e-02 -2.4590018e-02 -1.5233210e-01 -2.1189289e-01 -1.7248897e-01 -6.2455423e-02 5.4933614e-02 1.2398028e-01 1.2778044e-01 8.7386392e-02 3.4966577e-02 -1.0850501e-02 -4.6716543e-02 -6.9020828e-02 -6.3681635e-02 -1.6203206e-02 6.7394491e-02 1.5127737e-01 1.8399090e-01 1.2920707e-01 -7.0434827e-03 -1.7216342e-01 -2.8937677e-01 -2.9509198e-01 -1.7314710e-01 3.2745183e-02 2.3542177e-01 3.4097958e-01 2.9247721e-01 1.0411948e-01 -1.3495077e-01 -2.9868629e-01 -2.9240849e-01 -1.1517683e-01 1.2871323e-01 2.8803761e-01 2.6146766e-01 6.7234759e-02 -1.6729947e-01 -2.9180077e-01 -2.3297675e-01 -3.8493954e-02 1.6188055e-01 2.4607750e-01 1.7580193e-01 1.0770499e-02 -1.3917580e-01 -1.8630712e-01 -1.1496682e-01 1.8120146e-02 1.2605380e-01 1.4532251e-01 6.9056099e-02 -5.5814690e-02 -1.6001831e-01 -1.8912751e-01 -1.2778372e-01 -4.4698128e-03 1.2208903e-01 1.8963074e-01 1.6384408e-01 6.0799128e-02 -5.7339158e-02 -1.1860919e-01 -9.0086196e-02 -4.5798607e-03 6.0280807e-02 4.1676388e-02 -5.5180320e-02 -1.5518201e-01 -1.6828578e-01 -6.2049884e-02 1.0561621e-01 2.2337555e-01 2.0643187e-01 5.9839911e-02 -1.2043322e-01 -2.1083864e-01 -1.4415945e-01 4.3538937e-02 2.3203364e-01 2.9044234e-01 1.6171416e-01 -9.5674666e-02 -3.3749265e-01 -4.1795872e-01 -2.7746809e-01 2.0648626e-02 3.2603206e-01 4.8410918e-01 4.1672303e-01 1.5905611e-01 -1.6318595e-01 -3.9931562e-01 -4.4568803e-01 -2.9169291e-01 -2.0960934e-02 2.3175866e-01 3.4693819e-01 2.7877641e-01 7.7125945e-02 -1.4069530e-01 -2.5367798e-01 -2.0150506e-01 -1.6778161e-02 1.9116819e-01 2.9409556e-01 2.1593628e-01 -1.9610708e-02 -2.9401135e-01 -4.5512990e-01 -4.0311941e-01 -1.5075705e-01 1.7921653e-01 4.2153577e-01 4.6143206e-01 2.9688389e-01 3.5275834e-02 -1.7206796e-01 -2.2040717e-01 -1.1280250e-01 4.6014479e-02 1.2005000e-01 3.5297082e-02 -1.6459920e-01 -3.4121448e-01 -3.5130088e-01 -1.4787707e-01 1.7615712e-01 4.3972643e-01 4.8949447e-01 2.9899548e-01 -1.6059656e-02 -2.7414987e-01 -3.4124596e-01 -2.0476598e-01 3.1287353e-02 2.1535118e-01 2.3693813e-01 8.7039128e-02 -1.3914592e-01 -2.9731202e-01 -2.8057123e-01 -8.9244625e-02 1.6445576e-01 3.2621002e-01 2.9949560e-01 1.0678193e-01 -1.3016725e-01 -2.7225661e-01 -2.4687907e-01 -8.3173776e-02 1.1381888e-01 2.2819642e-01 1.9830143e-01 4.8505476e-02 -1.2763594e-01 -2.2560309e-01 -1.9560311e-01 -7.1212054e-02 6.0380807e-02 1.2445307e-01 1.0835168e-01 5.5609724e-02 1.7269294e-02 9.3997346e-03 1.1223045e-02 -4.3543819e-03 -4.2668837e-02 -8.5657964e-02 -1.0909342e-01 -9.7154374e-02 -4.6781850e-02 3.1101930e-02 1.0973840e-01 1.5122945e-01 1.2531404e-01 3.3620966e-02 -8.3194568e-02 -1.6716420e-01 1998. 1999. 2000. 2001. slicot-5.0+20101122/examples/IB03AD.res000077500000000000000000000014141201767322700167440ustar00rootroot00000000000000 IB03AD EXAMPLE PROGRAM RESULTS Final 2-norm of the residuals = 0.2970365D+00 Number of iterations = 87 Number of conjugate gradients iterations = 0 Number of function evaluations = 1322 Number of Jacobian evaluations = 105 Final approximate solution is -0.9728 0.6465 -1.2888 -0.4296 -0.8529 0.3181 0.9778 0.4570 -0.1420 0.8984 -0.6031 0.0697 -1.0822 0.4465 0.6036 0.3792 0.2532 -0.0285 0.4129 0.4833 0.1746 0.5626 0.2150 -0.3343 0.4013 -0.3679 0.5653 0.8092 -0.2363 -0.6361 -0.6818 0.6110 -0.5506 0.9913 0.0352 0.1968 -0.2502 7.0067 -10.7378 2.6900 -59.8756 -0.9898 -0.8296 2.3429 1.3455 -0.2531 -1.1265 0.0326 0.5617 0.1045 slicot-5.0+20101122/examples/IB03BD.dat000077500000000000000000001042021201767322700167230ustar00rootroot00000000000000 IB03BD EXAMPLE PROGRAM DATA 10 1 1 1024 4 12 500 1000 0 .00001 .00001 B 2.2183165e-01 3.9027807e-02 -5.0295887e-02 8.5386224e-03 7.2431159e-02 -1.7082198e-03 -1.7176287e-01 -2.6198104e-01 -1.7194108e-01 1.8566868e-02 1.5625362e-01 1.7463811e-01 1.1564450e-01 2.8779248e-02 -8.4265993e-02 -2.0978501e-01 -2.6591828e-01 -1.7268680e-01 2.1525013e-02 1.4363602e-01 7.3101431e-02 -1.0259212e-01 -1.6380473e-01 -1.0021167e-02 2.0263451e-01 2.1983417e-01 -2.1636523e-02 -3.0986057e-01 -3.8521982e-01 -2.1785179e-01 -1.4761096e-02 3.7005180e-02 -2.8119028e-02 -4.2167901e-02 5.2117694e-02 1.2023747e-01 1.8863385e-02 -1.9506434e-01 -3.0192175e-01 -1.7000747e-01 8.0740471e-02 2.0188076e-01 8.5108288e-02 -1.3270970e-01 -2.3646822e-01 -1.6505385e-01 -4.7448014e-02 -2.7886815e-02 -1.0152026e-01 -1.4155374e-01 -6.1650823e-02 8.3519614e-02 1.5926650e-01 8.6142760e-02 -9.4385381e-02 -2.6609066e-01 -3.2883874e-01 -2.5908050e-01 -1.1648940e-01 -3.0653766e-03 1.0326675e-02 -5.3445909e-02 -9.2412724e-02 -3.0279541e-02 8.4846832e-02 1.1133075e-01 -3.2135250e-02 -2.5308181e-01 -3.5670882e-01 -2.4458860e-01 -2.5254261e-02 9.3714332e-02 1.8643667e-02 -1.4592119e-01 -2.2730880e-01 -1.7140060e-01 -7.4131665e-02 -3.9669515e-02 -5.1266129e-02 -1.1752833e-02 1.0785565e-01 2.0665525e-01 1.6117322e-01 -2.6938653e-02 -2.1941152e-01 -2.7753567e-01 -1.8805912e-01 -4.6845025e-02 5.8585698e-02 1.2218407e-01 1.7838638e-01 2.2169815e-01 1.9825589e-01 8.0215288e-02 -7.2135308e-02 -1.4381520e-01 -6.8724371e-02 1.0191205e-01 2.3766633e-01 2.3876101e-01 1.1678077e-01 -2.0428168e-02 -5.8973233e-02 3.1326900e-02 1.7391495e-01 2.4558570e-01 1.7650262e-01 1.2444292e-02 -1.1538234e-01 -9.5917970e-02 6.4762165e-02 2.4258524e-01 3.0102251e-01 2.1222960e-01 7.8706189e-02 3.1500466e-02 1.0297577e-01 1.9875173e-01 1.9434906e-01 5.8146667e-02 -1.1941921e-01 -2.1038478e-01 -1.5594967e-01 1.8552198e-03 1.6878529e-01 2.5937416e-01 2.2516346e-01 6.6144472e-02 -1.5623019e-01 -3.3161105e-01 -3.6695732e-01 -2.6565333e-01 -1.3254832e-01 -8.0101064e-02 -1.2531889e-01 -1.8843171e-01 -1.9038956e-01 -1.3230055e-01 -7.0889306e-02 -3.9679280e-02 -2.6286077e-02 -2.3630770e-02 -6.0652834e-02 -1.4929250e-01 -2.2155095e-01 -1.7331044e-01 5.2693564e-03 1.7683919e-01 1.8244690e-01 2.5118458e-02 -1.1051051e-01 -5.1764984e-02 1.6342054e-01 3.1563281e-01 2.3808751e-01 -4.4871135e-03 -1.8778679e-01 -1.6017584e-01 2.3481991e-02 1.9209185e-01 2.4281065e-01 2.1224192e-01 1.8825017e-01 1.9811718e-01 2.0202486e-01 1.6812825e-01 1.1444796e-01 7.2452475e-02 4.0090973e-02 -6.7139529e-03 -6.8721730e-02 -1.1460099e-01 -1.1914168e-01 -8.9852521e-02 -4.5942222e-02 1.0932686e-02 8.1900393e-02 1.3092374e-01 9.0790221e-02 -6.3538148e-02 -2.5119963e-01 -3.2585173e-01 -2.0850925e-01 1.7922009e-02 1.6783753e-01 1.2518317e-01 -4.3517162e-02 -1.5783138e-01 -1.0686847e-01 4.4782565e-02 1.3893172e-01 9.8691579e-02 2.6311282e-03 -1.6073049e-02 7.8512306e-02 1.9453537e-01 2.2504627e-01 1.6121235e-01 7.8124056e-02 2.9774586e-02 -5.3899280e-03 -6.5745322e-02 -1.2329059e-01 -9.5096521e-02 5.5471394e-02 2.5017082e-01 3.4773286e-01 2.6656242e-01 5.3705965e-02 -1.6135006e-01 -2.7310977e-01 -2.6814818e-01 -2.1074926e-01 -1.7743213e-01 -1.9796482e-01 -2.4059041e-01 -2.4663820e-01 -1.8780129e-01 -9.8317382e-02 -4.7848155e-02 -7.3425069e-02 -1.3529842e-01 -1.4739094e-01 -6.2482366e-02 6.8729554e-02 1.3251322e-01 6.1482940e-02 -8.5065014e-02 -1.6074078e-01 -6.7974104e-02 1.3976672e-01 2.9838081e-01 2.8233998e-01 1.1391411e-01 -7.1966946e-02 -1.5876983e-01 -1.3805556e-01 -8.2998592e-02 -5.7864811e-02 -6.5300733e-02 -7.0590592e-02 -5.5847027e-02 -4.1219301e-02 -6.1578267e-02 -1.3176243e-01 -2.2968907e-01 -3.0193311e-01 -2.8770451e-01 -1.5729276e-01 5.4414593e-02 2.5362617e-01 3.4482230e-01 3.0119122e-01 1.8534835e-01 9.6712488e-02 9.3385279e-02 1.6057572e-01 2.4424680e-01 3.0164891e-01 3.1693510e-01 2.8441517e-01 1.9948758e-01 7.3600888e-02 -5.4291337e-02 -1.3721320e-01 -1.5626045e-01 -1.3464149e-01 -1.1510541e-01 -1.2587072e-01 -1.6605420e-01 -2.1242088e-01 -2.3059410e-01 -1.8785957e-01 -7.8188380e-02 5.0484398e-02 1.0697957e-01 2.7421051e-02 -1.4419852e-01 -2.5888039e-01 -1.8018121e-01 7.8519535e-02 3.4009981e-01 4.0793257e-01 2.3842529e-01 -2.7029751e-02 -1.9919385e-01 -2.0420528e-01 -1.1389043e-01 -3.5602606e-02 5.7385906e-04 3.8759790e-02 1.0691941e-01 1.6303496e-01 1.4314046e-01 4.7786789e-02 -4.1030659e-02 -3.5960232e-02 7.0498851e-02 2.0120383e-01 2.6638170e-01 2.3249669e-01 1.2937468e-01 1.3309043e-02 -6.2770099e-02 -5.8936178e-02 3.4143049e-02 1.6425689e-01 2.2228910e-01 1.2062705e-01 -1.0832755e-01 -3.0711352e-01 -3.2002334e-01 -1.4072879e-01 7.6263091e-02 1.6385270e-01 1.0093887e-01 1.7269577e-02 4.3458474e-02 1.6769625e-01 2.4967945e-01 1.7314220e-01 -2.7519776e-02 -1.9806822e-01 -2.1140982e-01 -7.2758850e-02 1.1057470e-01 2.3440218e-01 2.5956640e-01 1.9629970e-01 7.2200120e-02 -6.6390448e-02 -1.4805958e-01 -1.1487691e-01 1.3561014e-02 1.3146288e-01 1.3205007e-01 1.5159726e-02 -9.9141126e-02 -7.9831031e-02 8.4487631e-02 2.6348526e-01 2.9617209e-01 1.3322758e-01 -1.1642178e-01 -2.7289866e-01 -2.2996687e-01 -3.5143323e-02 1.5983180e-01 2.3035457e-01 1.7179773e-01 7.3333592e-02 1.1653452e-02 -1.8499701e-02 -6.7962911e-02 -1.4361094e-01 -1.7665147e-01 -9.1259528e-02 9.8323111e-02 2.6912800e-01 2.8047779e-01 9.9377687e-02 -1.5436535e-01 -2.9569363e-01 -2.3017874e-01 -4.1007324e-02 8.2484352e-02 2.1760384e-02 -1.5212456e-01 -2.4257965e-01 -1.2641528e-01 1.0676585e-01 2.2865135e-01 1.0211687e-01 -1.6408728e-01 -3.0761461e-01 -1.7309336e-01 1.2302931e-01 3.0157576e-01 1.9992664e-01 -6.5766948e-02 -2.2490680e-01 -1.3209725e-01 9.1452627e-02 1.9707770e-01 7.0972862e-02 -1.6016460e-01 -2.7859962e-01 -2.0288880e-01 -4.9817844e-02 1.3587087e-02 -5.2447125e-02 -1.4164147e-01 -1.3776729e-01 -3.9470574e-02 5.4688171e-02 5.9780155e-02 -2.0666265e-02 -1.2306679e-01 -1.9150051e-01 -1.9953793e-01 -1.3072099e-01 1.7129752e-02 1.9139299e-01 2.8015628e-01 1.9737258e-01 -1.0273734e-02 -1.6921879e-01 -1.2914132e-01 8.3866166e-02 2.8290870e-01 3.0288568e-01 1.5939055e-01 1.4121758e-02 -8.0309556e-03 5.7046152e-02 7.8808779e-02 -4.0300321e-04 -9.3021531e-02 -6.6955916e-02 1.0073094e-01 2.8905786e-01 3.4946321e-01 2.4220689e-01 5.3331283e-02 -1.0609621e-01 -1.9358889e-01 -2.2728166e-01 -2.1680862e-01 -1.4144032e-01 -5.2173696e-03 1.1701944e-01 1.2668247e-01 4.8375112e-03 -1.4889224e-01 -1.9905951e-01 -9.9563224e-02 6.4580042e-02 1.5505008e-01 9.7617503e-02 -6.4905019e-02 -2.1769152e-01 -2.6787937e-01 -2.0919394e-01 -1.1033568e-01 -4.3266567e-02 -1.8066266e-02 1.3641281e-02 9.0806946e-02 1.8645977e-01 2.3150216e-01 1.9334856e-01 1.1238648e-01 4.9498545e-02 1.3155560e-02 -3.5876844e-02 -1.0537074e-01 -1.2612890e-01 -1.8934023e-02 1.8850628e-01 3.4290627e-01 3.0108912e-01 9.0554124e-02 -9.4812468e-02 -8.8842381e-02 6.3160674e-02 1.4646977e-01 1.7441277e-02 -2.2104173e-01 -3.1862778e-01 -1.5530235e-01 1.1291463e-01 2.1663682e-01 7.1521680e-02 -1.2722266e-01 -1.3147084e-01 6.8036453e-02 2.2914846e-01 1.4875917e-01 -8.5725554e-02 -1.9280127e-01 -3.7053987e-02 1.9484616e-01 2.0627194e-01 -5.0290692e-02 -2.9703694e-01 -2.4262627e-01 7.3980280e-02 3.1209111e-01 2.0500085e-01 -1.4678863e-01 -3.9620361e-01 -3.3299784e-01 -8.5315346e-02 7.0026906e-02 3.1783466e-02 -5.6224174e-02 -3.8238612e-02 4.1162402e-02 1.4020902e-02 -1.6267337e-01 -3.2229719e-01 -2.8405914e-01 -8.0208074e-02 7.7279407e-02 5.2461001e-02 -5.6931255e-02 -5.7081867e-02 8.4722273e-02 1.8989091e-01 9.1251490e-02 -1.4913841e-01 -3.0047660e-01 -2.2924644e-01 -4.5027749e-02 4.5847665e-02 -1.0582268e-02 -7.0165157e-02 8.8253349e-03 1.7968871e-01 2.6336655e-01 1.6274839e-01 -3.4038513e-02 -1.6866975e-01 -1.7822821e-01 -1.1212378e-01 -2.2511191e-02 9.2633595e-02 2.2273027e-01 2.8312792e-01 1.8855450e-01 -1.3339719e-02 -1.4451328e-01 -7.9411873e-02 9.5243626e-02 1.5825934e-01 8.6924573e-03 -1.9762612e-01 -2.0963986e-01 3.0881541e-02 3.1088543e-01 3.7605990e-01 2.0371110e-01 3.1659734e-03 -4.2255731e-02 2.7937777e-02 4.3768827e-02 -5.0975761e-02 -1.2013869e-01 -1.9514056e-02 1.9409077e-01 3.0061057e-01 1.6772761e-01 -8.4377993e-02 -2.0596833e-01 -8.8137439e-02 1.3053768e-01 2.3231724e-01 1.5592782e-01 3.3546556e-02 1.2609146e-02 8.8143918e-02 1.3076425e-01 5.2445727e-02 -9.1540218e-02 -1.6532665e-01 -8.9700956e-02 9.2256458e-02 2.6287064e-01 3.2206114e-01 2.4782579e-01 1.0180547e-01 -1.2653507e-02 -2.4053903e-02 4.5165362e-02 9.2697417e-02 3.9645255e-02 -7.0244568e-02 -9.7812594e-02 4.0489353e-02 2.5706426e-01 3.5970764e-01 2.4838839e-01 2.8758245e-02 -9.2051146e-02 -1.8531616e-02 1.4540527e-01 2.2483594e-01 1.6366159e-01 6.0613849e-02 2.6700790e-02 4.8805007e-02 2.4088984e-02 -8.7776563e-02 -1.9182802e-01 -1.5875230e-01 2.1332672e-02 2.1574747e-01 2.8121193e-01 1.9605244e-01 5.2140821e-02 -6.0594054e-02 -1.3111027e-01 -1.9003660e-01 -2.3031943e-01 -1.9896872e-01 -7.1576527e-02 8.7126470e-02 1.5966083e-01 8.0700885e-02 -9.6050487e-02 -2.3768453e-01 -2.4174619e-01 -1.1781079e-01 2.4058534e-02 6.3114157e-02 -3.4924911e-02 -1.8708629e-01 -2.5777811e-01 -1.7457598e-01 2.3256558e-03 1.2615984e-01 9.1298660e-02 -7.2869748e-02 -2.3064584e-01 -2.6487668e-01 -1.7896622e-01 -8.1019614e-02 -7.2160218e-02 -1.5109102e-01 -2.2270453e-01 -1.9311631e-01 -5.5949947e-02 1.0558527e-01 1.9015867e-01 1.5010510e-01 9.3491571e-03 -1.6206410e-01 -2.7872156e-01 -2.6789883e-01 -1.0908763e-01 1.3219241e-01 3.2581004e-01 3.6597785e-01 2.5860903e-01 1.1593033e-01 5.3232658e-02 8.9253999e-02 1.5038178e-01 1.6325136e-01 1.2516262e-01 8.1000365e-02 5.6249003e-02 4.1260796e-02 3.6021307e-02 7.0909773e-02 1.5431016e-01 2.1909293e-01 1.6946538e-01 1.3913978e-03 -1.5472276e-01 -1.5445369e-01 -6.5114694e-03 1.1511921e-01 5.3537688e-02 -1.4926948e-01 -2.8563000e-01 -2.0489020e-01 2.2256191e-02 1.8089745e-01 1.3686717e-01 -4.3194077e-02 -1.9185844e-01 -2.2260927e-01 -1.8688905e-01 -1.7299493e-01 -1.9552456e-01 -2.0311384e-01 -1.6521655e-01 -1.1035364e-01 -7.5596967e-02 -5.2167223e-02 -5.0648414e-03 6.7754101e-02 1.2412118e-01 1.2838133e-01 9.0308482e-02 4.0708671e-02 -1.2463102e-02 -7.6325303e-02 -1.2432208e-01 -9.0380523e-02 5.7426602e-02 2.4318485e-01 3.1839858e-01 2.0029814e-01 -2.6893656e-02 -1.7351791e-01 -1.2458940e-01 4.6580380e-02 1.5624992e-01 9.9382689e-02 -5.1882624e-02 -1.4100610e-01 -1.0040874e-01 -1.2845131e-02 -3.6737447e-03 -9.7637188e-02 -2.0172142e-01 -2.1938378e-01 -1.5223806e-01 -7.5818447e-02 -3.6932476e-02 -8.3361793e-03 4.9321106e-02 1.0828653e-01 8.6261922e-02 -5.6487106e-02 -2.4839500e-01 -3.5078033e-01 -2.7598256e-01 -6.2963150e-02 1.5901166e-01 2.7685307e-01 2.7164897e-01 2.1079033e-01 1.7714997e-01 2.0086813e-01 2.4438441e-01 2.4570310e-01 1.8078261e-01 9.0365447e-02 4.4844498e-02 7.6311118e-02 1.4103984e-01 1.5313326e-01 6.6678933e-02 -6.7720328e-02 -1.3565971e-01 -6.6316159e-02 8.3832277e-02 1.6588475e-01 7.6147385e-02 -1.3444251e-01 -2.9759248e-01 -2.8274479e-01 -1.1318459e-01 7.1421886e-02 1.5414324e-01 1.3182338e-01 8.0829372e-02 6.0814130e-02 6.6565578e-02 6.1490382e-02 3.4525574e-02 1.4709018e-02 3.9340413e-02 1.1733787e-01 2.1846966e-01 2.8684125e-01 2.6688313e-01 1.3632576e-01 -6.7370697e-02 -2.5502586e-01 -3.3949317e-01 -3.0013913e-01 -1.9871892e-01 -1.2610649e-01 -1.2941580e-01 -1.8923457e-01 -2.5813995e-01 -3.0533743e-01 -3.1970649e-01 -2.8788006e-01 -1.9500297e-01 -5.4155345e-02 8.1116905e-02 1.5269009e-01 1.4976106e-01 1.1681611e-01 1.0728712e-01 1.3670700e-01 1.8344060e-01 2.2041268e-01 2.2972773e-01 1.9334746e-01 9.8734288e-02 -2.6231283e-02 -9.9070456e-02 -4.1644202e-02 1.2360480e-01 2.5212308e-01 1.9060093e-01 -6.5066267e-02 -3.3581971e-01 -4.0871250e-01 -2.3222990e-01 4.0796545e-02 2.0553146e-01 1.9047036e-01 8.7982654e-02 2.1078714e-02 1.1947834e-02 -7.4158796e-03 -8.0649898e-02 -1.5932177e-01 -1.5963498e-01 -6.7654645e-02 3.3754864e-02 4.5488264e-02 -5.1656648e-02 -1.8439778e-01 -2.5821552e-01 -2.3168258e-01 -1.3075945e-01 -1.4319768e-02 6.0276859e-02 5.2808278e-02 -4.2009846e-02 -1.6857834e-01 -2.1862301e-01 -1.0815610e-01 1.2758494e-01 3.3007803e-01 3.4236071e-01 1.5606744e-01 -7.3906241e-02 -1.7487103e-01 -1.1779263e-01 -2.8797157e-02 -4.2649366e-02 -1.5603253e-01 -2.3465677e-01 -1.6213440e-01 3.1155521e-02 1.9455902e-01 2.0308035e-01 6.4105637e-02 -1.1373221e-01 -2.2912186e-01 -2.4930244e-01 -1.8794162e-01 -6.9023299e-02 6.6894859e-02 1.4860950e-01 1.1319286e-01 -2.1622177e-02 -1.4430675e-01 -1.4139382e-01 -1.4679189e-02 1.0606471e-01 8.3987908e-02 -8.6549724e-02 -2.6473902e-01 -2.8787546e-01 -1.1665499e-01 1.3032718e-01 2.7649250e-01 2.2886289e-01 4.1972959e-02 -1.4166947e-01 -2.1351821e-01 -1.7294568e-01 -9.5242426e-02 -3.9988034e-02 6.0215518e-04 6.4278100e-02 1.4411085e-01 1.7008073e-01 7.6346726e-02 -1.1397897e-01 -2.7942868e-01 -2.8837790e-01 -1.1356283e-01 1.2995490e-01 2.6791352e-01 2.1050936e-01 3.2758432e-02 -8.8492035e-02 -3.6187051e-02 1.3102808e-01 2.2789768e-01 1.2664599e-01 -9.9240525e-02 -2.3008477e-01 -1.1958430e-01 1.3943384e-01 2.8863442e-01 1.6130336e-01 -1.3747854e-01 -3.2522857e-01 -2.2524885e-01 5.3864511e-02 2.3305883e-01 1.5177574e-01 -7.4373920e-02 -1.8870441e-01 -6.7093573e-02 1.6495747e-01 2.8369836e-01 2.0511206e-01 5.1011236e-02 -6.5929875e-03 6.8964562e-02 1.6340844e-01 1.5740112e-01 5.4023734e-02 -4.3471011e-02 -5.1346211e-02 2.3145779e-02 1.1745308e-01 1.8212689e-01 1.9584070e-01 1.4022670e-01 5.9022790e-03 -1.6079919e-01 -2.4935419e-01 -1.7100378e-01 3.1256057e-02 1.8605482e-01 1.4297623e-01 -7.3243962e-02 -2.7593402e-01 -2.9797544e-01 -1.5307840e-01 -4.0914832e-03 2.1269662e-02 -4.1497170e-02 -5.9046655e-02 2.7976789e-02 1.2846949e-01 1.0303296e-01 -7.5938937e-02 -2.8392411e-01 -3.6123552e-01 -2.5664252e-01 -5.3262494e-02 1.2879625e-01 2.3255706e-01 2.6842403e-01 2.5122050e-01 1.7087253e-01 3.4014290e-02 -9.3227815e-02 -1.2001867e-01 -2.1139059e-02 1.2023890e-01 1.7758447e-01 9.6606085e-02 -5.2792108e-02 -1.3892628e-01 -8.4350032e-02 7.1620365e-02 2.1524576e-01 2.5910116e-01 2.0627091e-01 1.2532985e-01 7.1727643e-02 3.8319163e-02 -1.9240088e-02 -1.1662856e-01 -2.1107703e-01 -2.4258539e-01 -1.9809090e-01 -1.2271124e-01 -6.5266079e-02 -2.6001544e-02 2.6587042e-02 8.9979857e-02 1.0112134e-01 -1.6495775e-03 -1.8712095e-01 -3.2285436e-01 -2.8769737e-01 -1.0373843e-01 6.3283390e-02 6.4192144e-02 -6.9141383e-02 -1.4546154e-01 -2.2743165e-02 2.1671482e-01 3.3495240e-01 1.9730942e-01 -6.4245098e-02 -1.8430371e-01 -5.9313975e-02 1.3285821e-01 1.3988590e-01 -6.3313853e-02 -2.3781208e-01 -1.6565753e-01 7.8634007e-02 2.0643470e-01 6.3051903e-02 -1.7337120e-01 -1.9553447e-01 5.8877424e-02 3.1320739e-01 2.6455767e-01 -5.6738794e-02 -3.0614673e-01 -2.0738949e-01 1.4261991e-01 3.9321755e-01 3.3131011e-01 8.6485026e-02 -6.3943179e-02 -2.3354764e-02 5.9552949e-02 3.1845636e-02 -5.2189216e-02 -1.8514555e-02 1.7050716e-01 3.3649462e-01 2.9310084e-01 7.8582244e-02 -8.5200138e-02 -5.9242022e-02 5.3629257e-02 5.3919799e-02 -9.1290610e-02 -1.9983794e-01 -1.0236954e-01 1.3831631e-01 2.9035137e-01 -1.7703630e-01 -1.1470789e-01 -1.7257803e-02 7.3360924e-02 1.2806267e-01 1.3650217e-01 1.0539571e-01 5.4901306e-02 1.0347593e-02 -1.4210364e-02 -2.9316079e-02 -5.9818410e-02 -1.1287079e-01 -1.5651256e-01 -1.3759239e-01 -3.1325918e-02 1.2118952e-01 2.2925439e-01 2.1688928e-01 8.3280850e-02 -9.0968958e-02 -1.9863421e-01 -1.7919413e-01 -5.4874063e-02 9.1323774e-02 1.7241745e-01 1.4973591e-01 5.1202694e-02 -5.0722214e-02 -8.6474562e-02 -3.6675604e-02 5.0794719e-02 9.2852996e-02 3.5475423e-02 -9.8019853e-02 -2.1560266e-01 -2.2054921e-01 -8.4207430e-02 1.2773783e-01 2.9411889e-01 3.1432928e-01 1.7183620e-01 -5.3673166e-02 -2.3087548e-01 -2.5206313e-01 -9.9556443e-02 1.3579254e-01 3.0302360e-01 2.8345210e-01 6.9698019e-02 -2.2311064e-01 -4.2606792e-01 -4.1979542e-01 -2.0235411e-01 1.1680679e-01 3.8269042e-01 4.7499251e-01 3.6130151e-01 1.0698485e-01 -1.5666457e-01 -2.9684785e-01 -2.5130444e-01 -6.7456399e-02 1.2329504e-01 1.8968350e-01 8.9456729e-02 -1.0185072e-01 -2.4339863e-01 -2.2562726e-01 -4.5215735e-02 1.9190737e-01 3.3930982e-01 3.0360010e-01 1.0486525e-01 -1.3364785e-01 -2.6276635e-01 -2.0355127e-01 -1.0514338e-03 2.0109829e-01 2.5410141e-01 1.0538640e-01 -1.6182684e-01 -3.7724711e-01 -3.8906986e-01 -1.6075631e-01 2.0065197e-01 5.0030087e-01 5.6260189e-01 3.3306758e-01 -8.1981699e-02 -4.6637054e-01 -6.1157444e-01 -4.3578631e-01 -3.4787751e-02 3.6943357e-01 5.5331393e-01 4.1651911e-01 3.8203811e-02 -3.6624642e-01 -5.6531588e-01 -4.4111547e-01 -5.7977077e-02 3.6800859e-01 5.8749279e-01 4.6334166e-01 5.9154789e-02 -3.8817476e-01 -6.0585734e-01 -4.5438072e-01 -2.1770889e-02 4.2269933e-01 5.9388393e-01 3.7277877e-01 -1.1367643e-01 -5.6785416e-01 -7.0538273e-01 -4.3261293e-01 9.5667577e-02 5.7311674e-01 7.2849359e-01 4.8697304e-01 9.0040534e-03 -4.1643634e-01 -5.5375692e-01 -3.6053568e-01 1.0675442e-03 2.8391467e-01 3.2050851e-01 1.2014875e-01 -1.5499683e-01 -3.0636590e-01 -2.2845450e-01 3.0168597e-02 3.0447079e-01 4.1814633e-01 2.9408146e-01 3.3795396e-03 -2.8043536e-01 -3.9163122e-01 -2.7524621e-01 -1.6330862e-02 2.2338646e-01 3.1163298e-01 2.1884631e-01 2.0034460e-02 -1.6244160e-01 -2.3122765e-01 -1.5928083e-01 4.5460308e-03 1.6378113e-01 2.2566835e-01 1.5187573e-01 -1.8633628e-02 -1.8835877e-01 -2.5597784e-01 -1.7568160e-01 1.6144538e-02 2.1796548e-01 3.1334397e-01 2.3350541e-01 9.9054075e-04 -2.7139443e-01 -4.3349329e-01 -3.8409180e-01 -1.3941008e-01 1.6850242e-01 3.6865127e-01 3.5669633e-01 1.5962938e-01 -8.6421861e-02 -2.2603591e-01 -1.7879992e-01 1.5608870e-02 2.2316774e-01 2.9540664e-01 1.5777130e-01 -1.3932674e-01 -4.3707134e-01 -5.5308393e-01 -3.9056636e-01 -6.9866596e-03 4.0342788e-01 6.1470960e-01 5.0478901e-01 1.3556472e-01 -2.7661265e-01 -4.8754120e-01 -3.7410263e-01 -1.0933935e-02 3.7332700e-01 5.3265415e-01 3.5296792e-01 -7.5112937e-02 -5.0630963e-01 -6.8543131e-01 -5.0254861e-01 -6.3204556e-02 3.7616490e-01 5.6861420e-01 4.2839911e-01 7.7256895e-02 -2.4286013e-01 -3.2974149e-01 -1.4621212e-01 1.6396591e-01 3.7227253e-01 3.1398669e-01 -1.5203951e-03 -3.8826155e-01 -5.9422715e-01 -4.6290884e-01 -4.4082503e-02 4.2614489e-01 6.6944646e-01 5.4057059e-01 1.1914310e-01 -3.4186097e-01 -5.7361170e-01 -4.5144665e-01 -6.3037624e-02 3.5015696e-01 5.3940241e-01 3.9354970e-01 6.6063109e-05 -4.0735798e-01 -5.8396114e-01 -4.1610263e-01 1.0313382e-02 4.5449701e-01 6.5638620e-01 4.8903578e-01 3.8482894e-02 -4.3952337e-01 -6.6436421e-01 -4.9492372e-01 -1.7915270e-02 4.9445240e-01 7.3828446e-01 5.5772875e-01 4.3827397e-02 -5.1216643e-01 -7.8827423e-01 -6.2373284e-01 -1.1577453e-01 4.4053448e-01 7.3121649e-01 6.0691719e-01 1.6037942e-01 -3.4101558e-01 -6.1837622e-01 -5.3898039e-01 -1.7955555e-01 2.3296574e-01 4.6098842e-01 3.9204767e-01 9.4586522e-02 -2.3425494e-01 -3.9383077e-01 -2.9901136e-01 -2.1727093e-02 2.6290754e-01 3.8667642e-01 2.8641038e-01 3.4299620e-02 -2.1199530e-01 -3.0703990e-01 -2.0539827e-01 1.3733625e-02 1.9989717e-01 2.2856610e-01 8.0442398e-02 -1.4924794e-01 -3.1635143e-01 -3.2043874e-01 -1.6226330e-01 6.7449386e-02 2.5253008e-01 3.1855044e-01 2.6051993e-01 1.2699840e-01 -1.6342455e-02 -1.1750854e-01 -1.5094063e-01 -1.1699324e-01 -3.6407066e-02 5.7070826e-02 1.2470744e-01 1.3295525e-01 6.7237676e-02 -5.6199791e-02 -1.8928499e-01 -2.6860491e-01 -2.4751370e-01 -1.2546869e-01 4.7269068e-02 1.9379936e-01 2.5012057e-01 1.9757699e-01 6.9603172e-02 -6.6884197e-02 -1.4260360e-01 -1.1800895e-01 -4.5690911e-03 1.3505757e-01 2.1176910e-01 1.5667518e-01 -2.9715225e-02 -2.6058872e-01 -4.0072162e-01 -3.4636170e-01 -1.0002597e-01 2.1522385e-01 4.2116592e-01 3.9178740e-01 1.3552073e-01 -2.0194672e-01 -4.2193015e-01 -3.9351670e-01 -1.3365470e-01 2.0423921e-01 4.2544835e-01 4.1162219e-01 1.8730580e-01 -1.0283670e-01 -2.8986993e-01 -2.8756628e-01 -1.3866788e-01 2.8290398e-02 9.5513335e-02 3.5118646e-02 -8.2724881e-02 -1.5147446e-01 -1.0799938e-01 2.6949604e-02 1.6959254e-01 2.3358015e-01 1.8482066e-01 5.6424609e-02 -7.8806247e-02 -1.5583364e-01 -1.5299245e-01 -9.3729273e-02 -1.9708548e-02 3.8600307e-02 7.1469845e-02 7.8472613e-02 5.5625386e-02 -1.0621857e-03 -8.0782039e-02 -1.5057837e-01 -1.6705428e-01 -1.0304932e-01 2.9389143e-02 1.7801990e-01 2.7318425e-01 2.6234323e-01 1.3834554e-01 -5.4215912e-02 -2.3593270e-01 -3.2392000e-01 -2.6898405e-01 -8.5844039e-02 1.4215609e-01 2.9652172e-01 2.8801270e-01 1.1683545e-01 -1.1688760e-01 -2.6947626e-01 -2.4573958e-01 -6.4329645e-02 1.5353975e-01 2.6653313e-01 2.0755588e-01 2.4602079e-02 -1.5772495e-01 -2.2567844e-01 -1.4875573e-01 9.9414396e-03 1.4397851e-01 1.7486115e-01 9.6314112e-02 -3.2169687e-02 -1.2887854e-01 -1.3861783e-01 -5.9693947e-02 6.1826068e-02 1.6117670e-01 1.8758542e-01 1.2643056e-01 4.7038639e-03 -1.2089033e-01 -1.8936563e-01 -1.6676448e-01 -6.8240952e-02 4.6702545e-02 1.0911959e-01 8.7135042e-02 1.1538006e-02 -4.4789930e-02 -2.4262269e-02 6.5437901e-02 1.5116338e-01 1.4886934e-01 3.3820535e-02 -1.3097789e-01 -2.3522600e-01 -2.0099760e-01 -4.2018915e-02 1.4060900e-01 2.2430878e-01 1.4698003e-01 -4.9334401e-02 -2.4015379e-01 -2.9449301e-01 -1.5978257e-01 9.9469238e-02 3.3553927e-01 4.0432846e-01 2.5275189e-01 -4.8157255e-02 -3.4363559e-01 -4.8101858e-01 -3.9093124e-01 -1.2065446e-01 1.9561509e-01 4.0816957e-01 4.2449571e-01 2.4947873e-01 -2.2290220e-02 -2.5535821e-01 -3.3965313e-01 -2.4442241e-01 -3.2717407e-02 1.7386538e-01 2.6131002e-01 1.8344736e-01 -1.4617105e-02 -2.2004617e-01 -3.0989410e-01 -2.1648361e-01 2.9614296e-02 3.0600899e-01 4.6010027e-01 3.9585763e-01 1.3407054e-01 -1.9445050e-01 -4.2254041e-01 -4.4190341e-01 -2.6148822e-01 2.4561144e-03 1.9639531e-01 2.2058130e-01 8.8618067e-02 -8.2771773e-02 -1.5145974e-01 -4.8116921e-02 1.7081593e-01 3.5448643e-01 3.5655964e-01 1.3834184e-01 -1.9528570e-01 -4.5613811e-01 -4.9089820e-01 -2.7873232e-01 5.5837539e-02 3.2156811e-01 3.7683870e-01 2.1007687e-01 -6.1195486e-02 -2.6670692e-01 -2.8529736e-01 -1.1252984e-01 1.4069959e-01 3.1548805e-01 3.0070613e-01 1.0177110e-01 -1.6096596e-01 -3.2711612e-01 -2.9842835e-01 -9.9492033e-02 1.4305421e-01 2.8418081e-01 2.4879424e-01 7.0440776e-02 -1.3708347e-01 -2.5105923e-01 -2.1001593e-01 -4.5285982e-02 1.4155737e-01 2.4209754e-01 2.0725941e-01 7.3959838e-02 -6.6466455e-02 -1.3533231e-01 -1.1722667e-01 -5.6247689e-02 -8.2151160e-03 4.6646596e-03 -5.3013327e-05 6.4836935e-03 3.4885521e-02 7.2093769e-02 9.6085499e-02 9.0621414e-02 5.0063443e-02 -1.9216694e-02 -9.5194586e-02 -1.4177512e-01 -1.2554939e-01 -4.1561203e-02 7.4612994e-02 1.6458119e-01 1.8370169e-01 1.2694288e-01 2.5574339e-02 -7.6209464e-02 -1.4292208e-01 -1.5717793e-01 -1.2150507e-01 -5.7465582e-02 3.0433319e-03 3.8135050e-02 5.3444515e-02 7.4126764e-02 1.1232692e-01 1.4266966e-01 1.1713381e-01 1.2919877e-02 -1.3094351e-01 -2.2903887e-01 -2.1083457e-01 -7.7741149e-02 9.2251468e-02 1.9732652e-01 1.8027267e-01 6.1530912e-02 -8.1015797e-02 -1.6435623e-01 -1.4922825e-01 -5.8874212e-02 3.9408110e-02 7.8379546e-02 3.6886774e-02 -4.2241134e-02 -8.1505612e-02 -2.9557008e-02 9.2798034e-02 2.0055247e-01 2.0414883e-01 7.6944227e-02 -1.2029199e-01 -2.7519345e-01 -2.9408814e-01 -1.6081545e-01 5.1070794e-02 2.1840144e-01 2.3874816e-01 9.4335060e-02 -1.2904879e-01 -2.8774773e-01 -2.6899028e-01 -6.6408095e-02 2.1071698e-01 4.0356249e-01 3.9994180e-01 1.9633323e-01 -1.0730235e-01 -3.6601054e-01 -4.6248715e-01 -3.5922221e-01 -1.1354600e-01 1.4870456e-01 2.9521055e-01 2.5966678e-01 8.3040302e-02 -1.0914113e-01 -1.8742442e-01 -1.0478464e-01 7.3317409e-02 2.1546569e-01 2.1382067e-01 5.6531581e-02 -1.6427012e-01 -3.1183656e-01 -2.9186150e-01 -1.1383004e-01 1.1231696e-01 2.4506533e-01 2.0292544e-01 1.9811075e-02 -1.7391062e-01 -2.3677906e-01 -1.1242105e-01 1.2953875e-01 3.3467916e-01 3.5946938e-01 1.6169418e-01 -1.6880410e-01 -4.5538345e-01 -5.3000472e-01 -3.2991559e-01 5.7588162e-02 4.3386984e-01 5.9508457e-01 4.4813661e-01 6.8860243e-02 -3.3635714e-01 -5.4527976e-01 -4.4370745e-01 -8.9647493e-02 3.1753702e-01 5.4673805e-01 4.6318145e-01 1.0733728e-01 -3.1949400e-01 -5.6446899e-01 -4.7269412e-01 -8.8269356e-02 3.6150197e-01 5.9965309e-01 4.7275161e-01 5.2712510e-02 -4.0097128e-01 -6.0010920e-01 -4.1032807e-01 6.1089052e-02 5.2877389e-01 7.0388838e-01 4.7272792e-01 -3.2841140e-02 -5.1806125e-01 -7.0615746e-01 -5.0443062e-01 -5.3964611e-02 3.6781621e-01 5.2531916e-01 3.6514315e-01 3.1895267e-02 -2.4276338e-01 -2.9561167e-01 -1.2568333e-01 1.2380832e-01 2.6979551e-01 2.0920891e-01 -2.0179145e-02 -2.6980104e-01 -3.7620139e-01 -2.6519009e-01 -1.4966321e-04 2.5905182e-01 3.5875119e-01 2.4783584e-01 5.4317821e-03 -2.1770753e-01 -2.9814845e-01 -2.0810260e-01 -1.7395596e-02 1.5890290e-01 2.2758901e-01 1.6085463e-01 3.3576307e-03 -1.5297196e-01 -2.1737064e-01 -1.5023570e-01 1.2479222e-02 1.7606639e-01 2.4089523e-01 1.6216345e-01 -2.3230254e-02 -2.1504218e-01 -3.0098784e-01 -2.1779026e-01 8.8067567e-03 2.6812984e-01 4.1695437e-01 3.6159556e-01 1.2203070e-01 -1.7147580e-01 -3.5437470e-01 -3.3058973e-01 -1.3341351e-01 9.9954914e-02 2.1969740e-01 1.5589313e-01 -4.1996520e-02 -2.3771826e-01 -2.9083527e-01 -1.4002506e-01 1.5548285e-01 4.3862419e-01 5.3769302e-01 3.6811228e-01 -6.9569482e-03 -3.9769165e-01 -5.8956799e-01 -4.7193386e-01 -1.1138894e-01 2.8025332e-01 4.6943948e-01 3.4372376e-01 -1.6555081e-02 -3.8429530e-01 -5.2185674e-01 -3.2705351e-01 1.0055685e-01 5.1629500e-01 6.7570174e-01 4.8204840e-01 4.6679399e-02 -3.7892485e-01 -5.5799051e-01 -4.1189337e-01 -6.3130989e-02 2.4927425e-01 3.2624429e-01 1.3391859e-01 -1.7899014e-01 -3.7999275e-01 -3.0718591e-01 1.9919795e-02 4.0587411e-01 5.9872071e-01 4.5200311e-01 2.6827172e-02 -4.3774484e-01 -6.7014857e-01 -5.3423365e-01 -1.1312830e-01 3.4367827e-01 5.7281717e-01 4.5156693e-01 6.5481027e-02 -3.4683106e-01 -5.3783781e-01 -3.9562633e-01 -5.2304328e-03 4.0256826e-01 5.8408144e-01 4.2300297e-01 -1.8218267e-04 -4.4833216e-01 -6.5943295e-01 -5.0033881e-01 -5.1578103e-02 4.3192551e-01 6.6545648e-01 5.0237264e-01 2.6477477e-02 -4.8897549e-01 -7.3697545e-01 -5.5960739e-01 -4.7597748e-02 5.0867228e-01 7.8911527e-01 6.3269313e-01 1.3197226e-01 -4.2464681e-01 -7.2603682e-01 -6.1784801e-01 -1.8264666e-01 3.2014735e-01 6.1135123e-01 5.4895999e-01 1.9768580e-01 -2.2062099e-01 -4.6220719e-01 -4.0211731e-01 -9.9950534e-02 2.4465654e-01 4.1872319e-01 3.2500596e-01 3.2810917e-02 -2.7440750e-01 -4.1536442e-01 -3.1832701e-01 -5.5989066e-02 2.0726049e-01 3.1798239e-01 2.2484797e-01 5.1703651e-03 -1.8889751e-01 -2.2927380e-01 -9.1914974e-02 1.3314428e-01 3.0513495e-01 3.2224987e-01 1.7778028e-01 -4.7100451e-02 -2.4007922e-01 -3.2145867e-01 -2.7615883e-01 -1.4545755e-01 4.2822900e-03 1.1399372e-01 1.5138712e-01 1.1530153e-01 3.0234280e-02 -6.4234624e-02 -1.2615802e-01 -1.2407054e-01 -4.9317670e-02 7.5619816e-02 2.0015044e-01 2.6472178e-01 2.3118708e-01 1.0699863e-01 -5.5412012e-02 -1.8550876e-01 -2.3096135e-01 -1.8218227e-01 -7.2615500e-02 4.0881922e-02 1.0372451e-01 8.6362391e-02 -1.1351454e-03 -1.0889033e-01 -1.6548976e-01 -1.1405709e-01 4.6560657e-02 2.4386985e-01 3.6111476e-01 3.0662373e-01 8.1468123e-02 -2.0497551e-01 -3.9165036e-01 -3.6309524e-01 -1.2535574e-01 1.8954273e-01 3.9793935e-01 3.7486538e-01 1.3124068e-01 -1.9174474e-01 -4.0848802e-01 -4.0149539e-01 -1.8960477e-01 9.0301438e-02 2.7507284e-01 2.7972729e-01 1.4341274e-01 -1.2566755e-02 -7.8032703e-02 -2.7425697e-02 7.5351759e-02 1.3487633e-01 9.5488652e-02 -2.4590018e-02 -1.5233210e-01 -2.1189289e-01 -1.7248897e-01 -6.2455423e-02 5.4933614e-02 1.2398028e-01 1.2778044e-01 8.7386392e-02 3.4966577e-02 -1.0850501e-02 -4.6716543e-02 -6.9020828e-02 -6.3681635e-02 -1.6203206e-02 6.7394491e-02 1.5127737e-01 1.8399090e-01 1.2920707e-01 -7.0434827e-03 -1.7216342e-01 -2.8937677e-01 -2.9509198e-01 -1.7314710e-01 3.2745183e-02 2.3542177e-01 3.4097958e-01 2.9247721e-01 1.0411948e-01 -1.3495077e-01 -2.9868629e-01 -2.9240849e-01 -1.1517683e-01 1.2871323e-01 2.8803761e-01 2.6146766e-01 6.7234759e-02 -1.6729947e-01 -2.9180077e-01 -2.3297675e-01 -3.8493954e-02 1.6188055e-01 2.4607750e-01 1.7580193e-01 1.0770499e-02 -1.3917580e-01 -1.8630712e-01 -1.1496682e-01 1.8120146e-02 1.2605380e-01 1.4532251e-01 6.9056099e-02 -5.5814690e-02 -1.6001831e-01 -1.8912751e-01 -1.2778372e-01 -4.4698128e-03 1.2208903e-01 1.8963074e-01 1.6384408e-01 6.0799128e-02 -5.7339158e-02 -1.1860919e-01 -9.0086196e-02 -4.5798607e-03 6.0280807e-02 4.1676388e-02 -5.5180320e-02 -1.5518201e-01 -1.6828578e-01 -6.2049884e-02 1.0561621e-01 2.2337555e-01 2.0643187e-01 5.9839911e-02 -1.2043322e-01 -2.1083864e-01 -1.4415945e-01 4.3538937e-02 2.3203364e-01 2.9044234e-01 1.6171416e-01 -9.5674666e-02 -3.3749265e-01 -4.1795872e-01 -2.7746809e-01 2.0648626e-02 3.2603206e-01 4.8410918e-01 4.1672303e-01 1.5905611e-01 -1.6318595e-01 -3.9931562e-01 -4.4568803e-01 -2.9169291e-01 -2.0960934e-02 2.3175866e-01 3.4693819e-01 2.7877641e-01 7.7125945e-02 -1.4069530e-01 -2.5367798e-01 -2.0150506e-01 -1.6778161e-02 1.9116819e-01 2.9409556e-01 2.1593628e-01 -1.9610708e-02 -2.9401135e-01 -4.5512990e-01 -4.0311941e-01 -1.5075705e-01 1.7921653e-01 4.2153577e-01 4.6143206e-01 2.9688389e-01 3.5275834e-02 -1.7206796e-01 -2.2040717e-01 -1.1280250e-01 4.6014479e-02 1.2005000e-01 3.5297082e-02 -1.6459920e-01 -3.4121448e-01 -3.5130088e-01 -1.4787707e-01 1.7615712e-01 4.3972643e-01 4.8949447e-01 2.9899548e-01 -1.6059656e-02 -2.7414987e-01 -3.4124596e-01 -2.0476598e-01 3.1287353e-02 2.1535118e-01 2.3693813e-01 8.7039128e-02 -1.3914592e-01 -2.9731202e-01 -2.8057123e-01 -8.9244625e-02 1.6445576e-01 3.2621002e-01 2.9949560e-01 1.0678193e-01 -1.3016725e-01 -2.7225661e-01 -2.4687907e-01 -8.3173776e-02 1.1381888e-01 2.2819642e-01 1.9830143e-01 4.8505476e-02 -1.2763594e-01 -2.2560309e-01 -1.9560311e-01 -7.1212054e-02 6.0380807e-02 1.2445307e-01 1.0835168e-01 5.5609724e-02 1.7269294e-02 9.3997346e-03 1.1223045e-02 -4.3543819e-03 -4.2668837e-02 -8.5657964e-02 -1.0909342e-01 -9.7154374e-02 -4.6781850e-02 3.1101930e-02 1.0973840e-01 1.5122945e-01 1.2531404e-01 3.3620966e-02 -8.3194568e-02 -1.6716420e-01 1998. 1999. 2000. 2001. slicot-5.0+20101122/examples/IB03BD.res000077500000000000000000000014541201767322700167510ustar00rootroot00000000000000 IB03BD EXAMPLE PROGRAM RESULTS IWARN on exit from IB03BD = 12 Final 2-norm of the residuals = 0.3048502D+00 Number of iterations = 23 Number of function evaluations = 625 Number of Jacobian evaluations = 270 Final approximate solution is 16.2674 1.2144 6.5207 -10.8207 7.7778 -5.3537 -50.6063 1291.8734 -0.3668 -73.8082 5.9979 -0.9106 0.0922 0.3366 0.9149 0.2901 1.3182 0.0179 0.0594 -0.0034 -0.3844 -0.0426 -2.0905 -0.9365 1.3176 0.8249 0.5811 0.8912 -0.3723 3.1782 -5.2780 -56.5497 -0.1040 -7.7904 0.1320 0.3895 0.0536 7.8236 -15.0550 2.4100 -68.6242 -0.8531 -0.7139 2.0029 1.4205 -0.2031 -0.9372 -0.0045 0.3742 0.1818 slicot-5.0+20101122/examples/MB01TD.dat000077500000000000000000000005161201767322700167520ustar00rootroot00000000000000 MB01TD EXAMPLE PROGRAM DATA 5 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 0. 0. 1. 5. 1. 0. 0. 0. 0. -4. 0. 0. 0. 20. 4. 5. 5. 1. 5. 1. -2. 1. 3. 0. -4. 0. 0. 4. 20. 4. 0. 0. 0. 3. 5. 0. 0. 0. 1. -2. slicot-5.0+20101122/examples/MB01TD.res000077500000000000000000000004431201767322700167720ustar00rootroot00000000000000 MB01TD EXAMPLE PROGRAM RESULTS The matrix product A*B is 1.0000 7.0000 31.0000 139.0000 22.0000 -8.0000 -11.0000 -9.0000 -32.0000 2.0000 0.0000 0.0000 4.0000 36.0000 27.0000 0.0000 0.0000 0.0000 -4.0000 8.0000 0.0000 0.0000 0.0000 64.0000 92.0000 slicot-5.0+20101122/examples/MB02CD.dat000077500000000000000000000002411201767322700167250ustar00rootroot00000000000000MB02CD EXAMPLE PROGRAM DATA 3 2 A 3.0000 1.0000 0.1000 0.1000 0.2000 0.0500 1.0000 4.0000 0.4000 0.1000 0.0400 0.2000 slicot-5.0+20101122/examples/MB02CD.res000077500000000000000000000020641201767322700167530ustar00rootroot00000000000000 MB02CD EXAMPLE PROGRAM RESULTS The generator of the inverse of block Toeplitz matrix is -0.2355 0.5231 -0.0642 0.0077 0.0187 -0.0265 -0.5568 -0.0568 0.0229 0.0060 0.0363 0.0000 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.0000 0.0000 0.0119 -0.0265 -0.0110 0.0076 The lower Cholesky factor of the inverse is 0.5774 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1741 0.5222 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0581 0.5812 0.0000 0.0000 0.0000 -0.0142 0.0080 -0.1747 0.5224 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.5825 0.0000 0.0119 -0.0265 -0.0110 0.0076 -0.1754 0.5231 The upper Cholesky factor of block Toeplitz matrix is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 0.0000 0.0000 0.0000 0.0000 1.7169 0.5759 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 slicot-5.0+20101122/examples/MB02DD.dat000077500000000000000000000004061201767322700167310ustar00rootroot00000000000000MB02DD EXAMPLE PROGRAM DATA 3 2 2 A R 3.0000 1.0000 0.1000 0.1000 0.2000 0.0500 0.1000 0.0400 0.01 0.02 1.0000 4.0000 0.4000 0.1000 0.0400 0.2000 0.0300 0.0200 0.03 0.01 slicot-5.0+20101122/examples/MB02DD.res000077500000000000000000000063401201767322700167550ustar00rootroot00000000000000 MB02DD EXAMPLE PROGRAM RESULTS The Cholesky factor is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 0.0000 0.0000 0.0000 0.0000 1.7169 0.5759 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 The inverse generator is -0.2355 0.5231 -0.0642 0.0077 0.0187 -0.0265 -0.5568 -0.0568 0.0229 0.0060 0.0363 0.0000 0.5825 0.0000 -0.0387 0.0052 0.0003 -0.0575 -0.1754 0.5231 0.0119 -0.0265 -0.0110 0.0076 The inverse Cholesky factor is 0.5774 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1741 0.5222 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0581 0.5812 0.0000 0.0000 0.0000 -0.0142 0.0080 -0.1747 0.5224 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.5825 0.0000 0.0119 -0.0265 -0.0110 0.0076 -0.1754 0.5231 The updated Cholesky factor is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.0577 0.0231 0.0058 0.0115 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 -0.0017 0.0035 0.0139 0.0017 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.1145 0.0279 0.0564 0.0227 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 -0.0152 0.0953 -0.0017 0.0033 0.0000 0.0000 0.0000 0.0000 1.7169 0.5759 0.0523 0.0453 0.1146 0.0273 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 0.1902 0.0357 -0.0157 0.0955 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.7159 0.5757 0.0526 0.0450 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 0.1901 0.0357 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.7159 0.5757 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.9117 The updated inverse generator is -0.5599 0.3310 -0.0305 0.0098 0.0392 -0.0209 0.0191 -0.0010 -0.0045 0.0035 -0.2289 -0.4091 0.0612 -0.0012 0.0125 0.0182 0.0042 0.0017 0.0014 0.0000 0.5828 0.0000 0.0027 -0.0029 -0.0195 0.0072 -0.0393 0.0057 0.0016 -0.0580 -0.1755 0.5231 -0.0037 0.0022 0.0005 -0.0022 0.0125 -0.0266 -0.0109 0.0077 The updated inverse Cholesky factor is 0.5774 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1741 0.5222 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0581 0.5812 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0142 0.0080 -0.1747 0.5224 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.5825 0.0000 0.0000 0.0000 0.0000 0.0000 0.0119 -0.0265 -0.0110 0.0076 -0.1754 0.5231 0.0000 0.0000 0.0000 0.0000 -0.0199 0.0073 -0.0391 0.0056 0.0017 -0.0580 0.5828 0.0000 0.0000 0.0000 0.0007 -0.0023 0.0122 -0.0265 -0.0110 0.0077 -0.1755 0.5231 0.0000 0.0000 0.0027 -0.0029 -0.0195 0.0072 -0.0393 0.0057 0.0016 -0.0580 0.5828 0.0000 -0.0037 0.0022 0.0005 -0.0022 0.0125 -0.0266 -0.0109 0.0077 -0.1755 0.5231 slicot-5.0+20101122/examples/MB02ED.dat000077500000000000000000000010041201767322700167250ustar00rootroot00000000000000MB02ED EXAMPLE PROGRAM DATA 3 3 2 C 3.0000 1.0000 0.2000 1.0000 4.0000 0.4000 0.2000 0.4000 5.0000 0.1000 0.1000 0.2000 0.2000 0.0400 0.0300 0.0500 0.2000 0.1000 0.1000 0.0300 0.1000 0.0400 0.0200 0.2000 0.0100 0.0300 0.0200 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 slicot-5.0+20101122/examples/MB02ED.res000077500000000000000000000003511201767322700167520ustar00rootroot00000000000000 MB02ED EXAMPLE PROGRAM RESULTS The solution of T*X = B is 0.2408 0.4816 0.1558 0.3116 0.1534 0.3068 0.2302 0.4603 0.1467 0.2934 0.1537 0.3075 0.2349 0.4698 0.1498 0.2995 0.1653 0.3307 slicot-5.0+20101122/examples/MB02FD.dat000077500000000000000000000002711201767322700167330ustar00rootroot00000000000000MB02FD EXAMPLE 4 2 3 0 1 1 3.0000 1.0000 0.1000 0.1000 0.2000 0.0500 0.2000 0.3000 1.0000 4.0000 0.4000 0.1000 0.0400 0.2000 0.1000 0.2000 slicot-5.0+20101122/examples/MB02FD.res000077500000000000000000000007751201767322700167650ustar00rootroot00000000000000 MB02FD EXAMPLE PROGRAM RESULTS Incomplete Cholesky factorization rows norm(Schur complement) 0 5.5509 2 5.1590 4 4.8766 The upper ICC factor of the block Toeplitz matrix is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.1155 0.1732 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 0.0174 0.0522 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.1104 0.0174 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 -0.0161 0.0931 slicot-5.0+20101122/examples/MB02GD.dat000077500000000000000000000002451201767322700167350ustar00rootroot00000000000000MB02GD EXAMPLE PROGRAM DATA 2 4 2 T 3.0000 1.0000 0.1000 0.4000 0.2000 0.0000 0.0000 4.0000 0.1000 0.1000 0.0500 0.2000 slicot-5.0+20101122/examples/MB02GD.res000077500000000000000000000007041201767322700167560ustar00rootroot00000000000000 MB02GD EXAMPLE PROGRAM RESULTS The upper Cholesky factor in banded storage format 0.0000 0.0000 0.0000 0.0000 0.1155 0.1044 0.1156 0.1051 0.0000 0.0000 0.0000 0.2309 -0.0087 0.2290 -0.0084 0.2302 0.0000 0.0000 0.0577 -0.0174 0.0541 -0.0151 0.0544 -0.0159 0.0000 0.5774 0.0348 0.5704 0.0222 0.5725 0.0223 0.5724 1.7321 1.9149 1.7307 1.9029 1.7272 1.8996 1.7272 1.8995 slicot-5.0+20101122/examples/MB02HD.dat000077500000000000000000000003041201767322700167320ustar00rootroot00000000000000MB02HD EXAMPLE PROGRAM DATA 2 2 6 2 5 1 N 4.0 4.0 1.0 3.0 2.0 1.0 2.0 2.0 4.0 4.0 3.0 4.0 1.0 3.0 2.0 1.0 slicot-5.0+20101122/examples/MB02HD.res000077500000000000000000000014541201767322700167620ustar00rootroot00000000000000 MB02HD EXAMPLE PROGRAM RESULTS The lower triangular factor R in banded storage -7.0711 -2.4125 6.0822 2.9967 5.9732 2.8593 5.8497 2.7914 2.7298 1.9557 -7.4953 -0.0829 5.8986 -0.5571 5.5329 0.2059 5.6797 0.3414 0.9565 0.0000 -4.2426 0.9202 2.4747 -1.6425 2.9472 -1.0052 2.4396 -0.7785 0.0000 0.0000 -5.2326 0.6218 2.8391 -0.0820 3.2670 0.6327 2.7067 0.0000 0.0000 0.0000 -3.5355 0.8207 3.1160 -0.4451 3.5758 0.5701 0.0000 0.0000 0.0000 0.0000 -4.6669 -0.5803 3.9454 0.7682 4.5481 0.0000 0.0000 0.0000 0.0000 0.0000 -1.4142 -0.0415 1.6441 0.4848 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -2.1213 0.0000 2.4662 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/MB02ID.dat000077500000000000000000000010121201767322700167300ustar00rootroot00000000000000MB02ID EXAMPLE PROGRAM DATA 3 2 4 3 1 1 A 5.0 2.0 1.0 2.0 4.0 3.0 4.0 0.0 2.0 2.0 3.0 3.0 5.0 1.0 3.0 3.0 1.0 1.0 2.0 3.0 1.0 3.0 2.0 2.0 1.0 4.0 2.0 3.0 2.0 2.0 2.0 4.0 3.0 1.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 slicot-5.0+20101122/examples/MB02ID.res000077500000000000000000000004601201767322700167570ustar00rootroot00000000000000 MB02ID EXAMPLE PROGRAM RESULTS The least squares solution of T * X = B is 0.0379 0.1677 0.0485 -0.0038 0.0429 0.1365 The minimum norm solution of T^T * X = C is 0.0509 0.0547 0.0218 0.0008 0.0436 0.0404 0.0031 0.0451 0.0421 0.0243 0.0556 0.0472 slicot-5.0+20101122/examples/MB02JD.dat000077500000000000000000000005371201767322700167440ustar00rootroot00000000000000MB02JD EXAMPLE PROGRAM DATA 2 3 4 3 Q 1.0 4.0 0.0 4.0 1.0 2.0 4.0 2.0 2.0 5.0 3.0 2.0 2.0 4.0 4.0 5.0 3.0 4.0 2.0 2.0 5.0 4.0 2.0 3.0 3.0 4.0 2.0 5.0 0.0 4.0 5.0 1.0 1.0 2.0 4.0 1.0 slicot-5.0+20101122/examples/MB02JD.res000077500000000000000000000024401201767322700167600ustar00rootroot00000000000000 MB02JD EXAMPLE PROGRAM RESULTS The factor Q is -0.0967 0.7166 -0.4651 0.1272 0.4357 0.0435 0.2201 0.0673 -0.3867 -0.3108 -0.0534 0.5251 0.0963 -0.3894 0.1466 0.5412 -0.3867 -0.0990 -0.1443 -0.7021 0.3056 -0.3367 -0.3233 0.1249 -0.4834 -0.0178 -0.3368 -0.1763 -0.5446 0.5100 0.1503 0.2054 -0.1933 0.5859 0.3214 0.1156 -0.4670 -0.3199 -0.4185 0.0842 -0.4834 -0.0178 0.1072 0.0357 -0.0575 -0.2859 0.4339 -0.6928 -0.1933 0.1623 0.7251 -0.1966 0.2736 0.3058 0.3398 0.2968 -0.3867 -0.0990 0.0777 0.3615 0.3386 0.4421 -0.5693 -0.2641 The factor R is -10.3441 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -6.3805 4.7212 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -7.3472 1.9320 4.5040 0.0000 0.0000 0.0000 0.0000 0.0000 -10.0541 2.5101 0.5065 3.6550 0.0000 0.0000 0.0000 0.0000 -6.5738 3.6127 1.2702 -1.3146 3.5202 0.0000 0.0000 0.0000 -5.2204 2.4764 2.4113 1.3890 1.2780 2.4976 0.0000 0.0000 -9.6674 3.2445 -0.5099 -0.0224 2.6548 2.9491 1.0049 0.0000 -6.3805 0.6968 1.9483 0.3050 0.7002 -2.0220 -2.8246 2.3147 -4.1570 2.4309 -0.7190 -0.1455 3.0149 0.5454 0.9394 -0.0548 slicot-5.0+20101122/examples/MB02JX.dat000077500000000000000000000012211201767322700167570ustar00rootroot00000000000000MB02JX EXAMPLE PROGRAM DATA 3 3 4 4 -1.0D0 -1.0D0 Q 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 0.0 1.0 1.0 1.0 0.0 2.0 2.0 0.0 1.0 2.0 3.0 1.0 2.0 3.0 0.0 1.0 1.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 1.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 1.0 1.0 1.0 2.0 3.0 1.0 2.0 3.0 0.0 1.0 0.0 slicot-5.0+20101122/examples/MB02JX.res000077500000000000000000000033001201767322700170000ustar00rootroot00000000000000 MB02JX EXAMPLE PROGRAM RESULTS Numerical rank RNK = 7 The factor Q is -0.3313 -0.0105 -0.0353 0.0000 -0.4714 -0.8165 0.0000 -0.3313 -0.0105 -0.0353 0.0000 -0.4714 0.4082 0.7071 -0.3313 -0.0105 -0.0353 0.0000 -0.4714 0.4082 -0.7071 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.1104 0.2824 0.9529 0.0000 0.0000 0.0000 0.0000 0.0000 0.4288 -0.1271 0.8944 0.0000 0.0000 0.0000 0.0000 0.8576 -0.2541 -0.4472 0.0000 0.0000 0.0000 The factor R is -9.0554 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0921 2.3322 0.0000 0.0000 0.0000 0.0000 0.0000 -5.9633 1.9557 -1.2706 0.0000 0.0000 0.0000 0.0000 -9.2762 4.4238 0.7623 1.3416 0.0000 0.0000 0.0000 -6.1842 2.9492 0.5082 0.8944 0.0000 0.0000 0.0000 -3.0921 1.4746 0.2541 0.4472 0.0000 0.0000 0.0000 -9.2762 4.4238 0.7623 1.3416 0.0000 0.0000 0.0000 -6.1842 2.9492 0.5082 0.8944 0.0000 0.0000 0.0000 -3.0921 1.4746 0.2541 0.4472 0.0000 0.0000 0.0000 -7.2885 4.4866 0.9741 1.3416 2.8284 0.0000 0.0000 -2.7608 1.4851 0.2894 0.4472 0.4714 0.8165 0.0000 -5.5216 2.9701 0.5788 0.8944 0.9428 0.4082 0.7071 The column permutation is 3 1 2 6 5 4 9 8 7 12 10 11 slicot-5.0+20101122/examples/MB02KD.dat000077500000000000000000000010471201767322700167420ustar00rootroot00000000000000MB02KD EXAMPLE PROGRAM DATA 3 2 4 5 1 C N 4.0 1.0 3.0 5.0 2.0 1.0 4.0 1.0 3.0 4.0 2.0 4.0 3.0 1.0 3.0 0.0 4.0 4.0 5.0 1.0 3.0 1.0 4.0 3.0 5.0 2.0 2.0 2.0 2.0 1.0 1.0 3.0 4.0 1.0 5.0 4.0 5.0 4.0 1.0 2.0 2.0 3.0 4.0 1.0 3.0 3.0 3.0 3.0 0.0 2.0 2.0 2.0 1.0 3.0 3.0 4.0 2.0 3.0 slicot-5.0+20101122/examples/MB02KD.res000077500000000000000000000002641201767322700167630ustar00rootroot00000000000000 MB02KD EXAMPLE PROGRAM RESULTS The product C = T * B is 45.0000 76.0000 55.0000 44.0000 84.0000 56.0000 52.0000 70.0000 54.0000 49.0000 63.0000 59.0000 slicot-5.0+20101122/examples/MB02MD.dat000077500000000000000000000004371201767322700167460ustar00rootroot00000000000000 MB02MD EXAMPLE PROGRAM DATA 6 3 1 B 0.0 0.80010 0.39985 0.60005 0.89999 0.29996 0.69990 0.39997 0.82997 0.49994 0.60003 0.20012 0.79011 0.90013 0.20016 0.79995 0.85002 0.39998 0.80006 0.49985 0.99016 0.20002 0.90007 0.70009 1.02994 slicot-5.0+20101122/examples/MB02MD.res000077500000000000000000000003431201767322700167630ustar00rootroot00000000000000 MB02MD EXAMPLE PROGRAM RESULTS The computed rank of the TLS approximation = 3 The solution X to the TLS problem is 0.5003 0.8003 0.2995 The singular values of C are 3.2281 0.8716 0.3697 0.0001 slicot-5.0+20101122/examples/MB02ND.dat000077500000000000000000000004631201767322700167460ustar00rootroot00000000000000 MB02ND EXAMPLE PROGRAM DATA 6 3 1 -1 0.001 0.0 0.0 0.80010 0.39985 0.60005 0.89999 0.29996 0.69990 0.39997 0.82997 0.49994 0.60003 0.20012 0.79011 0.90013 0.20016 0.79995 0.85002 0.39998 0.80006 0.49985 0.99016 0.20002 0.90007 0.70009 1.02994 slicot-5.0+20101122/examples/MB02ND.res000077500000000000000000000014101201767322700167600ustar00rootroot00000000000000 MB02ND EXAMPLE PROGRAM RESULTS The computed rank of the TLS approximation = 3 The elements of the partially diagonalized bidiagonal matrix are (1,1) = 3.2280 (1,2) = -0.0287 (2,2) = 0.8714 (2,3) = 0.0168 (3,3) = 0.3698 (3,4) = 0.0000 (4,4) = 0.0001 The solution X to the TLS problem is 0.5003 0.8003 0.2995 Right singular subspace corresponds to the first 4 components of the j-th column of C for which INUL(j) = .TRUE., j = 1,..., 4 Matrix C -0.3967 -0.7096 0.4612 -0.3555 0.9150 -0.2557 0.2414 -0.5687 -0.0728 0.6526 0.5215 -0.2128 0.0000 0.0720 0.6761 0.7106 0.1809 0.3209 0.0247 -0.4139 0.0905 0.4609 -0.3528 0.5128 j INUL(j) 1 F 2 F 3 F 4 T slicot-5.0+20101122/examples/MB02QD.dat000077500000000000000000000002761201767322700167530ustar00rootroot00000000000000 MB02QD EXAMPLE PROGRAM DATA 4 3 2 2.3D-16 0.0 L N 2.0 2.0 -3.0 3.0 3.0 -1.0 4.0 4.0 -5.0 -1.0 -1.0 -2.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/MB02QD.res000077500000000000000000000003341201767322700167670ustar00rootroot00000000000000 MB02QD EXAMPLE PROGRAM RESULTS The effective rank of A = 2 Estimates of the singular values SVAL = 7.8659 2.6698 0.0000 The least squares solution is -0.0034 -0.1054 -0.0034 -0.1054 -0.0816 -0.1973 slicot-5.0+20101122/examples/MB02SD.dat000077500000000000000000000005031201767322700167460ustar00rootroot00000000000000 MB02SD EXAMPLE PROGRAM DATA 5 4 O N 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 0. 3. 1. 5. 1. 0. 0. 2. 0. -4. 0. 0. 0. 1. 4. 5. 5. 1. 5. -2. 1. 3. 1. 0. 0. 4. 5. 2. 1. 1. 3. -1. 3. 3. 1. slicot-5.0+20101122/examples/MB02SD.res000077500000000000000000000004401201767322700167670ustar00rootroot00000000000000 MB02SD EXAMPLE PROGRAM RESULTS The solution matrix is 0.0435 1.2029 1.6377 1.1014 1.0870 -4.4275 -5.5580 -2.9638 0.9130 0.7609 -0.1087 0.6304 -0.8261 2.4783 4.2174 2.7391 -0.0435 0.1304 -0.3043 -0.4348 Reciprocal condition number = 0.1554D-01 slicot-5.0+20101122/examples/MB02VD.dat000077500000000000000000000004061201767322700167530ustar00rootroot00000000000000 MB02VD EXAMPLE PROGRAM DATA 5 4 N 1. 2. 6. 3. -2. -1. -1. 0. 2. 3. 1. 5. 1. -1. 2. 0. 0. 0. 0. 1. 5. 5. 1. 5. -2. 1. 3. 1. 0. 0. 4. 5. 2. 1. 1. 3. slicot-5.0+20101122/examples/MB02VD.res000077500000000000000000000003631201767322700167760ustar00rootroot00000000000000 MB02VD EXAMPLE PROGRAM RESULTS The solution matrix is -0.0690 0.3333 0.2414 0.2529 -0.1724 -1.6667 1.1034 -0.3678 0.9655 0.6667 -0.3793 -0.8736 0.3448 1.6667 0.7931 1.4023 -0.2069 0.0000 0.7241 0.7586 slicot-5.0+20101122/examples/MB03BD.dat000077500000000000000000000003721201767322700167320ustar00rootroot00000000000000MB03BD EXAMPLE PROGRAM DATA S C I 3 3 2 1 3 -1 1 -1 2.0 0.0 1.0 0.0 -2.0 -1.0 0.0 0.0 3.0 1.0 2.0 0.0 4.0 -1.0 3.0 0.0 3.0 1.0 1.0 0.0 1.0 0.0 4.0 -1.0 0.0 0.0 -2.0 slicot-5.0+20101122/examples/MB03BD.res000077500000000000000000000015711201767322700167550ustar00rootroot00000000000000MB03BD EXAMPLE PROGRAM RESULTS The matrix A on exit is The factor 1 is -2.0599 0.6251 -0.5959 0.0000 2.9774 -1.1479 0.0000 0.0000 1.9566 The factor 2 is -3.9705 -0.3216 2.9819 -2.0077 2.2246 -1.9116 0.0000 0.0000 1.8990 The factor 3 is 2.6946 -2.9508 0.5659 0.0000 1.3385 0.0097 0.0000 0.0000 -2.2180 The matrix Q on exit is The factor 1 is -0.3331 -0.7427 -0.5809 0.9394 -0.2084 -0.2723 0.0812 -0.6364 0.7671 The factor 2 is 0.2841 -0.7723 -0.5683 0.9515 0.1539 0.2664 -0.1183 -0.6164 0.7785 The factor 3 is -0.7883 -0.5567 0.2619 0.6055 -0.6263 0.4911 -0.1094 0.5457 0.8308 The vector ALPHAR is 0.3230 0.6459 -0.8752 The vector ALPHAI is 0.5694 -1.1387 0.0000 The vector BETA is 1.0000 1.0000 1.0000 The vector SCAL is 0 -1 -1 slicot-5.0+20101122/examples/MB03KD.dat000077500000000000000000000003761201767322700167470ustar00rootroot00000000000000MB03KD EXAMPLE PROGRAM DATA S C I N 3 3 2 1 3 -1 1 -1 2.0 0.0 1.0 0.0 -2.0 -1.0 0.0 0.0 3.0 1.0 2.0 0.0 4.0 -1.0 3.0 0.0 3.0 1.0 1.0 0.0 1.0 0.0 4.0 -1.0 0.0 0.0 -2.0 slicot-5.0+20101122/examples/MB03KD.res000077500000000000000000000015601201767322700167640ustar00rootroot00000000000000MB03KD EXAMPLE PROGRAM RESULTS The vector ALPHAR is 0.3230 0.6459 -0.8752 The vector ALPHAI is 0.5694 -1.1387 0.0000 The vector BETA is 1.0000 1.0000 1.0000 The vector SCAL is 0 -1 -1 The matrix A on exit is The factor 1 is 2.5997 -0.1320 -1.6847 0.0000 1.9725 -0.1377 0.0000 0.0000 2.3402 The factor 2 is -2.0990 -1.1625 2.5251 0.0000 3.1870 -0.3812 0.0000 -3.6737 -2.2513 The factor 3 is 1.8451 0.9652 -1.2422 0.0000 1.3270 2.1642 0.0000 0.0000 -3.2674 The matrix Q on exit is The factor 1 is 0.1648 -0.3771 -0.9114 -0.0376 -0.9258 0.3762 0.9856 0.0277 0.1668 The factor 2 is 0.5907 0.3477 0.7281 -0.7640 0.5311 0.3662 -0.2594 -0.7726 0.5794 The factor 3 is 0.6685 -0.7431 0.0303 0.4239 0.3472 -0.8365 0.6111 0.5720 0.5471 slicot-5.0+20101122/examples/MB03LD.dat000077500000000000000000000013051201767322700167410ustar00rootroot00000000000000MB03LD EXAMPLE PROGRAM DATA C Q 8 3.1472 1.3236 4.5751 4.5717 4.0579 -4.0246 4.6489 -0.1462 -3.7301 -2.2150 -3.4239 3.0028 4.1338 0.4688 4.7059 -3.5811 0.0000 0.0000 -1.5510 -4.5974 -2.5127 3.5071 0.0000 0.0000 1.5961 2.4490 -3.1428 2.5648 0.0000 0.0000 -0.0596 3.0340 2.4892 -1.1604 0.0000 0.0000 0.6882 -3.3782 -3.3435 1.8921 -0.3061 2.9428 1.0198 2.4815 -4.8810 -1.8878 -2.3703 -0.4946 -1.6288 0.2853 1.5408 -4.1618 -2.4013 -2.7102 0.3834 -3.9335 3.1730 -3.1815 -2.3620 4.9613 4.6190 3.6869 3.6929 0.7970 0.4986 -4.9537 -4.1556 3.5303 1.2206 -1.4905 0.1325 -1.0022 slicot-5.0+20101122/examples/MB03LD.res000077500000000000000000000022311201767322700167610ustar00rootroot00000000000000MB03LD EXAMPLE PROGRAM RESULTS The matrix A on exit is -4.7460 4.1855 3.2696 -0.2244 0.0000 6.4157 2.8287 1.4553 0.0000 0.0000 7.4626 1.5726 0.0000 0.0000 0.0000 8.8702 The matrix DE on exit is -5.4562 2.5550 -1.3137 -6.3615 -0.8940 -2.1348 -7.9616 0.0000 1.0704 -0.0659 4.9694 1.1516 4.8504 0.0000 -0.6922 -2.2744 3.4912 0.5046 4.4394 0.0000 The matrix C1 on exit is 6.9525 -4.9881 2.3661 4.2188 0.0000 8.5009 0.7182 5.5533 0.0000 0.0000 -4.6650 -2.8177 0.0000 0.0000 0.0000 1.5124 The matrix V on exit is 0.9136 4.1106 -0.0079 3.5789 -1.1553 -1.4785 -1.5155 -0.8018 -2.2167 4.8029 1.3645 2.5202 -1.0994 -0.6144 0.3970 2.0730 The vector ALPHAR is 0.8314 -1.1758 0.8131 0.0000 The vector ALPHAI is 0.4372 0.6183 0.0000 0.9164 The vector BETA is 0.7071 1.0000 1.4142 2.8284 The matrix Q is -0.1065 0.5967 -0.2995 0.2424 -0.1606 0.6881 0.4045 -0.3593 -0.1505 0.4501 -0.0188 0.0691 0.2261 -0.0852 -0.0435 0.0830 0.5528 0.3520 0.0895 -0.2247 -0.4917 -0.7055 -0.3540 0.2045 slicot-5.0+20101122/examples/MB03MD.dat000077500000000000000000000001621201767322700167420ustar00rootroot00000000000000 MB03MD EXAMPLE PROGRAM DATA 5 -3.0 3 0.0 0.0 1.0 2.0 3.0 4.0 5.0 2.0 3.0 4.0 5.0 slicot-5.0+20101122/examples/MB03MD.res000077500000000000000000000004521201767322700167650ustar00rootroot00000000000000 MB03MD EXAMPLE PROGRAM RESULTS The Bidiagonal Matrix J is (1,1) = 1.0000 (1,2) = 2.0000 (2,2) = 2.0000 (2,3) = 3.0000 (3,3) = 3.0000 (3,4) = 4.0000 (4,4) = 4.0000 (4,5) = 5.0000 (5,5) = 5.0000 The computed value of THETA is 4.7500 J has 3 singular values < = THETA slicot-5.0+20101122/examples/MB03ND.dat000077500000000000000000000001531201767322700167430ustar00rootroot00000000000000 MB03ND EXAMPLE PROGRAM DATA 5 5.0 0.0 0.0 1.0 2.0 3.0 4.0 5.0 2.0 3.0 4.0 5.0 slicot-5.0+20101122/examples/MB03ND.res000077500000000000000000000004031201767322700167620ustar00rootroot00000000000000 MB03ND EXAMPLE PROGRAM RESULTS The Bidiagonal Matrix J is (1,1) = 1.0000 (1,2) = 2.0000 (2,2) = 2.0000 (2,3) = 3.0000 (3,3) = 3.0000 (3,4) = 4.0000 (4,4) = 4.0000 (4,5) = 5.0000 (5,5) = 5.0000 J has 3 singular values < = 5.0000 slicot-5.0+20101122/examples/MB03OD.dat000077500000000000000000000003621201767322700167460ustar00rootroot00000000000000 MB03OD EXAMPLE PROGRAM DATA 6 5 Q 5.D-16 0.0 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 5. 5. 1. 5. 1. -2. -1. -1. 0. -2. 4. 8. 4. 20. 4. -2. -1. -1. 0. -2. slicot-5.0+20101122/examples/MB03OD.res000077500000000000000000000002311201767322700167620ustar00rootroot00000000000000 MB03OD EXAMPLE PROGRAM RESULTS The rank is 4 Column permutations are 4 3 1 5 2 SVAL vector is 22.7257 1.4330 0.0000 slicot-5.0+20101122/examples/MB03PD.dat000077500000000000000000000003621201767322700167470ustar00rootroot00000000000000 MB03PD EXAMPLE PROGRAM DATA 6 5 R 5.D-16 0.0 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 5. 5. 1. 5. 1. -2. -1. -1. 0. -2. 4. 8. 4. 20. 4. -2. -1. -1. 0. -2. slicot-5.0+20101122/examples/MB03PD.res000077500000000000000000000002331201767322700167650ustar00rootroot00000000000000 MB03PD EXAMPLE PROGRAM RESULTS The rank is 4 Row permutations are 2 4 6 3 1 5 SVAL vector is 24.5744 0.9580 0.0000 slicot-5.0+20101122/examples/MB03QD.dat000077500000000000000000000002601201767322700167450ustar00rootroot00000000000000 MB03QD EXAMPLE PROGRAM DATA 4 1 4 0.0 C S U -1.0 37.0 -12.0 -12.0 -1.0 -10.0 0.0 4.0 2.0 -4.0 7.0 -6.0 2.0 2.0 7.0 -9.0 slicot-5.0+20101122/examples/MB03QD.res000077500000000000000000000007771201767322700170030ustar00rootroot00000000000000 MB03QD EXAMPLE PROGRAM RESULTS The number of eigenvalues in the domain is 4 The ordered Schur form matrix is -3.1300 -26.5066 27.2262 -16.2009 0.9070 -3.1300 13.6254 8.9206 0.0000 0.0000 -3.3700 0.3419 0.0000 0.0000 -1.7879 -3.3700 The transformation matrix is 0.9611 0.1784 0.2064 -0.0440 -0.1468 -0.2704 0.8116 -0.4965 -0.2224 0.7675 0.4555 0.3924 -0.0733 0.5531 -0.3018 -0.7730 slicot-5.0+20101122/examples/MB03RD.dat000077500000000000000000000007361201767322700167560ustar00rootroot00000000000000 MB03RD EXAMPLE PROGRAM DATA 8 1.D03 1.D-2 U S 1. -1. 1. 2. 3. 1. 2. 3. 1. 1. 3. 4. 2. 3. 4. 2. 0. 0. 1. -1. 1. 5. 4. 1. 0. 0. 0. 1. -1. 3. 1. 2. 0. 0. 0. 1. 1. 2. 3. -1. 0. 0. 0. 0. 0. 1. 5. 1. 0. 0. 0. 0. 0. 0. 0.99999999 -0.99999999 0. 0. 0. 0. 0. 0. 0.99999999 0.99999999 slicot-5.0+20101122/examples/MB03RD.res000077500000000000000000000026621201767322700167770ustar00rootroot00000000000000 MB03RD EXAMPLE PROGRAM RESULTS The number of blocks is 2 The orders of blocks are 6 2 The block-diagonal matrix is 1.0000 -1.0000 -1.2247 -0.7071 -3.4186 1.4577 0.0000 0.0000 1.0000 1.0000 0.0000 1.4142 -5.1390 3.1637 0.0000 0.0000 0.0000 0.0000 1.0000 -1.7321 -0.0016 2.0701 0.0000 0.0000 0.0000 0.0000 0.5774 1.0000 0.7516 1.1379 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 -5.8606 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1706 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 -0.8850 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 The transformation matrix is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.9045 0.1957 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -0.3015 0.9755 0.0000 0.0000 0.8165 0.0000 -0.5768 -0.0156 -0.3015 0.0148 0.0000 0.0000 -0.4082 0.7071 -0.5768 -0.0156 0.0000 -0.0534 0.0000 0.0000 -0.4082 -0.7071 -0.5768 -0.0156 0.0000 0.0801 0.0000 0.0000 0.0000 0.0000 -0.0276 0.9805 0.0000 0.0267 0.0000 0.0000 0.0000 0.0000 0.0332 -0.0066 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0011 0.1948 0.0000 0.0000 slicot-5.0+20101122/examples/MB03SD.dat000077500000000000000000000002171201767322700167510ustar00rootroot00000000000000MB03SD EXAMPLE PROGRAM DATA 3 S 2.0 0.0 0.0 0.0 1.0 2.0 0.0 -1.0 3.0 1.0 0.0 0.0 2.0 3.0 4.0 -2.0 0.0 0.0 0.0 0.0 0.0 slicot-5.0+20101122/examples/MB03SD.res000077500000000000000000000003101201767322700167640ustar00rootroot00000000000000 MB03SD EXAMPLE PROGRAM RESULTS The eigenvalues are 2.0000 + ( 1.0000)i 2.0000 + ( -1.0000)i 1.4142 + ( 0.0000)i -1.4142 + ( 0.0000)i -2.0000 + ( 1.0000)i -2.0000 + ( -1.0000)i slicot-5.0+20101122/examples/MB03TD.dat000077500000000000000000000016011201767322700167500ustar00rootroot00000000000000MB03TD EXAMPLE PROGRAM DATA 5 S U .F. .T. .T. .F. .F. .F. .T. .T. .F. .F. 0.9501 0.7621 0.6154 0.4057 0.0579 0 0.4565 0.7919 0.9355 0.3529 0 -0.6822 0.4565 0.9169 0.8132 0 0 0 0.4103 0.0099 0 0 0 0 0.1389 0 -0.1834 -0.1851 0.5659 0.3040 0 0 0.4011 -0.9122 0.2435 0 0 0 0.4786 -0.2432 0 0 0 0 -0.5272 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 slicot-5.0+20101122/examples/MB03TD.res000077500000000000000000000032311201767322700167720ustar00rootroot00000000000000MB03TD EXAMPLE PROGRAM RESULTS The orthogonal symplectic factor U is 0.0407 0.4847 0.8737 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1245 -0.3866 0.2087 0.4509 -0.1047 0.3229 0.1248 -0.0843 0.1967 0.6415 -0.0933 0.4089 -0.2225 -0.4085 0.0709 -0.2171 0.2156 -0.1095 0.4348 0.5551 -0.1059 -0.5250 0.2962 -0.0295 0.2207 -0.6789 0.1133 -0.0312 0.2979 -0.1112 0.3937 0.3071 -0.1887 0.5332 -0.4351 -0.4423 0.0600 -0.0127 0.1679 -0.1179 0.0000 0.0000 0.0000 0.0000 0.0000 0.0407 0.4847 0.8737 0.0000 0.0000 -0.3229 -0.1248 0.0843 -0.1967 -0.6415 0.1245 -0.3866 0.2087 0.4509 -0.1047 0.2171 -0.2156 0.1095 -0.4348 -0.5551 -0.0933 0.4089 -0.2225 -0.4085 0.0709 0.6789 -0.1133 0.0312 -0.2979 0.1112 -0.1059 -0.5250 0.2962 -0.0295 0.2207 0.4423 -0.0600 0.0127 -0.1679 0.1179 0.3937 0.3071 -0.1887 0.5332 -0.4351 Orthogonality of U: || U'*U - I ||_F = .21E-14 The matrix A in reordered Schur canonical form is 0.4565 -0.4554 0.2756 -0.8651 -1.2050 1.1863 0.4565 0.2186 -0.0233 0.8293 0.0000 0.0000 0.9501 0.0625 -0.0064 0.0000 0.0000 0.0000 0.4103 0.5597 0.0000 0.0000 0.0000 0.0000 0.1389 The matrix G is 0.0000 0.3298 -0.0292 -0.1571 0.1751 -0.3298 0.0000 -0.0633 -0.2951 0.2396 0.0292 0.0633 0.0000 0.9567 0.7485 0.1571 0.2951 -0.9567 0.0000 0.2960 -0.1751 -0.2396 -0.7485 -0.2960 0.0000 slicot-5.0+20101122/examples/MB03UD.dat000077500000000000000000000002231201767322700167500ustar00rootroot00000000000000 MB03UD EXAMPLE PROGRAM DATA 4 V V -1.0 37.0 -12.0 -12.0 0.0 -10.0 0.0 4.0 0.0 0.0 7.0 -6.0 0.0 0.0 0.0 -9.0 slicot-5.0+20101122/examples/MB03UD.res000077500000000000000000000010541201767322700167740ustar00rootroot00000000000000 MB03UD EXAMPLE PROGRAM RESULTS Singular values are 42.0909 11.7764 5.4420 0.2336 The transpose of the right singular vectors matrix is 0.0230 -0.9084 0.2759 0.3132 0.0075 -0.1272 0.5312 -0.8376 0.0092 0.3978 0.8009 0.4476 0.9997 0.0182 -0.0177 -0.0050 The left singular vectors matrix is -0.9671 -0.0882 -0.0501 -0.2335 0.2456 -0.1765 -0.4020 -0.8643 0.0012 0.7425 0.5367 -0.4008 -0.0670 0.6401 -0.7402 0.1945 slicot-5.0+20101122/examples/MB03VD.dat000077500000000000000000000002501201767322700167510ustar00rootroot00000000000000MB03VD EXAMPLE PROGRAM DATA 4 2 1 4 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. slicot-5.0+20101122/examples/MB03VD.res000077500000000000000000000012631201767322700167770ustar00rootroot00000000000000 MB03VD EXAMPLE PROGRAM RESULTS Reduced matrices K = 1 -2.3926 2.7042 -0.9598 -1.2335 4.1417 -1.7046 1.3001 -1.3120 0.0000 -1.6247 -0.2534 1.6453 0.0000 0.0000 -0.0169 -0.4451 K = 2 -2.5495 2.3402 4.7021 0.2329 0.0000 1.9725 -0.2483 -2.3493 0.0000 0.0000 -0.6290 -0.5975 0.0000 0.0000 0.0000 -0.4426 Transformation matrices K = 1 1.0000 0.0000 0.0000 0.0000 0.0000 -0.7103 0.5504 -0.4388 0.0000 -0.4735 -0.8349 -0.2807 0.0000 -0.5209 0.0084 0.8536 K = 2 -0.5883 0.2947 0.7528 -0.0145 -0.3922 -0.8070 0.0009 -0.4415 -0.5883 0.4292 -0.6329 -0.2630 -0.3922 -0.2788 -0.1809 0.8577 NORM (Q'*A*Q - Aout) = 2.93760D-15 slicot-5.0+20101122/examples/MB03WD.dat000077500000000000000000000002601201767322700167530ustar00rootroot00000000000000MB03WD EXAMPLE PROGRAM DATA 4 2 1 4 1 4 S V 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. slicot-5.0+20101122/examples/MB03WD.res000077500000000000000000000015771201767322700170100ustar00rootroot00000000000000 MB03WD EXAMPLE PROGRAM RESULTS Computed eigenvalues ( 6.449861 , 7.817717 ) ( 6.449861 , -7.817717 ) ( 0.091315 , 0.000000 ) ( 0.208964 , 0.000000 ) Reduced matrices K = 1 2.2112 4.3718 -2.3362 0.8907 -0.9179 2.7688 -0.6570 -2.2426 0.0000 0.0000 0.3022 0.1932 0.0000 0.0000 0.0000 -0.4571 K = 2 2.9169 3.4539 2.2016 1.2367 0.0000 3.4745 1.0209 -2.0720 0.0000 0.0000 0.3022 -0.1932 0.0000 0.0000 0.0000 -0.4571 Transformation matrices K = 1 0.3493 0.6751 -0.6490 0.0327 0.7483 -0.4863 -0.1249 -0.4336 0.2939 0.5504 0.7148 -0.3158 0.4813 -0.0700 0.2286 0.8433 K = 2 0.2372 0.7221 0.6490 0.0327 0.8163 -0.3608 0.1249 -0.4336 0.2025 0.5902 -0.7148 -0.3158 0.4863 0.0076 -0.2286 0.8433 NORM (Z'*A*Z - Aout) = 7.10254D-15 slicot-5.0+20101122/examples/MB03XD.dat000077500000000000000000000026201201767322700167560ustar00rootroot00000000000000MB03XD EXAMPLE PROGRAM DATA 5 N G U V 3.7588548168313685e-001 9.1995720669587144e-001 1.9389317998466821e-001 5.4878212553858818e-001 6.2731478808399666e-001 9.8764628987858052e-003 8.4472150190817474e-001 9.0481233416635698e-001 9.3158335257969060e-001 6.9908013774533750e-001 4.1985780631021896e-001 3.6775288246828447e-001 5.6920574967174709e-001 3.3519743020639464e-001 3.9718395379261456e-001 7.5366962581358721e-001 6.2080133182114383e-001 6.3178992922175603e-001 6.5553105501201447e-001 4.1362889533818031e-001 7.9387177473231862e-001 7.3127726446634478e-001 2.3441295540825388e-001 3.9190420688900335e-001 6.5521294635567051e-001 1.8015558545989005e-001 4.1879254941592853e-001 2.7203760737317784e-001 2.8147214090719214e-001 1.7731904815580199e-001 3.4718672159409536e-001 2.7989257702981651e-001 3.5042861661866559e-001 2.5565572408444881e-001 4.3977750345993827e-001 2.8855026075967616e-001 2.1496327083014577e-001 1.7341073886969158e-001 3.9913855375815932e-001 4.0151317011596516e-001 4.0331887464437133e-001 2.6723538667317948e-001 3.7110275606849241e-001 3.7832182695699140e-001 3.3812641389556752e-001 8.4360396433341395e-002 4.3672540277019672e-001 7.0022228267365608e-002 3.8210230186291916e-001 1.9548216143135175e-001 2.9055490787446736e-001 4.7670819669167425e-001 1.4636498713707141e-001 2.7670398401519275e-001 2.9431082727794898e-002 slicot-5.0+20101122/examples/MB03XD.res000077500000000000000000000137241201767322700170060ustar00rootroot00000000000000 MB03XD EXAMPLE PROGRAM RESULTS The stable eigenvalues are i WR(i) WI(i) 1 -3.1941 0.0000 2 -0.1350 0.3179 3 -0.1350 -0.3179 4 -0.0595 0.2793 5 -0.0595 -0.2793 The matrix S of the reduced matrix is -3.1844761777714705 0.1612357243439340 -0.0628592203751098 0.2449004200921959 0.1974400149992626 0.0000000000000000 -0.1510667773167789 0.4260444411622883 -0.1775026035208666 0.3447278421198391 0.0000000000000000 -0.1386140422054271 -0.3006779624777444 0.2944143257134114 0.3456440339120371 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.2710128384740574 0.0933189808067095 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.4844146572359634 0.2004347508746742 The matrix T of the reduced matrix is 3.2038208121776348 0.1805955192510640 0.2466389119377566 -0.2539149302433392 -0.0359238844381156 0.0000000000000000 -0.7196686433290816 0.0000000000000000 0.2428659121580376 -0.0594190100670782 0.0000000000000000 0.0000000000000000 -0.1891741194498114 -0.3309578443491296 -0.0303520731950499 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.4361574461961528 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.1530894573304223 The matrix G of the reduced matrix is -0.0370982242678457 0.0917788436945731 -0.0560402416315241 0.1345152517579191 0.0256668227276677 0.0652183678916931 -0.0700457231988316 0.0350041175858833 -0.2233868768749274 -0.1171980260782826 -0.0626428681377085 0.2327575351902817 -0.1251515732208144 -0.0177816046663199 0.3696921118421150 0.0746042309265577 -0.0828007611045206 0.0217427473546019 -0.1157775118548848 -0.3161183681200569 0.1374372236164831 0.1002727885506978 0.4021556774753979 -0.0431072263235601 0.1067394572547818 Residual: || H*V - U*R ||_F = .46E-14 The orthogonal symplectic factor U is 0.3806883009357248 -0.0347810363019652 -0.5014665065895682 0.5389691288472414 0.2685446895251484 -0.1795922007470743 0.1908329820840928 0.0868799433942036 0.3114741142062438 -0.2579907627915120 0.4642712665555325 -0.5942766860716391 0.4781179763952650 0.2334370556238112 0.0166790369048892 -0.2447897730222851 -0.1028403314750051 -0.1157840914576275 -0.1873268885694416 0.1700708002861561 0.2772789197782786 -0.0130145392695875 -0.2123817030594140 -0.2550292626960040 -0.5049268366774471 -0.2243335325285328 0.3180998613802515 0.3315380214794929 0.1977859924739848 0.5072476567310018 0.4209268575081796 0.1499593172661209 -0.1925590746592153 -0.5472292877802430 0.4543329704184027 -0.2128397588651423 -0.2740560593051887 0.1941418870268840 -0.3096684962457376 -0.0581576193198811 0.3969669479129447 0.6321903535930841 0.3329156356041933 0.0163533225344418 -0.2638879466190077 -0.2002027567371932 -0.0040094115506849 -0.3979373387545270 0.1520881534833964 -0.2010804514091296 0.1795922007470743 -0.1908329820840928 -0.0868799433942036 -0.3114741142062438 0.2579907627915120 0.3806883009357248 -0.0347810363019652 -0.5014665065895682 0.5389691288472414 0.2685446895251484 0.2447897730222851 0.1028403314750051 0.1157840914576275 0.1873268885694416 -0.1700708002861561 0.4642712665555325 -0.5942766860716391 0.4781179763952650 0.2334370556238112 0.0166790369048892 0.2243335325285328 -0.3180998613802515 -0.3315380214794929 -0.1977859924739848 -0.5072476567310018 0.2772789197782786 -0.0130145392695875 -0.2123817030594140 -0.2550292626960040 -0.5049268366774471 0.2128397588651423 0.2740560593051887 -0.1941418870268840 0.3096684962457376 0.0581576193198811 0.4209268575081796 0.1499593172661209 -0.1925590746592153 -0.5472292877802430 0.4543329704184027 0.2002027567371932 0.0040094115506849 0.3979373387545270 -0.1520881534833964 0.2010804514091296 0.3969669479129447 0.6321903535930841 0.3329156356041933 0.0163533225344418 -0.2638879466190077 Orthogonality of U: || U^T U - I ||_F = .44E-14 The orthogonal symplectic factor V is 0.4447147692018326 -0.6830166755147431 -0.0002576861753472 0.5781954611783312 -0.0375091627893765 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.5121756358795811 0.0297197140254803 0.4332229148788684 -0.3240527006890551 0.5330850295256574 0.0299719306696789 -0.2322624725320721 -0.0280846899680319 -0.3044255686880006 -0.1077641482535489 0.3664711365265599 0.3288511296455133 0.0588396016404453 0.1134221597062261 0.1047567336850063 -0.0069083614679702 0.3351358347080118 -0.4922707032978923 0.4293545450291748 0.4372821269061881 0.4535357098437906 0.1062866148880800 -0.3964092656837794 -0.2211800890450660 0.0350667323996171 0.0167847133528844 0.2843629278945297 0.5958979805231186 0.3097336757510848 -0.2086733033047147 0.4450432900616095 0.2950206358263791 -0.1617837757183793 -0.0376369332204956 -0.6746752660482674 0.0248567764822071 -0.2810759958040470 -0.1653113624869855 -0.3528780198620398 -0.0254898556119232 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.4447147692018326 -0.6830166755147431 -0.0002576861753472 0.5781954611783312 -0.0375091627893765 -0.0299719306696789 0.2322624725320721 0.0280846899680319 0.3044255686880006 0.1077641482535489 0.5121756358795811 0.0297197140254803 0.4332229148788684 -0.3240527006890551 0.5330850295256574 0.0069083614679702 -0.3351358347080118 0.4922707032978923 -0.4293545450291748 -0.4372821269061881 0.3664711365265599 0.3288511296455133 0.0588396016404453 0.1134221597062261 0.1047567336850063 -0.0167847133528844 -0.2843629278945297 -0.5958979805231186 -0.3097336757510848 0.2086733033047147 0.4535357098437906 0.1062866148880800 -0.3964092656837794 -0.2211800890450660 0.0350667323996171 -0.0248567764822071 0.2810759958040470 0.1653113624869855 0.3528780198620398 0.0254898556119232 0.4450432900616095 0.2950206358263791 -0.1617837757183793 -0.0376369332204956 -0.6746752660482674 Orthogonality of V: || V^T V - I ||_F = .28E-14 slicot-5.0+20101122/examples/MB03XP.dat000077500000000000000000000025061201767322700167750ustar00rootroot00000000000000MB03XP EXAMPLE PROGRAM DATA 8 1 8 0.9708 -1.1156 -0.0884 -0.2684 0.2152 0.0402 0.0333 0.5141 -1.6142 2.8635 1.0420 -0.2295 -0.3560 0.4885 0.1026 -0.0164 0 1.1138 0.3509 -0.0963 0.0875 0.2158 0.2444 -0.2838 0 0 -0.5975 0.1021 -0.1026 -0.0062 -0.2646 -0.0745 0 0 0 0.6181 0.1986 0.3612 -0.1750 0.3332 0 0 0 0 -0.7387 -0.5201 0.0713 0.0501 0 0 0 0 0 -0.2677 -0.4918 -0.2838 0 0 0 0 0 0 0.3011 0.3389 0.9084 0.1739 0.5915 0.8729 0.8188 0.1911 0.4122 0.5527 0 0.1708 0.1197 0.2379 0.4302 0.4225 0.9016 0.4001 0 0 0.0381 0.6458 0.8903 0.8560 0.0056 0.1988 0 0 0 0.9669 0.7349 0.4902 0.2974 0.6252 0 0 0 0 0.6873 0.8159 0.0492 0.7334 0 0 0 0 0 0.4608 0.6932 0.3759 0 0 0 0 0 0 0.6501 0.0099 0 0 0 0 0 0 0 0.4199 slicot-5.0+20101122/examples/MB03XP.res000077500000000000000000000061721201767322700170210ustar00rootroot00000000000000 MB03XP EXAMPLE PROGRAM RESULTS The reduced matrix A is -0.6290 -0.1397 -0.0509 0.1603 -0.3248 0.2381 0.0694 0.0103 1.5112 -3.4273 -0.4485 -0.4357 -0.3456 0.4619 0.5998 0.5654 0.0000 0.0000 0.0547 -0.4360 0.1714 -0.2103 -0.0900 -0.4011 0.0000 0.0000 0.6623 0.2038 0.2796 -0.2629 0.3837 0.2382 0.0000 0.0000 0.0000 0.0000 -0.6315 0.2071 -0.0174 -0.3538 0.0000 0.0000 0.0000 0.0000 0.0000 -0.5850 -0.1813 0.2435 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.7884 0.1535 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.2832 Residual: || A*Z - Q*S ||_F = .46E-14 The reduced matrix B is -0.9231 0.0000 -0.9834 0.1805 0.4428 0.3655 -0.4300 0.8498 0.0000 -0.1837 -0.1873 0.0681 0.8412 -0.0556 0.0538 0.6113 0.0000 0.0000 -1.8997 0.0000 0.5651 -0.2785 0.2882 1.0458 0.0000 0.0000 0.0000 -0.2602 0.3527 -0.0020 -0.3396 0.2739 0.0000 0.0000 0.0000 0.0000 0.8521 -0.0164 0.2115 0.5446 0.0000 0.0000 0.0000 0.0000 0.0000 0.0283 -0.5128 0.0153 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.4153 0.4587 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.5894 Residual: || B*Q - Z*T ||_F = .39E-14 The orthogonal factor Q is -0.5333 0.3661 -0.1179 0.0264 0.0026 0.7527 0.0018 0.0189 0.0583 -0.8833 -0.0666 -0.0007 0.0017 0.4603 0.0050 0.0092 -0.8414 -0.2927 0.0347 0.0452 -0.0005 -0.4498 -0.0269 0.0001 0.0077 0.0046 -0.5687 -0.4810 0.0227 -0.0708 -0.6500 0.1312 0.0598 0.0059 -0.6128 0.7656 0.1348 -0.0863 0.0038 0.0954 -0.0242 -0.0016 -0.4295 -0.4163 0.3871 -0.0709 0.6964 -0.0417 0.0027 0.0001 0.3109 0.0620 0.8615 0.0378 -0.2267 0.3231 0.0012 0.0000 0.0188 -0.0514 -0.2987 -0.0172 0.2010 0.9312 Orthogonality of Q: || Q'*Q - I ||_F = .52E-14 The orthogonal factor Z is 0.9957 -0.0786 0.0397 -0.0032 0.0006 0.0227 0.0104 0.0123 0.0764 0.9956 0.0200 0.0073 -0.0009 0.0389 0.0263 0.0193 -0.0062 0.0235 0.6714 -0.0229 0.0271 -0.4461 -0.5354 -0.2486 -0.0445 -0.0437 0.6098 0.4197 -0.0656 0.6125 0.1248 0.2302 -0.0242 -0.0148 0.4049 -0.6041 0.2808 -0.1328 0.5972 0.1311 0.0096 0.0037 -0.0183 0.6539 0.5114 -0.4136 0.3620 -0.0913 -0.0019 -0.0004 -0.1055 -0.1544 0.7891 0.2944 -0.4436 0.2426 -0.0005 0.0000 -0.0039 0.0826 -0.1786 -0.3853 -0.1119 0.8946 Orthogonality of Z: || Z'*Z - I ||_F = .55E-14 ALPHAR ALPHAI BETA 0.4723 0.1464 1.2811 0.4723 -0.1464 1.2811 -0.0295 0.1416 2.6621 -0.0295 -0.1416 2.6621 -0.6315 0.0000 0.8521 -0.5850 0.0000 0.0283 -0.7884 0.0000 0.4153 0.2832 0.0000 0.5894 slicot-5.0+20101122/examples/MB03ZD.dat000077500000000000000000000067721201767322700167740ustar00rootroot00000000000000MB03ZD EXAMPLE PROGRAM DATA 5 1 A L B N B -3.1844761777714732 0.1612357243439331 -0.0628592203751138 0.2449004200921981 0.1974400149992579 0.0000000000000000 -0.1510667773167784 0.4260444411622838 -0.1775026035208615 0.3447278421198472 0.0000000000000000 -0.1386140422054264 -0.3006779624777515 0.2944143257134196 0.3456440339120323 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.2710128384740570 0.0933189808067138 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.4844146572359603 0.2004347508746697 3.2038208121776366 0.1805955192510651 0.2466389119377561 -0.2539149302433368 -0.0359238844381195 0.0000000000000000 -0.7196686433290816 0.0000000000000000 0.2428659121580384 -0.0594190100670832 0.0000000000000000 0.0000000000000000 -0.1891741194498107 -0.3309578443491266 -0.0303520731950515 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.4361574461961550 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.1530894573304220 -0.0370982242678464 0.0917788436945724 -0.0560402416315252 0.1345152517579192 0.0256668227276700 0.0652183678916931 -0.0700457231988297 0.0350041175858839 -0.2233868768749268 -0.1171980260782843 -0.0626428681377119 0.2327575351902772 -0.1251515732208170 -0.0177816046663201 0.3696921118421182 0.0746042309265599 -0.0828007611045140 0.0217427473546043 -0.1157775118548851 -0.3161183681200527 0.1374372236164812 0.1002727885506992 0.4021556774753973 -0.0431072263235579 0.1067394572547867 0.3806883009357247 -0.0347810363019649 -0.5014665065895758 0.5389691288472394 0.2685446895251367 0.4642712665555326 -0.5942766860716395 0.4781179763952615 0.2334370556238151 0.0166790369048933 0.2772789197782788 -0.0130145392695876 -0.2123817030594055 -0.2550292626960107 -0.5049268366774490 0.4209268575081796 0.1499593172661228 -0.1925590746592156 -0.5472292877802402 0.4543329704184054 0.3969669479129449 0.6321903535930828 0.3329156356041961 0.0163533225344433 -0.2638879466190024 -0.1795922007470742 0.1908329820840911 0.0868799433942070 0.3114741142062388 -0.2579907627915167 -0.2447897730222852 -0.1028403314750045 -0.1157840914576285 -0.1873268885694406 0.1700708002861580 -0.2243335325285328 0.3180998613802520 0.3315380214794822 0.1977859924739963 0.5072476567310013 -0.2128397588651423 -0.2740560593051881 0.1941418870268881 -0.3096684962457369 -0.0581576193198714 -0.2002027567371932 -0.0040094115506855 -0.3979373387545264 0.1520881534833910 -0.2010804514091372 0.4447147692018334 -0.6830166755147440 -0.0002576861753487 0.5781954611783305 -0.0375091627893805 0.5121756358795817 0.0297197140254773 0.4332229148788766 -0.3240527006890552 0.5330850295256511 0.3664711365265602 0.3288511296455119 0.0588396016404451 0.1134221597062257 0.1047567336850078 0.4535357098437908 0.1062866148880792 -0.3964092656837774 -0.2211800890450674 0.0350667323996222 0.4450432900616097 0.2950206358263853 -0.1617837757183893 -0.0376369332204927 -0.6746752660482623 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0299719306696789 -0.2322624725320701 -0.0280846899680325 -0.3044255686880000 -0.1077641482535519 -0.0069083614679702 0.3351358347080056 -0.4922707032978891 0.4293545450291714 0.4372821269062001 0.0167847133528843 0.2843629278945327 0.5958979805231146 0.3097336757510886 -0.2086733033047188 0.0248567764822071 -0.2810759958040470 -0.1653113624869834 -0.3528780198620412 -0.0254898556119252 slicot-5.0+20101122/examples/MB03ZD.res000077500000000000000000000027531201767322700170100ustar00rootroot00000000000000MB03ZD EXAMPLE PROGRAM RESULTS The stable eigenvalues are i WR(i) WI(i) 1 -3.1941 0.0000 2 -0.1350 0.3179 3 -0.1350 -0.3179 4 -0.0595 0.2793 5 -0.0595 -0.2793 A basis for the stable invariant subspace is -0.102 -0.116 0.627 0.118 -0.605 -0.100 -0.510 -0.266 0.504 0.124 -0.179 0.015 -0.112 -0.142 0.413 -0.055 0.252 0.182 -0.134 0.100 -0.078 0.576 -0.271 -0.252 -0.177 0.340 -0.135 0.053 -0.234 -0.110 0.528 0.108 -0.205 0.219 -0.096 0.397 -0.429 0.161 -0.598 0.199 0.444 0.342 0.447 0.406 0.440 0.434 0.014 -0.383 0.072 -0.391 Orthogonality of US: || US'*US - I ||_F = .62E-15 Symplecticity of US: || US'*J*US ||_F = .23E-14 A basis for the unstable invariant subspace is -0.428 0.383 0.048 0.105 0.187 -0.506 -0.100 0.541 0.245 0.223 -0.334 -0.524 -0.044 -0.153 0.126 -0.453 0.076 0.103 -0.525 -0.268 -0.436 0.098 -0.752 0.209 -0.251 -0.093 -0.089 0.258 -0.114 -0.725 -0.112 -0.196 -0.186 -0.302 0.394 -0.120 -0.286 0.027 0.680 -0.119 -0.102 0.630 0.079 0.040 0.127 -0.091 -0.171 -0.136 -0.136 0.231 Orthogonality of UU: || UU'*UU - I ||_F = .69E-15 Symplecticity of UU: || UU'*J*UU ||_F = .10E-13 slicot-5.0+20101122/examples/MB04AD.dat000077500000000000000000000024651201767322700167370ustar00rootroot00000000000000MB04AD EXAMPLE PROGRAM DATA T C C C C 8 3.1472 4.5751 -0.7824 1.7874 -2.2308 -0.6126 2.0936 4.5974 4.0579 4.6489 4.1574 2.5774 -4.5383 -1.1844 2.5469 -1.5961 -3.7301 -3.4239 2.9221 2.4313 -4.0287 2.6552 -2.2397 0.8527 4.1338 4.7059 4.5949 -1.0777 3.2346 2.9520 1.7970 -2.7619 1.3236 4.5717 1.5574 1.5548 1.9483 -3.1313 1.5510 2.5127 -4.0246 -0.1462 -4.6429 -3.2881 -1.8290 -0.1024 -3.3739 -2.4490 -2.2150 3.0028 3.4913 2.0605 4.5022 -0.5441 -3.8100 0.0596 0.4688 -3.5811 4.3399 -4.6817 -4.6555 1.4631 -0.0164 1.9908 3.9090 -3.5071 3.1428 -3.0340 -1.4834 3.7401 -0.1715 0.4026 4.5929 -2.4249 -2.5648 -2.4892 3.7401 -2.1416 1.6251 2.6645 0.4722 3.4072 4.2926 1.1604 -0.1715 1.6251 -4.2415 -0.0602 -3.6138 -2.4572 -1.5002 -0.2671 0.4026 2.6645 -0.0602 -3.7009 0.6882 -1.8421 -4.1122 0.1317 -3.9090 -4.5929 -0.4722 3.6138 -1.8421 2.9428 -0.4340 1.3834 3.5071 2.4249 -3.4072 2.4572 -4.1122 -0.4340 -2.3703 0.5231 -3.1428 2.5648 -4.2926 1.5002 0.1317 1.3834 0.5231 -4.1618 3.0340 2.4892 -1.1604 0.2671 slicot-5.0+20101122/examples/MB04AD.res000077500000000000000000000076271201767322700167650ustar00rootroot00000000000000MB04AD EXAMPLE PROGRAM RESULTS The matrix T on exit is -3.9699 3.7658 5.5815 -1.7750 -0.8818 -0.0511 -4.2158 1.9054 0.0000 5.3686 -5.9166 4.9163 1.3839 0.8870 3.9458 -4.9167 0.0000 0.0000 5.9641 1.9432 -2.0680 2.4402 -1.4091 5.8512 0.0000 0.0000 0.0000 5.9983 -3.8172 4.0147 -2.0739 -1.2570 0.0000 0.0000 0.0000 0.0000 8.2005 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5732 8.0098 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.6017 2.4397 5.9751 0.0000 0.0000 0.0000 0.0000 0.0000 -2.5869 0.5598 0.2544 5.2129 The matrix Z on exit is -6.4705 -2.5511 -4.0551 -1.9895 -2.7642 0.7532 -4.1047 -2.2046 0.0000 7.3589 -4.4480 -2.7491 -1.5465 -1.4345 -0.9272 1.3121 0.0000 0.0000 4.9125 -0.4968 5.3574 3.8579 5.2547 -1.7324 0.0000 0.0000 0.0000 9.0822 0.0460 -0.3382 3.9302 3.1084 0.0000 0.0000 0.0000 0.0000 6.1869 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 5.5573 6.6549 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 2.7456 -3.5789 4.3432 0.0000 0.0000 0.0000 0.0000 0.0000 0.1549 3.5335 3.1346 4.1062 The matrix H is -7.4834 0.4404 2.3558 1.6724 -0.4630 1.9533 1.5724 -2.7254 0.0000 -7.3500 3.7414 3.7466 0.2837 0.6849 0.7727 -4.2140 0.0000 0.0000 -2.3493 -3.7994 -0.6872 1.1773 -2.6901 -5.1494 0.0000 0.0000 0.0000 -3.4719 5.3322 0.4182 1.9779 1.5175 0.0000 0.0000 0.0000 0.0000 -6.1880 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.3324 9.0833 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8703 0.0799 -2.8180 0.0000 0.0000 0.0000 0.0000 0.0000 -2.3477 3.3110 0.6561 0.7281 The matrix Q1 is -0.2489 -0.1409 0.3615 0.6458 0.0113 0.6063 -0.0470 0.0238 -0.2436 0.1294 -0.0874 -0.4103 0.3408 0.3628 -0.3267 0.6272 -0.4316 -0.2352 0.5553 -0.2811 -0.2198 -0.2880 -0.4564 -0.1773 0.1992 -0.2176 -0.5198 0.1561 -0.1523 0.1299 -0.7281 -0.2197 0.0161 0.7390 0.1125 -0.2226 -0.1003 0.3608 -0.1118 -0.4886 -0.5824 0.0984 -0.3052 0.1996 0.5889 -0.2442 0.0060 -0.3341 -0.3246 0.4661 -0.1835 0.3523 -0.5153 -0.3034 -0.0865 0.3931 -0.4559 -0.2961 -0.3790 -0.3127 -0.4356 0.3452 0.3642 -0.1467 The matrix Q2 is 0.0288 -0.1842 -0.6791 -0.2115 -0.4790 0.4212 -0.0417 -0.2253 -0.0666 -0.0787 -0.3711 0.1737 -0.0482 -0.5770 -0.6785 0.1607 0.1506 0.6328 0.0518 -0.6266 0.0652 -0.0790 -0.2854 -0.2994 -0.2900 -0.2737 -0.0076 -0.3671 -0.2017 -0.6241 0.4521 -0.2675 0.3353 0.4107 0.0326 0.1400 -0.6447 -0.2043 0.2561 0.4187 0.0905 -0.1648 -0.2363 -0.5323 0.3180 0.0286 0.1252 0.7126 -0.7246 0.0468 0.3328 -0.1794 -0.3639 0.2257 -0.2623 0.2786 0.4922 -0.5353 0.4803 -0.2501 -0.2723 0.0199 -0.3194 -0.0371 The upper left block of the matrix U1 is 0.4144 0.2249 0.6015 -0.1964 -0.0198 0.5131 -0.2823 -0.3058 -0.6620 0.1508 0.2237 0.0240 -0.0743 -0.4323 -0.0332 -0.7263 The upper right block of the matrix U1 is -0.3474 0.1306 -0.3391 -0.3530 -0.3760 0.1550 0.6087 -0.1646 0.1707 0.6553 -0.1262 -0.1177 0.3048 -0.0773 0.0767 -0.4173 The upper left block of the matrix U2 is 0.1403 -0.6447 -0.6536 -0.3707 0.7069 0.2609 -0.0091 -0.1702 -0.1218 -0.1120 0.3766 -0.5154 0.0773 0.6349 -0.5070 -0.1810 The upper right block of the matrix U2 is 0.0000 0.0000 0.0000 0.0000 0.1182 0.1587 0.1930 -0.5716 0.6051 -0.2720 0.3364 0.1089 0.2823 -0.0386 -0.1529 0.4434 The vector ALPHAR is 0.0000 0.7122 0.0000 0.7450 The vector ALPHAI is 0.7540 0.0000 0.7465 0.0000 The vector BETA is 4.0000 4.0000 8.0000 16.0000 slicot-5.0+20101122/examples/MB04BD.dat000077500000000000000000000013111201767322700167250ustar00rootroot00000000000000MB04BD EXAMPLE PROGRAM DATA T I I 8 3.1472 1.3236 4.5751 4.5717 4.0579 -4.0246 4.6489 -0.1462 -3.7301 -2.2150 -3.4239 3.0028 4.1338 0.4688 4.7059 -3.5811 0.0000 0.0000 -1.5510 -4.5974 -2.5127 3.5071 0.0000 0.0000 1.5961 2.4490 -3.1428 2.5648 0.0000 0.0000 -0.0596 3.0340 2.4892 -1.1604 0.0000 0.0000 0.6882 -3.3782 -3.3435 1.8921 -0.3061 2.9428 1.0198 2.4815 -4.8810 -1.8878 -2.3703 -0.4946 -1.6288 0.2853 1.5408 -4.1618 -2.4013 -2.7102 0.3834 -3.9335 3.1730 -3.1815 -2.3620 4.9613 4.6190 3.6869 3.6929 0.7970 0.4986 -4.9537 -4.1556 3.5303 1.2206 -1.4905 0.1325 -1.0022 slicot-5.0+20101122/examples/MB04BD.res000077500000000000000000000050771201767322700167630ustar00rootroot00000000000000MB04BD EXAMPLE PROGRAM RESULTS The matrix A on exit is -4.7460 4.1855 3.2696 -0.2244 0.0000 6.4157 2.8287 1.4553 0.0000 0.0000 7.4626 1.5726 0.0000 0.0000 0.0000 8.8702 The matrix D on exit is 0.0000 -1.3137 -6.3615 -0.8940 0.0000 0.0000 1.0704 -0.0659 4.4324 0.0000 0.0000 -0.6922 0.5254 1.6653 0.0000 0.0000 The matrix B on exit is -6.4937 -2.1982 -1.3881 1.3477 0.0000 4.6929 0.6650 -4.1191 0.0000 0.0000 9.1725 3.4721 0.0000 0.0000 0.0000 7.2106 The matrix F on exit is 0.0000 -1.1367 2.2966 -1.0744 0.0000 0.0000 3.7875 0.9427 0.0000 0.0000 0.0000 -4.7136 0.0000 0.0000 0.0000 0.0000 The matrix C1 on exit is 6.9525 -4.9881 2.3661 4.2188 0.0000 8.5009 0.7182 5.5533 0.0000 0.0000 -4.6650 -2.8177 0.0000 0.0000 0.0000 1.5124 The matrix C2 on exit is -5.4562 -2.1348 4.9694 -2.2744 2.5550 -7.9616 1.1516 3.4912 0.0000 0.0000 4.8504 0.5046 0.0000 0.0000 0.0000 4.4394 The matrix V on exit is 0.9136 4.1106 -0.0079 3.5789 -1.1553 -1.4785 -1.5155 -0.8018 -2.2167 4.8029 1.3645 2.5202 -1.0994 -0.6144 0.3970 2.0730 The vector ALPHAR is 0.8314 -1.1758 0.8131 0.0000 The vector ALPHAI is 0.4372 0.6183 0.0000 0.9164 The vector BETA is 0.7071 1.0000 1.4142 2.8284 The matrix Q1 is -0.0098 0.1978 0.2402 0.5274 0.1105 -0.0149 -0.1028 0.7759 -0.6398 0.2356 0.2765 -0.1301 -0.5351 -0.3078 0.2435 0.0373 0.1766 -0.4781 0.2657 -0.5415 0.0968 -0.4663 -0.0983 0.3741 0.3207 -0.1980 0.1141 0.0240 -0.1712 0.2630 0.8513 0.1451 -0.6551 -0.2956 -0.0288 -0.1169 0.5593 0.3381 0.1753 0.1055 -0.0246 -0.2759 0.2470 -0.1408 -0.4837 0.6567 -0.4042 0.1172 -0.0772 -0.0121 -0.8394 -0.1852 -0.2673 0.0046 0.0159 0.4282 0.1442 0.6884 0.1257 -0.5860 0.2110 0.2699 0.0363 0.1657 The matrix Q2 is -0.2891 0.3096 0.6312 0.6498 0.0000 0.0000 0.0000 0.0000 0.1887 0.1936 -0.3857 0.3664 0.5660 0.1238 -0.2080 -0.5148 -0.2492 -0.2877 -0.0874 0.1110 -0.1081 -0.2999 0.6800 -0.5207 -0.7430 -0.0646 -0.4689 0.1556 -0.2401 0.0181 -0.3724 0.0562 -0.0999 -0.2026 -0.0355 0.0866 0.5587 -0.6625 -0.0114 0.4349 -0.4357 0.1209 0.0489 -0.2990 0.5094 0.5191 0.3837 0.1661 -0.2429 0.4131 0.2549 -0.5525 0.0749 -0.3829 -0.2690 -0.4190 0.0889 0.7439 -0.3960 0.0697 -0.1821 -0.1988 0.3687 0.2616 slicot-5.0+20101122/examples/MB04DD.dat000077500000000000000000000015051201767322700167340ustar00rootroot00000000000000MB04DD EXAMPLE PROGRAM DATA 6 B 0 0 0 0 0 0 0.0994 0 0 0 0 0.9696 0.3248 0 0 0 0.4372 0.8308 0 0 0 0.0717 0 0 0 0 0 0 0 0.1976 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0.0651 0 0 0 0 0 0 0 0 0 0 0 0.0444 0 0 0.1957 0 0.8144 0 0 0 0.3652 0 0.9121 0.9023 0 0 0 0 0 1.0945 slicot-5.0+20101122/examples/MB04DD.res000077500000000000000000000022161201767322700167550ustar00rootroot00000000000000 MB04DD EXAMPLE PROGRAM RESULTS The balanced matrix A is 0.0000 0.0000 0.0000 0.0000 0.0000 0.9696 0.0000 0.0000 0.0000 0.0000 -0.8144 -0.9023 0.0000 0.0000 0.0000 0.0000 0.1093 0.2077 0.0000 0.0000 0.0000 0.0717 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1976 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The balanced matrix QG is 0.0000 0.0000 0.0994 0.0000 0.0651 0.0000 0.0000 0.0000 0.0000 0.0000 0.0812 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1776 0.0000 0.0000 0.1957 0.0000 0.0000 0.0000 0.0000 0.0000 0.3652 0.0000 0.9121 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0945 ILO = 3 Norm of subdiagonal blocks: 0.0 slicot-5.0+20101122/examples/MB04DS.dat000077500000000000000000000015051201767322700167530ustar00rootroot00000000000000MB04DS EXAMPLE PROGRAM DATA 6 B 0.0576 0 0.5208 0 0.7275 -0.7839 0.1901 0.0439 0.1663 0.0928 0.6756 -0.5030 0.5962 0 0.4418 0 -0.5955 0.7176 0.5869 0 0.3939 0.0353 0.6992 -0.0147 0.2222 0 -0.3663 0 0.5548 -0.4608 0 0 0 0 0 0.1338 0 0 -0.9862 -0.4544 -0.4733 0.4435 0 0 0 0 -0.6927 0.6641 0.4453 0 -0.3676 0 0 0 0.0841 0.3533 0 0 0 0 0 0 0.0877 0 0.9561 0 0.4784 0 0 0 0 -0.0164 -0.4514 -0.8289 -0.6831 -0.1536 0 0 slicot-5.0+20101122/examples/MB04DS.res000077500000000000000000000016441201767322700170000ustar00rootroot00000000000000 MB04DS EXAMPLE PROGRAM RESULTS The balanced matrix A is 0.1338 0.4514 0.6831 0.8289 0.1536 0.0164 0.0000 0.0439 0.0928 0.1663 0.6756 0.1901 0.0000 0.0000 0.0353 0.3939 0.6992 0.5869 0.0000 0.0000 0.0000 0.4418 -0.5955 0.5962 0.0000 0.0000 0.0000 -0.3663 0.5548 0.2222 0.0000 0.0000 0.0000 0.5208 0.7275 0.0576 The balanced matrix QG is 0.0000 0.0000 0.5030 0.0147 -0.7176 0.4608 0.7839 0.0000 0.0000 0.0000 0.6641 -0.6927 0.4453 0.9862 0.0000 0.0000 0.0000 0.0000 -0.0841 0.0877 0.4733 0.0000 0.0000 0.0000 0.0000 0.0000 0.3533 0.4544 0.0000 0.0000 0.0000 0.4784 0.0000 0.0000 -0.4435 0.0000 0.0000 0.0000 0.3676 -0.9561 0.0000 0.0000 ILO = 4 Norm of subdiagonal blocks: 0.0 slicot-5.0+20101122/examples/MB04DY.dat000077500000000000000000000002731201767322700167620ustar00rootroot00000000000000MB04DY EXAMPLE PROGRAM DATA 3 S -0.4 0.05 0.0007 -4.7 0.8 0.025 81.0 29.0 -0.9 0.0034 0.0014 0.00077 -0.005 0.0004 0.003 -18.0 -12.0 43.0 99.0 420.0 -200.0 slicot-5.0+20101122/examples/MB04DY.res000077500000000000000000000007551201767322700170100ustar00rootroot00000000000000 MB04DY EXAMPLE PROGRAM RESULTS The scaled Hamiltonian is -0.4000 0.4000 0.3584 418.4403 21.5374 0.1851 -0.5875 0.8000 1.6000 21.5374 -9.6149 0.0120 0.1582 0.4531 -0.9000 0.1851 0.0120 0.0014 -0.0001 -0.0008 0.1789 0.4000 0.5875 -0.1582 -0.0008 0.0515 13.9783 -0.4000 -0.8000 -0.4531 0.1789 13.9783 -426.0056 -0.3584 -1.6000 0.9000 The scaling factors are 0.0029 0.0228 1.4595 slicot-5.0+20101122/examples/MB04GD.dat000077500000000000000000000004001201767322700167300ustar00rootroot00000000000000 MB04GD EXAMPLE PROGRAM DATA 6 5 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 5. 5. 1. 5. 1. -2. -1. -1. 0. -2. 4. 8. 4. 20. 4. -2. -1. -1. 0. -2. 0 0 0 0 0 0 slicot-5.0+20101122/examples/MB04GD.res000077500000000000000000000005741201767322700167650ustar00rootroot00000000000000 MB04GD EXAMPLE PROGRAM RESULTS Row permutations are 2 4 6 3 1 5 The matrix A is 0.0000 -1.0517 -1.8646 -1.9712 1.2374 0.0000 -1.0517 -1.8646 -1.9712 1.2374 0.0000 -1.0517 -1.8646 -1.9712 1.2374 0.0000 0.0000 4.6768 0.0466 -7.4246 0.0000 0.0000 0.0000 6.7059 -5.4801 0.0000 0.0000 0.0000 0.0000 -22.6274 slicot-5.0+20101122/examples/MB04MD.dat000077500000000000000000000002151201767322700167420ustar00rootroot00000000000000 MB04MD EXAMPLE PROGRAM DATA 4 0.0 1.0 0.0 0.0 0.0 300.0 400.0 500.0 600.0 1.0 2.0 0.0 0.0 1.0 1.0 1.0 1.0 slicot-5.0+20101122/examples/MB04MD.res000077500000000000000000000004471201767322700167720ustar00rootroot00000000000000 MB04MD EXAMPLE PROGRAM RESULTS The balanced matrix is 1.0000 0.0000 0.0000 0.0000 30.0000 400.0000 50.0000 60.0000 1.0000 20.0000 0.0000 0.0000 1.0000 10.0000 1.0000 1.0000 SCALE is 1.0000 10.0000 1.0000 1.0000 slicot-5.0+20101122/examples/MB04OD.dat000077500000000000000000000003121201767322700167420ustar00rootroot00000000000000 MB04OD EXAMPLE PROGRAM DATA 3 2 2 F 3. 2. 1. 0. 2. 1. 0. 0. 1. 2. 3. 1. 4. 6. 5. 3. 2. 1. 3. 3. 2. 1. 3. 3. 2. slicot-5.0+20101122/examples/MB04OD.res000077500000000000000000000005101201767322700167630ustar00rootroot00000000000000 MB04OD EXAMPLE PROGRAM RESULTS The updated matrix R is -5.3852 -6.6850 -4.6424 0.0000 -2.8828 -2.0694 0.0000 0.0000 -1.7793 The updated matrix B is -4.2710 -3.7139 -0.1555 -2.1411 -1.6021 0.9398 The updated matrix C is 0.5850 1.0141 -2.7974 -3.1162 slicot-5.0+20101122/examples/MB04PB.dat000077500000000000000000000011261201767322700167450ustar00rootroot00000000000000MB04PB EXAMPLE PROGRAM DATA 5 0.9501 0.7621 0.6154 0.4057 0.0579 0.2311 0.4565 0.7919 0.9355 0.3529 0.6068 0.0185 0.9218 0.9169 0.8132 0.4860 0.8214 0.7382 0.4103 0.0099 0.8913 0.4447 0.1763 0.8936 0.1389 0.3869 0.4055 0.2140 1.0224 1.1103 0.7016 1.3801 0.7567 1.4936 1.2913 0.9515 1.1755 0.7993 1.7598 1.6433 1.0503 0.8839 1.1010 1.2019 1.1956 0.9346 0.6824 0.7590 1.1364 0.8780 0.9029 1.6565 1.1022 0.7408 0.3793 slicot-5.0+20101122/examples/MB04PB.res000077500000000000000000000033751201767322700167760ustar00rootroot00000000000000 TMB04PB EXAMPLE PROGRAM RESULTS The symplectic orthogonal factor U is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0927 0.2098 0.5594 -0.0226 0.0000 0.5538 0.3184 0.2519 -0.4031 0.0000 -0.2435 0.4745 -0.6362 -0.2542 0.0000 0.3207 -0.2455 0.0595 -0.2819 0.0000 -0.1950 -0.1770 -0.1519 -0.2857 0.0000 0.4823 0.4122 -0.2060 0.6173 0.0000 -0.3576 -0.0480 0.2302 0.4512 0.0000 0.3523 -0.6047 -0.3110 0.1635 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.5538 -0.3184 -0.2519 0.4031 0.0000 -0.0927 0.2098 0.5594 -0.0226 0.0000 -0.3207 0.2455 -0.0595 0.2819 0.0000 -0.2435 0.4745 -0.6362 -0.2542 0.0000 -0.4823 -0.4122 0.2060 -0.6173 0.0000 -0.1950 -0.1770 -0.1519 -0.2857 0.0000 -0.3523 0.6047 0.3110 -0.1635 0.0000 -0.3576 -0.0480 0.2302 0.4512 Orthogonality of U: || U'*U - I ||_F = .77E-15 The reduced matrix A is 0.9501 -1.5494 0.5268 0.3187 -0.6890 -2.4922 2.0907 -1.3598 0.5682 0.5618 0.0000 -1.7723 0.3960 -0.2624 -0.3709 0.0000 0.0000 -0.2648 0.2136 -0.3226 0.0000 0.0000 0.0000 -0.2308 0.2319 The reduced matrix QG is 0.3869 0.4055 0.0992 0.5237 -0.4110 -0.4861 0.0000 -3.7784 -4.1609 0.3614 0.3606 -0.0696 0.0000 0.0000 1.2192 -0.0848 0.2007 0.3735 0.0000 0.0000 0.0000 -0.8646 0.1538 -0.1970 0.0000 0.0000 0.0000 0.0000 -0.4527 0.0743 Residual: || H - U*R*U' ||_F = .33E-14 slicot-5.0+20101122/examples/MB04PU.dat000077500000000000000000000011261201767322700167700ustar00rootroot00000000000000MB04PU EXAMPLE PROGRAM DATA 5 0.9501 0.7621 0.6154 0.4057 0.0579 0.2311 0.4565 0.7919 0.9355 0.3529 0.6068 0.0185 0.9218 0.9169 0.8132 0.4860 0.8214 0.7382 0.4103 0.0099 0.8913 0.4447 0.1763 0.8936 0.1389 0.4055 0.3869 1.3801 0.7993 1.2019 0.8780 0.2140 1.4936 0.7567 1.7598 1.1956 0.9029 1.0224 1.2913 1.0503 1.6433 0.9346 1.6565 1.1103 0.9515 0.8839 0.7590 0.6824 1.1022 0.7016 1.1755 1.1010 1.1364 0.3793 0.7408 slicot-5.0+20101122/examples/MB04PU.res000077500000000000000000000033751201767322700170210ustar00rootroot00000000000000 TMB04PU EXAMPLE PROGRAM RESULTS The symplectic orthogonal factor U is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1119 0.7763 -0.2005 -0.0001 0.0000 0.1036 -0.2783 -0.2583 0.4356 0.0000 -0.2937 0.2320 0.4014 0.5541 0.0000 0.4949 0.1187 -0.0294 -0.3632 0.0000 -0.2352 -0.2243 -0.7056 -0.0500 0.0000 0.5374 0.3102 -0.0893 0.0318 0.0000 -0.4314 -0.0354 0.2658 -0.6061 0.0000 0.3396 -0.3230 0.3931 0.0207 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1036 0.2783 0.2583 -0.4356 0.0000 -0.1119 0.7763 -0.2005 -0.0001 0.0000 -0.4949 -0.1187 0.0294 0.3632 0.0000 -0.2937 0.2320 0.4014 0.5541 0.0000 -0.5374 -0.3102 0.0893 -0.0318 0.0000 -0.2352 -0.2243 -0.7056 -0.0500 0.0000 -0.3396 0.3230 -0.3931 -0.0207 0.0000 -0.4314 -0.0354 0.2658 -0.6061 Orthogonality of U: || U'*U - I ||_F = .16E-14 The reduced matrix A is 0.9501 -1.8690 0.8413 -0.0344 -0.0817 -2.0660 2.7118 -1.6646 0.7606 -0.0285 0.0000 -2.4884 0.4115 -0.4021 0.3964 0.0000 0.0000 -0.5222 0.1767 -0.3081 0.0000 0.0000 0.0000 0.1915 -0.3426 The reduced matrix QG is 0.4055 0.3869 -0.4295 0.9242 -0.7990 -0.0268 0.0000 -3.0834 -2.5926 0.0804 0.1386 -0.1630 0.0000 0.0000 1.3375 0.9618 -0.0263 0.1829 0.0000 0.0000 0.0000 -0.3556 0.6662 0.2123 0.0000 0.0000 0.0000 0.0000 0.1337 -0.8622 Residual: || H - U*R*U' ||_F = .60E-14 slicot-5.0+20101122/examples/MB04TB.dat000077500000000000000000000020621201767322700167510ustar00rootroot00000000000000MB04TB EXAMPLE PROGRAM DATA 5 N N 0.4643 0.3655 0.6853 0.5090 0.3718 0.3688 0.6460 0.4227 0.6798 0.5135 0.7458 0.5043 0.9419 0.9717 0.9990 0.7140 0.4941 0.7802 0.5272 0.1220 0.7418 0.0339 0.7441 0.0436 0.6564 -0.4643 -0.3688 -0.7458 -0.7140 -0.7418 -0.3655 -0.6460 -0.5043 -0.4941 -0.0339 -0.6853 -0.4227 -0.9419 -0.7802 -0.7441 -0.5090 -0.6798 -0.9717 -0.5272 -0.0436 -0.3718 -0.5135 -0.9990 -0.1220 -0.6564 0.7933 1.5765 1.0711 1.0794 0.8481 1.5765 0.1167 1.5685 0.8756 0.5037 1.0711 1.5685 0.9902 0.3858 0.2109 1.0794 0.8756 0.3858 1.8834 1.4338 0.8481 0.5037 0.2109 1.4338 0.1439 1.0786 1.5264 1.1721 1.5343 0.4756 1.5264 0.8644 0.6872 1.1379 0.6499 1.1721 0.6872 1.5194 1.1197 1.0158 1.5343 1.1379 1.1197 0.6612 0.2004 0.4756 0.6499 1.0158 0.2004 1.2188 slicot-5.0+20101122/examples/MB04TB.res000077500000000000000000000063471201767322700170040ustar00rootroot00000000000000 MB04TB EXAMPLE PROGRAM RESULTS The orthogonal symplectic factor U is -0.1513 0.0756 -0.0027 0.1694 -0.2999 0.3515 -0.4843 0.6545 -0.1995 -0.1627 -0.1202 0.2320 0.1662 -0.2835 -0.0508 0.4975 0.3319 -0.2686 -0.4186 -0.4649 -0.2431 0.2724 0.3439 0.3954 0.0236 0.3820 -0.2863 -0.4324 0.3706 0.1984 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 0.5000 0.3659 0.1429 0.0493 0.6015 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 0.1550 -0.4441 -0.0396 0.2376 -0.1702 -0.3515 0.4843 -0.6545 0.1995 0.1627 -0.1513 0.0756 -0.0027 0.1694 -0.2999 -0.4975 -0.3319 0.2686 0.4186 0.4649 -0.1202 0.2320 0.1662 -0.2835 -0.0508 -0.3820 0.2863 0.4324 -0.3706 -0.1984 -0.2431 0.2724 0.3439 0.3954 0.0236 -0.5000 -0.3659 -0.1429 -0.0493 -0.6015 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 -0.1550 0.4441 0.0396 -0.2376 0.1702 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 Orthogonality of U: || U^T U - I ||_F = .24E-14 The factor R is -3.0684 4.6724 -0.2613 -0.1996 0.0208 -0.1071 -0.1355 -0.1400 0.4652 -0.5032 0.0000 -1.8037 -0.0301 -0.1137 0.1771 0.0277 0.3929 0.5424 0.5220 -0.4843 0.0000 0.0000 -0.7617 -0.1874 0.2557 0.1244 -0.0012 0.4091 0.5123 -0.3522 0.0000 0.0000 0.0000 -0.6931 -0.4293 -0.3718 0.1542 -0.3635 0.0336 -0.9832 0.0000 0.0000 0.0000 0.0000 0.6469 0.2074 0.0266 0.2028 0.1995 0.2517 0.0000 0.0000 0.0000 0.0000 0.0000 2.6325 -4.7377 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.2702 0.9347 -1.1210 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.3219 -0.5394 0.1748 -0.4788 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1431 -0.1021 0.4974 -0.3565 -0.6402 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1622 -0.2368 0.6126 -0.7369 0.6915 Residual: || H*V - U*R ||_F = .87E-14 The orthogonal symplectic factor V is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0061 -0.1732 0.3134 0.2220 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 -0.0382 0.2453 -0.1662 0.0509 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 -0.0665 -0.4132 -0.3100 -0.4457 0.0000 -0.3872 -0.4022 -0.4194 0.3541 0.0000 -0.0406 0.3820 0.3006 0.3861 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0061 0.1732 -0.3134 -0.2220 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0382 -0.2453 0.1662 -0.0509 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 0.0665 0.4132 0.3100 0.4457 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 0.0406 -0.3820 -0.3006 -0.3861 0.0000 -0.3872 -0.4022 -0.4194 0.3541 Orthogonality of V: || V^T V - I ||_F = .14E-14 slicot-5.0+20101122/examples/MB04TS.dat000077500000000000000000000020621201767322700167720ustar00rootroot00000000000000MB04TB EXAMPLE PROGRAM DATA 5 N N 0.4643 0.3655 0.6853 0.5090 0.3718 0.3688 0.6460 0.4227 0.6798 0.5135 0.7458 0.5043 0.9419 0.9717 0.9990 0.7140 0.4941 0.7802 0.5272 0.1220 0.7418 0.0339 0.7441 0.0436 0.6564 -0.4643 -0.3688 -0.7458 -0.7140 -0.7418 -0.3655 -0.6460 -0.5043 -0.4941 -0.0339 -0.6853 -0.4227 -0.9419 -0.7802 -0.7441 -0.5090 -0.6798 -0.9717 -0.5272 -0.0436 -0.3718 -0.5135 -0.9990 -0.1220 -0.6564 0.7933 1.5765 1.0711 1.0794 0.8481 1.5765 0.1167 1.5685 0.8756 0.5037 1.0711 1.5685 0.9902 0.3858 0.2109 1.0794 0.8756 0.3858 1.8834 1.4338 0.8481 0.5037 0.2109 1.4338 0.1439 1.0786 1.5264 1.1721 1.5343 0.4756 1.5264 0.8644 0.6872 1.1379 0.6499 1.1721 0.6872 1.5194 1.1197 1.0158 1.5343 1.1379 1.1197 0.6612 0.2004 0.4756 0.6499 1.0158 0.2004 1.2188 slicot-5.0+20101122/examples/MB04TS.res000077500000000000000000000063471201767322700170250ustar00rootroot00000000000000 MB04TS EXAMPLE PROGRAM RESULTS The orthogonal symplectic factor U is -0.1513 0.0756 -0.0027 0.1694 -0.2999 0.3515 -0.4843 0.6545 -0.1995 -0.1627 -0.1202 0.2320 0.1662 -0.2835 -0.0508 0.4975 0.3319 -0.2686 -0.4186 -0.4649 -0.2431 0.2724 0.3439 0.3954 0.0236 0.3820 -0.2863 -0.4324 0.3706 0.1984 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 0.5000 0.3659 0.1429 0.0493 0.6015 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 0.1550 -0.4441 -0.0396 0.2376 -0.1702 -0.3515 0.4843 -0.6545 0.1995 0.1627 -0.1513 0.0756 -0.0027 0.1694 -0.2999 -0.4975 -0.3319 0.2686 0.4186 0.4649 -0.1202 0.2320 0.1662 -0.2835 -0.0508 -0.3820 0.2863 0.4324 -0.3706 -0.1984 -0.2431 0.2724 0.3439 0.3954 0.0236 -0.5000 -0.3659 -0.1429 -0.0493 -0.6015 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 -0.1550 0.4441 0.0396 -0.2376 0.1702 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 Orthogonality of U: || U^T U - I ||_F = .24E-14 The factor R is -3.0684 4.6724 -0.2613 -0.1996 0.0208 -0.1071 -0.1355 -0.1400 0.4652 -0.5032 0.0000 -1.8037 -0.0301 -0.1137 0.1771 0.0277 0.3929 0.5424 0.5220 -0.4843 0.0000 0.0000 -0.7617 -0.1874 0.2557 0.1244 -0.0012 0.4091 0.5123 -0.3522 0.0000 0.0000 0.0000 -0.6931 -0.4293 -0.3718 0.1542 -0.3635 0.0336 -0.9832 0.0000 0.0000 0.0000 0.0000 0.6469 0.2074 0.0266 0.2028 0.1995 0.2517 0.0000 0.0000 0.0000 0.0000 0.0000 2.6325 -4.7377 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.2702 0.9347 -1.1210 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.3219 -0.5394 0.1748 -0.4788 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1431 -0.1021 0.4974 -0.3565 -0.6402 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1622 -0.2368 0.6126 -0.7369 0.6915 Residual: || H*V - U*R ||_F = .87E-14 The orthogonal symplectic factor V is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0061 -0.1732 0.3134 0.2220 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 -0.0382 0.2453 -0.1662 0.0509 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 -0.0665 -0.4132 -0.3100 -0.4457 0.0000 -0.3872 -0.4022 -0.4194 0.3541 0.0000 -0.0406 0.3820 0.3006 0.3861 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0061 0.1732 -0.3134 -0.2220 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0382 -0.2453 0.1662 -0.0509 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 0.0665 0.4132 0.3100 0.4457 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 0.0406 -0.3820 -0.3006 -0.3861 0.0000 -0.3872 -0.4022 -0.4194 0.3541 Orthogonality of V: || V^T V - I ||_F = .14E-14 slicot-5.0+20101122/examples/MB04UD.dat000077500000000000000000000003401201767322700167510ustar00rootroot00000000000000 MB04UD EXAMPLE PROGRAM DATA 4 4 0.0 2.0 0.0 2.0 -2.0 0.0 -2.0 0.0 2.0 2.0 0.0 -2.0 0.0 2.0 -2.0 0.0 2.0 1.0 0.0 1.0 -1.0 0.0 -1.0 0.0 1.0 1.0 0.0 -1.0 0.0 1.0 -1.0 0.0 1.0 slicot-5.0+20101122/examples/MB04UD.res000077500000000000000000000007111201767322700167740ustar00rootroot00000000000000 MB04UD EXAMPLE PROGRAM RESULTS The transformed matrix A is 0.5164 1.0328 1.1547 -2.3094 0.0000 -2.5820 0.0000 -1.1547 0.0000 0.0000 -3.4641 0.0000 0.0000 0.0000 0.0000 -3.4641 The transformed matrix E is 0.2582 0.5164 0.5774 -1.1547 0.0000 -1.2910 0.0000 -0.5774 0.0000 0.0000 -1.7321 0.0000 0.0000 0.0000 0.0000 -1.7321 The computed rank of E = 4 ISTAIR is 1 2 3 4 slicot-5.0+20101122/examples/MB04VD.dat000077500000000000000000000002161201767322700167540ustar00rootroot00000000000000 MB04VD EXAMPLE PROGRAM DATA 2 4 0.0 S 1.0 0.0 -1.0 0.0 1.0 1.0 0.0 -1.0 0.0 -1.0 0.0 0.0 0.0 -1.0 0.0 0.0 slicot-5.0+20101122/examples/MB04VD.res000077500000000000000000000015651201767322700170050ustar00rootroot00000000000000 MB04VD EXAMPLE PROGRAM RESULTS The unitary transformed pencil is Q'*(s*E-A)*Z, where Matrix Q 0.7071 -0.7071 0.7071 0.7071 Matrix E 0.0000 0.0000 -1.1547 0.8165 0.0000 0.0000 0.0000 0.0000 Matrix A 0.0000 1.7321 0.5774 -0.4082 0.0000 0.0000 0.0000 -1.2247 Matrix Z 0.5774 0.8165 0.0000 0.0000 0.0000 0.0000 0.8165 -0.5774 0.5774 -0.4082 -0.4082 -0.5774 0.5774 -0.4082 0.4082 0.5774 The number of submatrices having full row rank detected in matrix A = 2 The column dimensions of the submatrices having full column rank in the pencil sE(eps) - A(eps) are 2 1 The row dimensions of the submatrices having full row rank in the pencil sE(eps) - A(eps) are 1 0 The orders of the diagonal submatrices in the pencil sE(inf) - A(inf) are 1 MNEI is 1 3 1 slicot-5.0+20101122/examples/MB04XD.dat000077500000000000000000000004711201767322700167610ustar00rootroot00000000000000 MB04XD EXAMPLE PROGRAM DATA 6 4 -1 0.001 0.0 0.0 A A 0.80010 0.39985 0.60005 0.89999 0.29996 0.69990 0.39997 0.82997 0.49994 0.60003 0.20012 0.79011 0.90013 0.20016 0.79995 0.85002 0.39998 0.80006 0.49985 0.99016 0.20002 0.90007 0.70009 1.02994 slicot-5.0+20101122/examples/MB04XD.res000077500000000000000000000021511201767322700167770ustar00rootroot00000000000000 MB04XD EXAMPLE PROGRAM RESULTS The computed rank of matrix A = 3 The elements of the partially diagonalized bidiagonal matrix are (1,1) = 3.2280 (1,2) = -0.0287 (2,2) = 0.8714 (2,3) = 0.0168 (3,3) = 0.3698 (3,4) = 0.0000 (4,4) = 0.0001 Matrix U 0.8933 0.4328 -0.1209 0.2499 -0.5812 0.4913 -0.4493 0.8555 -0.2572 0.1617 -0.4608 -0.7379 -0.0079 0.2841 0.9588 -0.5352 0.1892 0.0525 0.0000 0.0000 0.0003 -0.1741 0.3389 -0.3397 0.0000 0.0000 0.0000 0.6482 0.5428 0.1284 0.0000 0.0000 0.0000 -0.4176 -0.0674 0.2819 Left singular subspace corresponds to the i-th column(s) of U for which INUL(i) = .TRUE., i = 1,...,6 i INUL(i) 1 F 2 F 3 F 4 T 5 T 6 T Matrix V -0.3967 -0.7096 0.4612 -0.3555 0.9150 -0.2557 0.2414 -0.5687 -0.0728 0.6526 0.5215 -0.2128 0.0000 0.0720 0.6761 0.7106 Right singular subspace corresponds to the j-th column(s) of V for which INUL(j) = .TRUE., j = 1,...,4 j INUL(j) 1 F 2 F 3 F 4 T slicot-5.0+20101122/examples/MB04YD.dat000077500000000000000000000002041201767322700167540ustar00rootroot00000000000000 MB04YD EXAMPLE PROGRAM DATA 5 5 2.0 -1 0.0 0.0 N N 1.0 2.0 3.0 4.0 5.0 2.0 3.0 4.0 5.0 slicot-5.0+20101122/examples/MB04YD.res000077500000000000000000000004141201767322700170000ustar00rootroot00000000000000 MB04YD EXAMPLE PROGRAM RESULTS The transformed bidiagonal matrix J is (1,1) = 0.4045 (1,2) = 0.0000 (2,2) = 1.9839 (2,3) = 0.0000 (3,3) = 3.4815 (3,4) = 0.0128 (4,4) = 5.3723 (4,5) = 0.0273 (5,5) = 7.9948 J has 3 singular values > 2.0000 slicot-5.0+20101122/examples/MB04ZD.dat000077500000000000000000000001651201767322700167630ustar00rootroot00000000000000MB04ZD EXAMPLE PROGRAM DATA 3 N 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 1.0 1.0 1.0 2.0 2.0 3.0 7.0 6.0 5.0 8.0 4.0 9.0 slicot-5.0+20101122/examples/MB04ZD.res000077500000000000000000000015411201767322700170030ustar00rootroot00000000000000 MB04ZD EXAMPLE PROGRAM RESULTS The square-reduced Hamiltonian is 1.0000 3.3485 0.3436 1.0000 1.9126 -0.1072 6.7566 11.0750 -0.3014 1.9126 8.4479 -1.0790 2.3478 1.6899 -2.3868 -0.1072 -1.0790 -2.9871 7.0000 8.6275 -0.6352 -1.0000 -6.7566 -2.3478 8.6275 16.2238 -0.1403 -3.3485 -11.0750 -1.6899 -0.6352 -0.1403 1.2371 -0.3436 0.3014 2.3868 The square of the square-reduced Hamiltonian is 48.0000 80.6858 -2.5217 0.0000 1.8590 -10.5824 167.8362 298.4815 -4.0310 -1.8590 0.0000 -33.1160 0.0000 4.5325 2.5185 10.5824 33.1160 0.0000 0.0000 0.0000 0.0000 48.0000 167.8362 0.0000 0.0000 0.0000 0.0000 80.6858 298.4815 4.5325 0.0000 0.0000 0.0000 -2.5217 -4.0310 2.5185 slicot-5.0+20101122/examples/MB05MD.dat000077500000000000000000000002161201767322700167440ustar00rootroot00000000000000 MB05MD EXAMPLE PROGRAM DATA 4 1.0 0.5 0.0 2.3 -2.6 0.0 0.5 -1.4 -0.7 2.3 -1.4 0.5 0.0 -2.6 -0.7 0.0 0.5 slicot-5.0+20101122/examples/MB05MD.res000077500000000000000000000013131201767322700167640ustar00rootroot00000000000000 MB05MD EXAMPLE PROGRAM RESULTS The solution matrix exp(A*DELTA) is 26.8551 -3.2824 18.7409 -19.4430 -3.2824 4.3474 -5.1848 0.2700 18.7409 -5.1848 15.6012 -11.7228 -19.4430 0.2700 -11.7228 15.6012 The eigenvalues of A are -3.0 0.0*j 4.0 0.0*j -1.0 0.0*j 2.0 0.0*j The eigenvector matrix for A is -0.7000 0.7000 0.1000 -0.1000 0.1000 -0.1000 0.7000 -0.7000 0.5000 0.5000 0.5000 0.5000 -0.5000 -0.5000 0.5000 0.5000 The inverse eigenvector matrix for A (premultiplied by exp(Lambda*DELTA)) is -0.0349 0.0050 0.0249 -0.0249 38.2187 -5.4598 27.2991 -27.2991 0.0368 0.2575 0.1839 0.1839 -0.7389 -5.1723 3.6945 3.6945 slicot-5.0+20101122/examples/MB05ND.dat000077500000000000000000000003201201767322700167410ustar00rootroot00000000000000 MB05ND EXAMPLE PROGRAM DATA 5 0.1 0.0001 5.0 4.0 3.0 2.0 1.0 1.0 6.0 0.0 4.0 3.0 2.0 0.0 7.0 6.0 5.0 1.0 3.0 1.0 8.0 7.0 2.0 5.0 7.0 1.0 9.0 slicot-5.0+20101122/examples/MB05ND.res000077500000000000000000000010521201767322700167650ustar00rootroot00000000000000 MB05ND EXAMPLE PROGRAM RESULTS The solution matrix exp(A*DELTA) is 1.8391 0.9476 0.7920 0.8216 0.7811 0.3359 2.2262 0.4013 1.0078 1.0957 0.6335 0.6776 2.6933 1.6155 1.8502 0.4804 1.1561 0.9110 2.7461 2.0854 0.7105 1.4244 1.8835 1.0966 3.4134 and its integral is 0.1347 0.0352 0.0284 0.0272 0.0231 0.0114 0.1477 0.0104 0.0369 0.0368 0.0218 0.0178 0.1624 0.0580 0.0619 0.0152 0.0385 0.0267 0.1660 0.0732 0.0240 0.0503 0.0679 0.0317 0.1863 slicot-5.0+20101122/examples/MB05OD.dat000077500000000000000000000001511201767322700167440ustar00rootroot00000000000000 MB05OD EXAMPLE PROGRAM DATA 3 1.0 S 2.0 1.0 1.0 0.0 3.0 2.0 1.0 0.0 4.0 slicot-5.0+20101122/examples/MB05OD.res000077500000000000000000000005001201767322700167630ustar00rootroot00000000000000 MB05OD EXAMPLE PROGRAM RESULTS The solution matrix E = exp(A*DELTA) is 22.5984 17.2073 53.8144 24.4047 27.6033 83.2241 29.4097 12.2024 81.4177 Minimal number of accurate digits in the norm of E = 13 Number of accurate digits in the norm of E at 95 per cent confidence interval = 15 slicot-5.0+20101122/examples/MC01MD.dat000077500000000000000000000001201201767322700167330ustar00rootroot00000000000000 MC01MD EXAMPLE PROGRAM DATA 5 2.0 6 6.0 5.0 4.0 3.0 2.0 1.0 slicot-5.0+20101122/examples/MC01MD.res000077500000000000000000000005351201767322700167660ustar00rootroot00000000000000 MC01MD EXAMPLE PROGRAM RESULTS ALPHA = 2.0000 The coefficients of the shifted polynomial are power of (x-ALPHA) coefficient 0 120.0000 1 201.0000 2 150.0000 3 59.0000 4 12.0000 5 1.0000 slicot-5.0+20101122/examples/MC01ND.dat000077500000000000000000000001211201767322700167350ustar00rootroot00000000000000 MC01ND EXAMPLE PROGRAM DATA 4 -1.56 0.29 5.0 3.0 -1.0 2.0 1.0 slicot-5.0+20101122/examples/MC01ND.res000077500000000000000000000002041201767322700167600ustar00rootroot00000000000000 MC01ND EXAMPLE PROGRAM RESULTS Real part of P( -1.56 +0.29*j ) = -4.1337 Imaginary part of P( -1.56 +0.29*j ) = 1.7088 slicot-5.0+20101122/examples/MC01OD.dat000077500000000000000000000001431201767322700167420ustar00rootroot00000000000000 MC01OD EXAMPLE PROGRAM DATA 5 1.1 0.9 0.6 -0.7 -2.0 0.3 -0.8 2.5 -0.3 -0.4 slicot-5.0+20101122/examples/MC01OD.res000077500000000000000000000005431201767322700167670ustar00rootroot00000000000000 MC01OD EXAMPLE PROGRAM RESULTS The coefficients of the polynomial P(x) are power of x real part imag part 0 2.7494 -2.1300 1 -1.7590 -5.4205 2 0.0290 2.8290 3 -1.6500 -1.7300 4 1.4000 -2.6000 5 1.0000 0.0000 slicot-5.0+20101122/examples/MC01PD.dat000077500000000000000000000001431201767322700167430ustar00rootroot00000000000000 MC01PD EXAMPLE PROGRAM DATA 5 0.0 1.0 0.0 -1.0 2.0 0.0 1.0 3.0 1.0 -3.0 slicot-5.0+20101122/examples/MC01PD.res000077500000000000000000000004111201767322700167620ustar00rootroot00000000000000 MC01PD EXAMPLE PROGRAM RESULTS The coefficients of the polynomial P(x) are power of x coefficient 0 -20.0000 1 14.0000 2 -24.0000 3 15.0000 4 -4.0000 5 1.0000 slicot-5.0+20101122/examples/MC01QD.dat000077500000000000000000000001251201767322700167440ustar00rootroot00000000000000 MC01QD EXAMPLE PROGRAM DATA 4 2.0 2.0 -1.0 2.0 1.0 2 1.0 -1.0 1.0 slicot-5.0+20101122/examples/MC01QD.res000077500000000000000000000004371201767322700167730ustar00rootroot00000000000000 MC01QD EXAMPLE PROGRAM RESULTS The coefficients of the polynomials Q(x) and R(x) are Q(x) R(x) power of x coefficient coefficient 0 1.0000 1.0000 1 3.0000 0.0000 2 1.0000 slicot-5.0+20101122/examples/MC01RD.dat000077500000000000000000000001451201767322700167470ustar00rootroot00000000000000 MC01RD EXAMPLE PROGRAM DATA 1 1.00 2.50 2 1.00 0.10 -0.40 1 1.15 1.50 -2.20 slicot-5.0+20101122/examples/MC01RD.res000077500000000000000000000003651201767322700167740ustar00rootroot00000000000000 MC01RD EXAMPLE PROGRAM RESULTS Degree of the resulting polynomial P(x) = 3 The coefficients of P(x) are power of x coefficient 0 -1.5300 1 -0.7000 2 -0.1500 3 -1.0000 slicot-5.0+20101122/examples/MC01SD.dat000077500000000000000000000001161201767322700167460ustar00rootroot00000000000000 MC01SD EXAMPLE PROGRAM DATA 5 10.0 -40.5 159.5 0.0 2560.0 -10236.5 slicot-5.0+20101122/examples/MC01SD.res000077500000000000000000000005761201767322700170010ustar00rootroot00000000000000 MC01SD EXAMPLE PROGRAM RESULTS The base of the machine (BETA) = 2 The scaling factors are s = BETA**( -3) and t = BETA**( -2) The coefficients of the scaled polynomial Q(x) = s*P(tx) are power of x coefficient 0 1.2500 1 -1.2656 2 1.2461 3 0.0000 4 1.2500 5 -1.2496 slicot-5.0+20101122/examples/MC01TD.dat000077500000000000000000000001041201767322700167440ustar00rootroot00000000000000 MC01TD EXAMPLE PROGRAM DATA 4 C 2.0 0.0 1.0 -1.0 1.0 slicot-5.0+20101122/examples/MC01TD.res000077500000000000000000000001761201767322700167760ustar00rootroot00000000000000 MC01TD EXAMPLE PROGRAM RESULTS The polynomial P(x) is unstable The number of zeros of P(x) in the right half-plane = 2 slicot-5.0+20101122/examples/MC01VD.dat000077500000000000000000000000571201767322700167550ustar00rootroot00000000000000 MC01VD EXAMPLE PROGRAM DATA 0.5 -1.0 2.0 slicot-5.0+20101122/examples/MC01VD.res000077500000000000000000000002001201767322700167640ustar00rootroot00000000000000 MC01VD EXAMPLE PROGRAM RESULTS The roots of the quadratic equation are x = 1.0000 +1.7321*j x = 1.0000 -1.7321*j slicot-5.0+20101122/examples/MC01WD.dat000077500000000000000000000001341201767322700167520ustar00rootroot00000000000000 MC01WD EXAMPLE PROGRAM DATA 6 0.62 1.10 1.64 1.88 2.12 1.70 1.00 0.60 0.80 slicot-5.0+20101122/examples/MC01WD.res000077500000000000000000000006031201767322700167740ustar00rootroot00000000000000 MC01WD EXAMPLE PROGRAM RESULTS The coefficients of the quotient polynomial Q(x) are power of x coefficient 0 0.6000 1 0.7000 2 0.8000 3 0.9000 4 1.0000 The coefficients of the remainder polynomial R(x) are power of x coefficient 0 0.2600 1 0.2000 slicot-5.0+20101122/examples/MC03MD.dat000077500000000000000000000004661201767322700167520ustar00rootroot00000000000000 MC03MD EXAMPLE PROGRAM DATA 3 2 2 2 1.0 0.0 3.0 2.0 -1.0 2.0 -2.0 4.0 9.0 3.0 7.0 -2.0 6.0 2.0 -3.0 1.0 2.0 4.0 1 6.0 1.0 1.0 7.0 -9.0 -6.0 7.0 8.0 1 1.0 1.0 0.0 0.0 1.0 1.0 -1.0 1.0 1.0 -1.0 -1.0 1.0 1.0 slicot-5.0+20101122/examples/MC03MD.res000077500000000000000000000007121201767322700167650ustar00rootroot00000000000000 MC03MD EXAMPLE PROGRAM RESULTS The polynomial matrix P(x) (of degree 3) is power of x 0 1 2 3 element ( 1, 1) is 9.00 -31.00 37.00 -60.00 element ( 1, 2) is 15.00 41.00 23.00 50.00 element ( 2, 1) is 0.00 38.00 -64.00 -30.00 element ( 2, 2) is -6.00 44.00 100.00 30.00 element ( 3, 1) is 20.00 14.00 -83.00 3.00 element ( 3, 2) is 18.00 33.00 72.00 11.00 slicot-5.0+20101122/examples/MC03ND.dat000077500000000000000000000006551201767322700167530ustar00rootroot00000000000000 MC03ND EXAMPLE PROGRAM DATA 5 4 2 0.0 2.0 2.0 0.0 3.0 0.0 4.0 0.0 6.0 8.0 8.0 0.0 12.0 0.0 0.0 0.0 0.0 2.0 2.0 0.0 3.0 1.0 0.0 1.0 0.0 0.0 0.0 2.0 0.0 4.0 0.0 4.0 0.0 2.0 2.0 0.0 3.0 3.0 2.0 1.0 3.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 slicot-5.0+20101122/examples/MC03ND.res000077500000000000000000000011401201767322700167620ustar00rootroot00000000000000 MC03ND EXAMPLE PROGRAM RESULTS The right nullspace vectors of P(s) are 0.0000 0.0000 0.0000 -0.8321 0.0000 0.1538 0.0000 -1.0000 0.0000 0.5547 0.0000 0.2308 The minimal polynomial basis K(s) (of degree 1) for the right nullspace is power of s 0 1 element ( 1, 1) is 0.00 0.00 element ( 1, 2) is 0.00 0.00 element ( 2, 1) is -0.83 0.00 element ( 2, 2) is 0.00 0.15 element ( 3, 1) is 0.00 0.00 element ( 3, 2) is -1.00 0.00 element ( 4, 1) is 0.55 0.00 element ( 4, 2) is 0.00 0.23 slicot-5.0+20101122/examples/MD03AD.dat000077500000000000000000000001501201767322700167250ustar00rootroot00000000000000 MD03AD EXAMPLE PROGRAM DATA 15 3 100 0 -1. -1. G D F U 1.0 1.0 1.0 slicot-5.0+20101122/examples/MD03AD.res000077500000000000000000000003231201767322700167500ustar00rootroot00000000000000 MD03AD EXAMPLE PROGRAM RESULTS Final 2-norm of the residuals = 0.9063596D-01 The number of function and Jacobian evaluations = 13 12 Final approximate solution is 0.0824 1.1330 2.3437 slicot-5.0+20101122/examples/MD03BD.dat000077500000000000000000000002111201767322700167240ustar00rootroot00000000000000 MD03BD EXAMPLE PROGRAM DATA 15 3 100 5 0 0 1.D2 0 -1. -1. -1. -1. G I E 1.0 1.0 1.0 slicot-5.0+20101122/examples/MD03BD.res000077500000000000000000000003631201767322700167550ustar00rootroot00000000000000 MD03BD EXAMPLE PROGRAM RESULTS IWARN on exit from MD03BD = 1 Final 2-norm of the residuals = 0.9063596D-01 The number of function and Jacobian evaluations = 6 5 Final approximate solution is 0.0824 1.1330 2.3437 slicot-5.0+20101122/examples/SB01BD.dat000077500000000000000000000005571201767322700167430ustar00rootroot00000000000000 SB01BD EXAMPLE PROGRAM DATA 4 2 2 -.4 1.E-8 C -6.8000 0.0000 -207.0000 0.0000 1.0000 0.0000 0.0000 0.0000 43.2000 0.0000 0.0000 -4.2000 0.0000 0.0000 1.0000 0.0000 5.6400 0.0000 0.0000 0.0000 0.0000 1.1800 0.0000 0.0000 -0.5000 0.1500 -0.5000 -0.1500 -2.0000 0.0000 -0.4000 0.0000 slicot-5.0+20101122/examples/SB01BD.res000077500000000000000000000007151201767322700167600ustar00rootroot00000000000000 SB01BD EXAMPLE PROGRAM RESULTS Number of assigned eigenvalues: NAP = 2 Number of fixed eigenvalues: NFP = 2 Number of uncontrollable poles: NUP = 0 The state feedback matrix F is -0.0876 -4.2138 0.0837 -18.1412 -0.0233 18.2483 -0.4259 -4.8120 The eigenvalues of closed-loop matrix A+B*F ( -3.3984, 94.5253 ) ( -3.3984,-94.5253 ) ( -0.5000, 0.1500 ) ( -0.5000, -0.1500 ) NORM(A+B*F - Z*Aout*Z') / (eps*NORM(A)) = 1.03505D+01 slicot-5.0+20101122/examples/SB01DD.dat000077500000000000000000000004221201767322700167340ustar00rootroot00000000000000 SB01DD EXAMPLE PROGRAM DATA 4 2 0.0 I -1.0 0.0 2.0 -3.0 1.0 -4.0 3.0 -1.0 0.0 2.0 4.0 -5.0 0.0 0.0 -1.0 -2.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 -1.0 -1.0 -1.0 -1.0 0.0 0.0 0.0 0.0 1.0 2.0 2.0 1.0 -1.0 -2.0 3.0 1.0 slicot-5.0+20101122/examples/SB01DD.res000077500000000000000000000002131201767322700167530ustar00rootroot00000000000000 SB01DD EXAMPLE PROGRAM RESULTS The state feedback matrix G is -5.2339 3.1725 -15.7885 21.7043 -1.6022 0.8504 -5.1914 6.2339 slicot-5.0+20101122/examples/SB01MD.dat000077500000000000000000000003121201767322700167430ustar00rootroot00000000000000 SB01MD EXAMPLE PROGRAM DATA 4 0.0 I -1.0 0.0 2.0 -3.0 1.0 -4.0 3.0 -1.0 0.0 2.0 4.0 -5.0 0.0 0.0 -1.0 -2.0 1.0 0.0 0.0 0.0 -1.0 -1.0 -1.0 -1.0 0.0 0.0 0.0 0.0 slicot-5.0+20101122/examples/SB01MD.res000077500000000000000000000001661201767322700167730ustar00rootroot00000000000000 SB01MD EXAMPLE PROGRAM RESULTS The one-dimensional state feedback matrix G is 1.0000 29.0000 93.0000 -76.0000 slicot-5.0+20101122/examples/SB02MD.dat000077500000000000000000000002161201767322700167470ustar00rootroot00000000000000 SB02MD EXAMPLE PROGRAM DATA 2 C D U N S 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/SB02MD.res000077500000000000000000000001611201767322700167670ustar00rootroot00000000000000 SB02MD EXAMPLE PROGRAM RESULTS RCOND = 0.31 The solution matrix X is 2.0000 1.0000 1.0000 2.0000 slicot-5.0+20101122/examples/SB02ND.dat000077500000000000000000000002551201767322700167530ustar00rootroot00000000000000 SB02ND EXAMPLE PROGRAM DATA 2 1 3 0.0 D N Z U 2.0 -1.0 1.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 slicot-5.0+20101122/examples/SB02ND.res000077500000000000000000000002311201767322700167660ustar00rootroot00000000000000 SB02ND EXAMPLE PROGRAM RESULTS The solution matrix X is 1.0000 0.0000 0.0000 1.0000 The optimal feedback matrix F is 2.0000 -1.0000 slicot-5.0+20101122/examples/SB02OD.dat000077500000000000000000000002711201767322700167520ustar00rootroot00000000000000 SB02OD EXAMPLE PROGRAM DATA 2 1 3 0.0 C B B U Z S 0.0 1.0 0.0 0.0 0.0 1.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/SB02OD.res000077500000000000000000000001421201767322700167700ustar00rootroot00000000000000 SB02OD EXAMPLE PROGRAM RESULTS The solution matrix X is 1.7321 1.0000 1.0000 1.7321 slicot-5.0+20101122/examples/SB02PD.dat000077500000000000000000000002031201767322700167460ustar00rootroot00000000000000 SB02PD EXAMPLE PROGRAM DATA 2 A N U 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/SB02PD.res000077500000000000000000000003041201767322700167710ustar00rootroot00000000000000 SB02PD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 2.0000 Estimated reciprocal condition number = 0.1333 Estimated error bound = 0.0000000000000063 slicot-5.0+20101122/examples/SB02QD.dat000077500000000000000000000002161201767322700167530ustar00rootroot00000000000000 SB02QD EXAMPLE PROGRAM DATA 2 B N N U O 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/SB02QD.res000077500000000000000000000003311201767322700167720ustar00rootroot00000000000000 SB02QD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 2.0000 Estimated separation = 0.4000 Estimated reciprocal condition number = 0.1333 Estimated error bound = 0.0000 slicot-5.0+20101122/examples/SB02RD.dat000077500000000000000000000002461201767322700167570ustar00rootroot00000000000000 SB02RD EXAMPLE PROGRAM DATA 2 A C D N U N S N O 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/SB02RD.res000077500000000000000000000003321201767322700167740ustar00rootroot00000000000000 SB02RD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 2.0000 Estimated separation = 0.4000 Estimated reciprocal condition number = 0.1333 Estimated error bound = 0.0000 slicot-5.0+20101122/examples/SB02SD.dat000077500000000000000000000002101201767322700167470ustar00rootroot00000000000000 SB02SD EXAMPLE PROGRAM DATA 2 B N N U O 2.0 -1.0 1.0 0.0 0.0 0.0 0.0 1.0 1.0 0.0 0.0 0.0 slicot-5.0+20101122/examples/SB02SD.res000077500000000000000000000003311201767322700167740ustar00rootroot00000000000000 SB02SD EXAMPLE PROGRAM RESULTS The solution matrix X is -0.7691 1.2496 1.2496 -2.3306 Estimated separation = 0.4456 Estimated reciprocal condition number = 0.1445 Estimated error bound = 0.0000 slicot-5.0+20101122/examples/SB03MD.dat000077500000000000000000000002541201767322700167520ustar00rootroot00000000000000 SB03MD EXAMPLE PROGRAM DATA 3 D N X N 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples/SB03MD.res000077500000000000000000000002541201767322700167730ustar00rootroot00000000000000 SB03MD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 1.0000 3.0000 0.0000 1.0000 0.0000 4.0000 Scaling factor = 1.0000 slicot-5.0+20101122/examples/SB03OD.dat000077500000000000000000000004361201767322700167560ustar00rootroot00000000000000 SB03OD EXAMPLE PROGRAM DATA 4 5 C N N -1.0 37.0 -12.0 -12.0 -1.0 -10.0 0.0 4.0 2.0 -4.0 7.0 -6.0 2.0 2.0 7.0 -9.0 1.0 2.5 1.0 3.5 0.0 1.0 0.0 1.0 -1.0 -2.5 -1.0 -1.5 1.0 2.5 4.0 -5.5 -1.0 -2.5 -4.0 3.5 slicot-5.0+20101122/examples/SB03OD.res000077500000000000000000000006061201767322700167760ustar00rootroot00000000000000 SB03OD EXAMPLE PROGRAM RESULTS The transpose of the Cholesky factor U is 1.0000 3.0000 1.0000 2.0000 -1.0000 1.0000 -1.0000 1.0000 -2.0000 1.0000 The solution matrix X = op(U)'*op(U) is 1.0000 3.0000 2.0000 -1.0000 3.0000 10.0000 5.0000 -2.0000 2.0000 5.0000 6.0000 -5.0000 -1.0000 -2.0000 -5.0000 7.0000 Scaling factor = 1.0000 slicot-5.0+20101122/examples/SB03QD.dat000077500000000000000000000002621201767322700167550ustar00rootroot00000000000000 SB03QD EXAMPLE PROGRAM DATA 3 B N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples/SB03QD.res000077500000000000000000000004431201767322700167770ustar00rootroot00000000000000 SB03QD EXAMPLE PROGRAM RESULTS The solution matrix X is 3.2604 2.7187 1.8616 2.7187 4.4271 0.5699 1.8616 0.5699 6.0461 Scaling factor = 1.0000 Estimated separation = 4.9068 Estimated reciprocal condition number = 0.3611 Estimated error bound = 0.0000 slicot-5.0+20101122/examples/SB03SD.dat000077500000000000000000000002621201767322700167570ustar00rootroot00000000000000 SB03SD EXAMPLE PROGRAM DATA 3 B N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples/SB03SD.res000077500000000000000000000004431201767322700170010ustar00rootroot00000000000000 SB03SD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 1.0000 3.0000 0.0000 1.0000 0.0000 4.0000 Scaling factor = 1.0000 Estimated separation = 5.2302 Estimated reciprocal condition number = 0.1832 Estimated error bound = 0.0000 slicot-5.0+20101122/examples/SB03TD.dat000077500000000000000000000002621201767322700167600ustar00rootroot00000000000000 SB03TD EXAMPLE PROGRAM DATA 3 A N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples/SB03TD.res000077500000000000000000000004431201767322700170020ustar00rootroot00000000000000 SB03TD EXAMPLE PROGRAM RESULTS The solution matrix X is 3.2604 2.7187 1.8616 2.7187 4.4271 0.5699 1.8616 0.5699 6.0461 Scaling factor = 1.0000 Estimated separation = 4.9068 Estimated reciprocal condition number = 0.3611 Estimated error bound = 0.0000 slicot-5.0+20101122/examples/SB03UD.dat000077500000000000000000000002621201767322700167610ustar00rootroot00000000000000 SB03UD EXAMPLE PROGRAM DATA 3 A N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples/SB03UD.res000077500000000000000000000004431201767322700170030ustar00rootroot00000000000000 SB03UD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 1.0000 3.0000 0.0000 1.0000 0.0000 4.0000 Scaling factor = 1.0000 Estimated separation = 5.2302 Estimated reciprocal condition number = 0.1832 Estimated error bound = 0.0000 slicot-5.0+20101122/examples/SB04MD.dat000077500000000000000000000002421201767322700167500ustar00rootroot00000000000000 SB04MD EXAMPLE PROGRAM DATA 3 2 2.0 1.0 3.0 0.0 2.0 1.0 6.0 1.0 2.0 2.0 1.0 1.0 6.0 2.0 1.0 1.0 4.0 0.0 5.0 slicot-5.0+20101122/examples/SB04MD.res000077500000000000000000000002711201767322700167730ustar00rootroot00000000000000 SB04MD EXAMPLE PROGRAM RESULTS The solution matrix X is -2.7685 0.5498 -1.0531 0.6865 4.5257 -0.4389 The orthogonal matrix Z is -0.9732 -0.2298 0.2298 -0.9732 slicot-5.0+20101122/examples/SB04ND.dat000077500000000000000000000005651201767322700167610ustar00rootroot00000000000000 SB04ND EXAMPLE PROGRAM DATA 5 3 0.0 U U B 17.0 24.0 1.0 8.0 15.0 23.0 5.0 7.0 14.0 16.0 0.0 6.0 13.0 20.0 22.0 0.0 0.0 19.0 21.0 3.0 0.0 0.0 0.0 2.0 9.0 8.0 1.0 6.0 0.0 5.0 7.0 0.0 9.0 2.0 62.0 -12.0 26.0 59.0 -10.0 31.0 70.0 -6.0 9.0 35.0 31.0 -7.0 36.0 -15.0 7.0 slicot-5.0+20101122/examples/SB04ND.res000077500000000000000000000003101201767322700167660ustar00rootroot00000000000000 SB04ND EXAMPLE PROGRAM RESULTS The solution matrix X is 0.0000 0.0000 1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 2.0000 -2.0000 1.0000 slicot-5.0+20101122/examples/SB04OD.dat000077500000000000000000000005241201767322700167550ustar00rootroot00000000000000 SB04OD EXAMPLE PROGRAM DATA 3 2 R N D 1.6 -3.1 1.9 -3.8 4.2 2.4 0.5 2.2 -4.5 1.1 0.1 -1.3 -3.1 -2.0 28.9 -5.7 -11.8 12.9 -31.7 2.5 0.1 1.7 -2.5 0.0 0.9 0.1 5.1 -7.3 6.0 2.4 -3.6 2.5 0.5 23.8 -11.0 -10.4 39.5 -74.8 slicot-5.0+20101122/examples/SB04OD.res000077500000000000000000000011551201767322700167770ustar00rootroot00000000000000 SB04OD EXAMPLE PROGRAM RESULTS The solution matrix L is -0.7538 -1.6210 2.1778 1.7005 -3.5029 2.7961 The solution matrix R is 1.3064 2.7989 0.3698 -5.3376 -0.8767 6.7500 The left transformation matrix P is -0.3093 -0.9502 0.0383 0.9366 -0.2974 0.1851 -0.1645 0.0932 0.9820 The right transformation matrix Q is -0.6097 -0.7920 -0.0314 0.6310 -0.5090 0.5854 0.4796 -0.3371 -0.8102 The left transformation matrix U is -0.8121 0.5835 0.5835 0.8121 The right transformation matrix V is -0.9861 0.1660 0.1660 0.9861 DIF = 0.1147 slicot-5.0+20101122/examples/SB04PD.dat000077500000000000000000000003061201767322700167540ustar00rootroot00000000000000 SB04PD EXAMPLE PROGRAM DATA 3 2 1 D N N N N 2.0 1.0 3.0 0.0 2.0 1.0 6.0 1.0 2.0 2.0 1.0 1.0 6.0 2.0 1.0 1.0 4.0 0.0 5.0 slicot-5.0+20101122/examples/SB04PD.res000077500000000000000000000005071201767322700170000ustar00rootroot00000000000000 SB04PD EXAMPLE PROGRAM RESULTS The solution matrix X is -0.3430 0.1995 -0.1856 0.4192 0.6922 -0.2952 Scaling factor = 1.0000 The orthogonal matrix U is 0.5396 -0.7797 0.3178 0.1954 -0.2512 -0.9480 -0.8190 -0.5736 -0.0168 The orthogonal matrix V is -0.9732 -0.2298 0.2298 -0.9732 slicot-5.0+20101122/examples/SB04QD.dat000077500000000000000000000003531201767322700167570ustar00rootroot00000000000000 SB04QD EXAMPLE PROGRAM DATA 3 3 1.0 2.0 3.0 6.0 7.0 8.0 9.0 2.0 3.0 7.0 2.0 3.0 2.0 1.0 2.0 3.0 4.0 1.0 271.0 135.0 147.0 923.0 494.0 482.0 578.0 383.0 287.0 slicot-5.0+20101122/examples/SB04QD.res000077500000000000000000000004021201767322700167730ustar00rootroot00000000000000 SB04QD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 3.0000 6.0000 4.0000 7.0000 1.0000 5.0000 3.0000 2.0000 The orthogonal matrix Z is 0.8337 0.5204 -0.1845 0.3881 -0.7900 -0.4746 0.3928 -0.3241 0.8606 slicot-5.0+20101122/examples/SB04RD.dat000077500000000000000000000010231201767322700167530ustar00rootroot00000000000000 SB04RD EXAMPLE PROGRAM DATA 5 5 0.0 U U B 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 1.0 0.0 2.0 3.0 4.0 5.0 0.0 0.0 6.0 7.0 8.0 0.0 0.0 0.0 9.0 1.0 1.0 2.0 3.0 4.0 5.0 0.0 1.0 2.0 3.0 4.0 0.0 0.0 1.0 2.0 3.0 0.0 0.0 0.0 1.0 -5.0 0.0 0.0 0.0 4.0 1.0 2.0 4.0 10.0 40.0 7.0 6.0 20.0 40.0 74.0 38.0 0.0 2.0 8.0 36.0 2.0 0.0 0.0 6.0 52.0 -9.0 0.0 0.0 0.0 13.0 -43.0 slicot-5.0+20101122/examples/SB04RD.res000077500000000000000000000004421201767322700170000ustar00rootroot00000000000000 SB04RD EXAMPLE PROGRAM RESULTS The solution matrix X is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/SB06ND.dat000077500000000000000000000004731201767322700167610ustar00rootroot00000000000000 SB06ND EXAMPLE PROGRAM DATA 5 2 0.0 N N -17.0 24.0 41.0 68.0 15.0 23.0 -35.0 27.0 14.0 16.0 34.0 26.0 -13.0 20.0 22.0 10.0 12.0 19.0 -21.0 63.0 11.0 18.0 25.0 52.0 -29.0 -31.0 14.0 74.0 -69.0 -59.0 16.0 16.0 -25.0 -25.0 36.0 slicot-5.0+20101122/examples/SB06ND.res000077500000000000000000000002411201767322700167730ustar00rootroot00000000000000 SB06ND EXAMPLE PROGRAM RESULTS The deadbeat feedback matrix F is -0.4819 -0.5782 -2.7595 -3.1093 0.0000 0.2121 -0.4462 0.7698 -1.5421 -0.5773 slicot-5.0+20101122/examples/SB08CD.dat000077500000000000000000000015251201767322700167470ustar00rootroot00000000000000 SB08CD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/SB08CD.res000077500000000000000000000026541201767322700167740ustar00rootroot00000000000000 SB08CD EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -0.1605 0.0523 0.9423 2.0193 0.4166 0.2518 1.6140 -0.4489 -0.1605 1.7955 3.8719 -0.2394 0.0491 -0.8740 0.0000 0.0000 -12.4245 3.5463 -0.0057 0.0254 -0.0053 0.0000 0.0000 0.0000 -3.5957 -0.0153 -0.0290 -0.0616 0.0000 0.0000 0.0000 0.0000 -13.1627 -1.9835 -3.6182 0.0000 0.0000 0.0000 0.0000 0.0000 -1.4178 5.6218 0.0000 0.0000 0.0000 0.0000 0.0000 -0.8374 -1.4178 The numerator input/state matrix BQ is -1.0157 0.2554 0.5523 0.4443 0.0056 -11.6989 0.0490 4.3728 11.7198 -0.0038 -2.8173 0.0308 3.1018 -0.0009 The numerator state/output matrix CQ is 0.1975 -0.1063 -0.0006 -0.0083 0.1279 0.8797 0.3994 0.8541 -0.4513 -0.0007 -0.0041 0.0305 -0.2562 0.0122 0.4668 0.8826 0.0248 -0.0506 0.0000 0.0022 -0.0017 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -0.1605 0.0523 -0.4489 -0.1605 The denominator input/state matrix BR is -0.0158 -0.0692 -0.1688 0.0306 0.1281 -0.4984 The denominator state/output matrix CR is 0.1975 -0.1063 0.8541 -0.4513 0.4668 0.8826 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/SB08DD.dat000077500000000000000000000015251201767322700167500ustar00rootroot00000000000000 SB08DD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/SB08DD.res000077500000000000000000000025311201767322700167670ustar00rootroot00000000000000 SB08DD EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -1.4178 -5.1682 3.2450 -0.2173 0.0564 -4.1066 -0.2336 0.9109 -1.4178 -2.1262 0.1231 0.0805 -0.4816 0.2196 0.0000 0.0000 -13.1627 0.0608 -0.0218 3.8320 0.3429 0.0000 0.0000 0.0000 -3.5957 -3.3373 0.0816 -4.1237 0.0000 0.0000 0.0000 0.0000 -12.4245 -0.3133 4.4255 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1605 -0.0772 0.0000 0.0000 0.0000 0.0000 0.0000 0.3040 -0.1605 The numerator input/state matrix BQ is 5.0302 -0.0063 0.7078 -0.0409 -11.3663 0.0051 0.1760 0.5879 -0.0265 12.2119 1.1050 0.3215 0.0066 -2.5822 The numerator state/output matrix CQ is -0.8659 0.2787 -0.3432 0.0020 0.0000 0.2325 0.0265 0.0797 -0.3951 0.0976 -0.0292 0.0062 0.8985 0.1406 -0.0165 -0.0645 0.0097 0.8032 -0.1602 0.0874 -0.5630 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -0.1605 -0.0772 0.3040 -0.1605 The denominator input/state matrix BR is 1.1050 0.3215 0.0066 -2.5822 The denominator state/output matrix CR is -0.2288 -0.0259 -0.0070 0.1497 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/SB08ED.dat000077500000000000000000000015321201767322700167470ustar00rootroot00000000000000 SB08ED EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 -1.0 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/SB08ED.res000077500000000000000000000026541201767322700167760ustar00rootroot00000000000000 SB08ED EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -1.0000 0.0526 -0.1408 -0.3060 0.4199 0.2408 1.7274 -0.4463 -1.0000 2.0067 4.3895 0.0062 0.1813 0.0895 0.0000 0.0000 -12.4245 3.5463 -0.0057 0.0254 -0.0053 0.0000 0.0000 0.0000 -3.5957 -0.0153 -0.0290 -0.0616 0.0000 0.0000 0.0000 0.0000 -13.1627 -1.9835 -3.6182 0.0000 0.0000 0.0000 0.0000 0.0000 -1.4178 5.6218 0.0000 0.0000 0.0000 0.0000 0.0000 -0.8374 -1.4178 The numerator input/state matrix BQ is -1.1544 -0.0159 -0.0631 0.5122 0.0056 -11.6989 0.0490 4.3728 11.7198 -0.0038 -2.8173 0.0308 3.1018 -0.0009 The numerator state/output matrix CQ is 0.2238 0.0132 -0.0006 -0.0083 0.1279 0.8797 0.3994 0.9639 0.0643 -0.0007 -0.0041 0.0305 -0.2562 0.0122 -0.0660 0.9962 0.0248 -0.0506 0.0000 0.0022 -0.0017 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -1.0000 0.0526 -0.4463 -1.0000 The denominator input/state matrix BR is -0.2623 -1.1297 0.0764 -0.0155 -0.0752 -1.1676 The denominator state/output matrix CR is 0.2238 0.0132 0.9639 0.0643 -0.0660 0.9962 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/SB08FD.dat000077500000000000000000000015321201767322700167500ustar00rootroot00000000000000 SB08FD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 -1.0 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/SB08FD.res000077500000000000000000000025311201767322700167710ustar00rootroot00000000000000 SB08FD EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -1.4178 -5.1682 3.2450 -0.2173 0.0564 -3.2129 -3.6183 0.9109 -1.4178 -2.1262 0.1231 0.0805 -0.4392 -0.2528 0.0000 0.0000 -13.1627 0.0608 -0.0218 2.3461 5.8272 0.0000 0.0000 0.0000 -3.5957 -3.3373 1.3622 -3.6083 0.0000 0.0000 0.0000 0.0000 -12.4245 -9.8634 8.1191 0.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 -0.0135 0.0000 0.0000 0.0000 0.0000 0.0000 1.7393 -1.0000 The numerator input/state matrix BQ is 5.0302 -0.0063 0.7078 -0.0409 -11.3663 0.0051 0.1760 0.5879 -0.0265 12.2119 1.0104 1.3262 0.4474 -2.2388 The numerator state/output matrix CQ is -0.8659 0.2787 -0.3432 0.0020 0.0000 0.2026 0.1172 0.0797 -0.3951 0.0976 -0.0292 0.0062 0.7676 0.4879 -0.0165 -0.0645 0.0097 0.8032 -0.1602 0.3050 -0.4812 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -1.0000 -0.0135 1.7393 -1.0000 The denominator input/state matrix BR is 1.0104 1.3262 0.4474 -2.2388 The denominator state/output matrix CR is -0.1091 -0.4653 -0.7055 0.4766 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/SB08MD.dat000077500000000000000000000001001201767322700167450ustar00rootroot00000000000000 SB08MD EXAMPLE PROGRAM DATA 3 A 8.0 -6.0 -3.0 1.0 slicot-5.0+20101122/examples/SB08MD.res000077500000000000000000000006411201767322700170000ustar00rootroot00000000000000 SB08MD EXAMPLE PROGRAM RESULTS The coefficients of the polynomial B(s) are power of s coefficient 0 64.0000 2 -84.0000 4 21.0000 6 -1.0000 The coefficients of the spectral factor E(s) are power of s coefficient 0 8.0000 1 14.0000 2 7.0000 3 1.0000 RES = 2.7E-15 slicot-5.0+20101122/examples/SB08ND.dat000077500000000000000000000000711201767322700167550ustar00rootroot00000000000000 SB08ND EXAMPLE PROGRAM DATA 2 A 2.0 4.5 1.0 slicot-5.0+20101122/examples/SB08ND.res000077500000000000000000000005551201767322700170050ustar00rootroot00000000000000 SB08ND EXAMPLE PROGRAM RESULTS The coefficients of the polynomial B(z) are power of z coefficient 0 25.2500 1 13.5000 2 2.0000 The coefficients of the spectral factor E(z) are power of z coefficient 0 0.5000 1 3.0000 2 4.0000 RES = 4.4E-16 slicot-5.0+20101122/examples/SB09MD.dat000077500000000000000000000002761201767322700167640ustar00rootroot00000000000000 SB09MD EXAMPLE PROGRAM DATA 2 2 2 0.0 1.3373 0.1205 0.6618 -0.3372 -0.4062 1.6120 0.9299 0.7429 1.1480 -0.1837 0.8843 -0.4947 -0.4616 1.4674 0.6028 0.9524 slicot-5.0+20101122/examples/SB09MD.res000077500000000000000000000004101201767322700167730ustar00rootroot00000000000000 SB09MD EXAMPLE PROGRAM RESULTS The sum-of-squares matrix SS is 1.9534 1.3027 2.6131 0.6656 The quadratic error matrix SE is 0.0389 0.1565 0.1134 0.0687 The percentage relative error matrix PRE is 14.1125 34.6607 20.8363 32.1262 slicot-5.0+20101122/examples/SB10DD.dat000077500000000000000000000013311201767322700167340ustar00rootroot00000000000000 SB10DD EXAMPLE PROGRAM DATA 6 5 5 2 2 -0.7 0.0 0.3 0.0 -0.5 -0.1 -0.6 0.2 -0.4 -0.3 0.0 0.0 -0.5 0.7 -0.1 0.0 0.0 -0.8 -0.7 0.0 0.0 -0.5 -1.0 0.0 0.0 0.3 0.6 -0.9 0.1 -0.4 0.5 -0.8 0.0 0.0 0.2 -0.9 -1.0 -2.0 -2.0 1.0 0.0 1.0 0.0 1.0 -2.0 1.0 -3.0 -4.0 0.0 2.0 -2.0 1.0 -2.0 1.0 0.0 -1.0 0.0 1.0 -2.0 0.0 3.0 1.0 0.0 3.0 -1.0 -2.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 0.0 0.0 2.0 0.0 -4.0 0.0 -2.0 1.0 -3.0 0.0 0.0 3.0 1.0 0.0 1.0 -2.0 1.0 0.0 -2.0 1.0 -1.0 -2.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 2.0 -1.0 -3.0 0.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 2.0 1.0 111.294 0.00000001 slicot-5.0+20101122/examples/SB10DD.res000077500000000000000000000016211201767322700167570ustar00rootroot00000000000000 SB10DD EXAMPLE PROGRAM RESULTS The controller state matrix AK is -18.0030 52.0376 26.0831 -0.4271 -40.9022 18.0857 18.8203 -57.6244 -29.0938 0.5870 45.3309 -19.8644 -26.5994 77.9693 39.0368 -1.4020 -60.1129 26.6910 -21.4163 62.1719 30.7507 -0.9201 -48.6221 21.8351 -0.8911 4.2787 2.3286 -0.2424 -3.0376 1.2169 -5.3286 16.1955 8.4824 -0.2489 -12.2348 5.1590 The controller input matrix BK is 16.9788 14.1648 -18.9215 -15.6726 25.2046 21.2848 20.1122 16.8322 1.4104 1.2040 5.3181 4.5149 The controller output matrix CK is -9.1941 27.5165 13.7364 -0.3639 -21.5983 9.6025 3.6490 -10.6194 -5.2772 0.2432 8.1108 -3.6293 The controller matrix DK is 9.0317 7.5348 -3.4006 -2.8219 The estimated condition numbers are 0.24960D+00 0.98548D+00 0.99186D+00 0.63733D-05 0.48625D+00 0.29430D-01 0.56942D-02 0.12470D-01 slicot-5.0+20101122/examples/SB10ED.dat000077500000000000000000000013211201767322700167340ustar00rootroot00000000000000 SB10ED EXAMPLE PROGRAM DATA 6 5 5 2 2 -0.7 0.0 0.3 0.0 -0.5 -0.1 -0.6 0.2 -0.4 -0.3 0.0 0.0 -0.5 0.7 -0.1 0.0 0.0 -0.8 -0.7 0.0 0.0 -0.5 -1.0 0.0 0.0 0.3 0.6 -0.9 0.1 -0.4 0.5 -0.8 0.0 0.0 0.2 -0.9 -1.0 -2.0 -2.0 1.0 0.0 1.0 0.0 1.0 -2.0 1.0 -3.0 -4.0 0.0 2.0 -2.0 1.0 -2.0 1.0 0.0 -1.0 0.0 1.0 -2.0 0.0 3.0 1.0 0.0 3.0 -1.0 -2.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 0.0 0.0 2.0 0.0 -4.0 0.0 -2.0 1.0 -3.0 0.0 0.0 3.0 1.0 0.0 1.0 -2.0 1.0 0.0 -2.0 1.0 -1.0 -2.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 2.0 -1.0 -3.0 0.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 2.0 1.0 0.00000001 slicot-5.0+20101122/examples/SB10ED.res000077500000000000000000000016031201767322700167600ustar00rootroot00000000000000 SB10ED EXAMPLE PROGRAM RESULTS The controller state matrix AK is -0.0551 -2.1891 -0.6607 -0.2532 0.6674 -1.0044 -1.0379 2.3804 0.5031 0.3960 -0.6605 1.2673 -0.0876 -2.1320 -0.4701 -1.1461 1.2927 -1.5116 -0.1358 -2.1237 -0.9560 -0.7144 0.6673 -0.7957 0.4900 0.0895 0.2634 -0.2354 0.1623 -0.2663 0.1672 -0.4163 0.2871 -0.1983 0.4944 -0.6967 The controller input matrix BK is -0.5985 -0.5464 0.5285 0.6087 -0.7600 -0.4472 -0.7288 -0.6090 0.0532 0.0658 -0.0663 0.0059 The controller output matrix CK is 0.2500 -1.0200 -0.3371 -0.2733 0.2747 -0.4444 0.0654 0.2095 0.0632 0.2089 -0.1895 0.1834 The controller matrix DK is -0.2181 -0.2070 0.1094 0.1159 The estimated condition numbers are 0.10000D+01 0.10000D+01 0.25207D+00 0.83985D-01 0.48628D-02 0.55015D-03 0.49886D+00 slicot-5.0+20101122/examples/SB10FD.dat000077500000000000000000000013261201767322700167420ustar00rootroot00000000000000 SB10FD EXAMPLE PROGRAM DATA 6 5 5 2 2 -1.0 0.0 4.0 5.0 -3.0 -2.0 -2.0 4.0 -7.0 -2.0 0.0 3.0 -6.0 9.0 -5.0 0.0 2.0 -1.0 -8.0 4.0 7.0 -1.0 -3.0 0.0 2.0 5.0 8.0 -9.0 1.0 -4.0 3.0 -5.0 8.0 0.0 2.0 -6.0 -3.0 -4.0 -2.0 1.0 0.0 2.0 0.0 1.0 -5.0 2.0 -5.0 -7.0 0.0 7.0 -2.0 4.0 -6.0 1.0 1.0 -2.0 -3.0 9.0 -8.0 0.0 5.0 1.0 -2.0 3.0 -6.0 -2.0 1.0 -1.0 2.0 -4.0 0.0 -3.0 -3.0 0.0 5.0 -1.0 1.0 1.0 -7.0 5.0 0.0 -8.0 2.0 -2.0 9.0 -3.0 4.0 0.0 3.0 7.0 0.0 1.0 -2.0 1.0 -6.0 -2.0 1.0 -2.0 -3.0 0.0 0.0 0.0 4.0 0.0 1.0 0.0 5.0 -3.0 -4.0 0.0 1.0 0.0 1.0 0.0 1.0 -3.0 0.0 0.0 1.0 7.0 1.0 15.0 0.00000001 slicot-5.0+20101122/examples/SB10FD.res000077500000000000000000000024121201767322700167600ustar00rootroot00000000000000 SB10FD EXAMPLE PROGRAM RESULTS The controller state matrix AK is -2.8043 14.7367 4.6658 8.1596 0.0848 2.5290 4.6609 3.2756 -3.5754 -2.8941 0.2393 8.2920 -15.3127 23.5592 -7.1229 2.7599 5.9775 -2.0285 -22.0691 16.4758 12.5523 -16.3602 4.4300 -3.3168 30.6789 -3.9026 -1.3868 26.2357 -8.8267 10.4860 -5.7429 0.0577 10.8216 -11.2275 1.5074 -10.7244 The controller input matrix BK is -0.1581 -0.0793 -0.9237 -0.5718 0.7984 0.6627 0.1145 0.1496 -0.6743 -0.2376 0.0196 -0.7598 The controller output matrix CK is -0.2480 -0.1713 -0.0880 0.1534 0.5016 -0.0730 2.8810 -0.3658 1.3007 0.3945 1.2244 2.5690 The controller matrix DK is 0.0554 0.1334 -0.3195 0.0333 The estimated condition numbers are 0.10000D+01 0.10000D+01 0.11241D-01 0.80492D-03 The real parts of the closed-loop system poles are -0.10731D+03 -0.66556D+02 -0.38269D+02 -0.38269D+02 -0.20089D+02 -0.62557D+01 -0.62557D+01 -0.32405D+01 -0.32405D+01 -0.17178D+01 -0.41466D+01 -0.76437D+01 The imaginary parts of the closed-loop system poles are 0.00000D+00 0.00000D+00 0.13114D+02 -0.13114D+02 0.00000D+00 0.12961D+02 -0.12961D+02 0.67998D+01 -0.67998D+01 0.00000D+00 0.00000D+00 0.00000D+00 slicot-5.0+20101122/examples/SB10HD.dat000077500000000000000000000013211201767322700167370ustar00rootroot00000000000000 SB10HD EXAMPLE PROGRAM DATA 6 5 5 2 2 -1.0 0.0 4.0 5.0 -3.0 -2.0 -2.0 4.0 -7.0 -2.0 0.0 3.0 -6.0 9.0 -5.0 0.0 2.0 -1.0 -8.0 4.0 7.0 -1.0 -3.0 0.0 2.0 5.0 8.0 -9.0 1.0 -4.0 3.0 -5.0 8.0 0.0 2.0 -6.0 -3.0 -4.0 -2.0 1.0 0.0 2.0 0.0 1.0 -5.0 2.0 -5.0 -7.0 0.0 7.0 -2.0 4.0 -6.0 1.0 1.0 -2.0 -3.0 9.0 -8.0 0.0 5.0 1.0 -2.0 3.0 -6.0 -2.0 1.0 -1.0 2.0 -4.0 0.0 -3.0 -3.0 0.0 5.0 -1.0 1.0 1.0 -7.0 5.0 0.0 -8.0 2.0 -2.0 9.0 -3.0 4.0 0.0 3.0 7.0 0.0 1.0 -2.0 1.0 -6.0 -2.0 0.0 0.0 0.0 -4.0 -1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 1.0 3.0 1.0 0.0 1.0 -3.0 -2.0 0.0 1.0 7.0 1.0 0.00000001 slicot-5.0+20101122/examples/SB10HD.res000077500000000000000000000017331201767322700167670ustar00rootroot00000000000000 SB10HD EXAMPLE PROGRAM RESULTS The controller state matrix AK is 88.0015 -145.7298 -46.2424 82.2168 -45.2996 -31.1407 25.7489 -31.4642 -12.4198 9.4625 -3.5182 2.7056 54.3008 -102.4013 -41.4968 50.8412 -20.1286 -26.7191 108.1006 -198.0785 -45.4333 70.3962 -25.8591 -37.2741 -115.8900 226.1843 47.2549 -47.8435 -12.5004 34.7474 59.0362 -101.8471 -20.1052 36.7834 -16.1063 -26.4309 The controller input matrix BK is 3.7345 3.4758 -0.3020 0.6530 3.4735 4.0499 4.3198 7.2755 -3.9424 -10.5942 2.1784 2.5048 The controller output matrix CK is -2.3346 3.2556 0.7150 -0.9724 0.6962 0.4074 7.6899 -8.4558 -2.9642 7.0365 -4.2844 0.1390 The controller matrix DK is 0.0000 0.0000 0.0000 0.0000 The estimated condition numbers are 0.23570D+00 0.26726D+00 0.22747D-01 0.21130D-02 slicot-5.0+20101122/examples/SB10ID.dat000077500000000000000000000007041201767322700167440ustar00rootroot00000000000000 SB10ID EXAMPLE PROGRAM DATA 6 2 3 -1.0 0.0 4.0 5.0 -3.0 -2.0 -2.0 4.0 -7.0 -2.0 0.0 3.0 -6.0 9.0 -5.0 0.0 2.0 -1.0 -8.0 4.0 7.0 -1.0 -3.0 0.0 2.0 5.0 8.0 -9.0 1.0 -4.0 3.0 -5.0 8.0 0.0 2.0 -6.0 -3.0 -4.0 2.0 0.0 -5.0 -7.0 4.0 -6.0 -3.0 9.0 1.0 -2.0 1.0 -1.0 2.0 -4.0 0.0 -3.0 -3.0 0.0 5.0 -1.0 1.0 1.0 -7.0 5.0 0.0 -8.0 2.0 -2.0 1.0 -2.0 0.0 4.0 5.0 -3.0 1.0 slicot-5.0+20101122/examples/SB10ID.res000077500000000000000000000014601201767322700167650ustar00rootroot00000000000000 SB10ID EXAMPLE PROGRAM RESULTS The controller state matrix AK is -39.0671 9.9293 22.2322 -27.4113 43.8655 -6.6117 3.0006 11.0878 -11.4130 15.4269 33.6805 -6.6934 -23.9953 14.1438 -33.4358 -32.3191 9.7316 25.4033 -24.0473 42.0517 -44.1655 18.7767 34.8873 -42.4369 50.8437 The controller input matrix BK is -10.2905 -16.5382 -10.9782 -4.3598 -8.7525 -5.1447 6.5962 1.8975 6.2316 -9.8770 -14.7041 -11.8778 -9.6726 -22.7309 -18.2692 The controller output matrix CK is -0.6647 -0.0599 -1.0376 0.5619 1.7297 -8.4202 3.9573 7.3094 -7.6283 10.6768 The controller matrix DK is 0.8466 0.4979 -0.6993 -1.2226 -4.8689 -4.5056 The estimated condition numbers are 0.13861D-01 0.90541D-02 slicot-5.0+20101122/examples/SB10KD.dat000077500000000000000000000006051201767322700167460ustar00rootroot00000000000000 SB10KD EXAMPLE PROGRAM DATA 6 2 2 0.2 0.0 0.3 0.0 -0.3 -0.1 -0.3 0.2 -0.4 -0.3 0.0 0.0 -0.1 0.1 -0.1 0.0 0.0 -0.3 0.1 0.0 0.0 -0.1 -0.1 0.0 0.0 0.3 0.6 0.2 0.1 -0.4 0.2 -0.4 0.0 0.0 0.2 -0.2 -1.0 -2.0 1.0 3.0 -3.0 -4.0 1.0 -2.0 0.0 1.0 1.0 5.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 -1.0 1.1 slicot-5.0+20101122/examples/SB10KD.res000077500000000000000000000015341201767322700167710ustar00rootroot00000000000000 SB10KD EXAMPLE PROGRAM RESULTS The controller state matrix AK is 0.0337 0.0222 0.0858 0.1264 -0.1872 0.1547 0.4457 0.0668 -0.2255 -0.3204 -0.4548 -0.0691 -0.2419 -0.2506 -0.0982 -0.1321 -0.0130 -0.0838 -0.4402 0.3654 -0.0335 -0.2444 0.6366 -0.6469 -0.3623 0.3854 0.4162 0.4502 0.0065 0.1261 -0.0121 -0.4377 0.0604 0.2265 -0.3389 0.4542 The controller input matrix BK is 0.0931 -0.0269 -0.0872 0.1599 0.0956 -0.1469 -0.1728 0.0129 0.2022 -0.1154 0.2419 -0.1737 The controller output matrix CK is -0.3677 0.2188 0.0403 -0.0854 0.3564 -0.3535 0.1624 -0.0708 0.0058 0.0606 -0.2163 0.1802 The controller matrix DK is -0.0857 -0.0246 0.0460 0.0074 The estimated condition numbers are 0.11269D-01 0.17596D-01 0.18225D+00 0.75968D-03 slicot-5.0+20101122/examples/SB10ZD.dat000077500000000000000000000007161201767322700167700ustar00rootroot00000000000000 SB10LD EXAMPLE PROGRAM DATA 6 2 3 0.2 0.0 3.0 0.0 -0.3 -0.1 -3.0 0.2 -0.4 -0.3 0.0 0.0 -0.1 0.1 -1.0 0.0 0.0 -3.0 1.0 0.0 0.0 -1.0 -1.0 0.0 0.0 0.3 0.6 2.0 0.1 -0.4 0.2 -4.0 0.0 0.0 0.2 -2.0 -1.0 -2.0 1.0 3.0 -3.0 -4.0 1.0 -2.0 0.0 1.0 1.0 5.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 -1.0 2.0 4.0 -3.0 0.0 5.0 1.0 10.0 -6.0 -7.0 8.0 2.0 -4.0 1.1 0.0 slicot-5.0+20101122/examples/SB10ZD.res000077500000000000000000000016771201767322700170200ustar00rootroot00000000000000 SB10ZD EXAMPLE PROGRAM RESULTS The controller state matrix AK is 1.0128 0.5101 -0.1546 1.1300 3.3759 0.4911 -2.1257 -1.4517 -0.4486 0.3493 -1.5506 -1.4296 -1.0930 -0.6026 -0.1344 0.2253 -1.5625 -0.6762 0.3207 0.1698 0.2376 -1.1781 -0.8705 0.2896 0.5017 0.9006 0.0668 2.3613 0.2049 0.3703 1.0787 0.6703 0.2783 -0.7213 0.4918 0.7435 The controller input matrix BK is 0.4132 0.3112 -0.8077 0.2140 0.4253 0.1811 -0.0710 0.0807 0.3558 -0.0121 -0.2019 0.0249 0.1047 0.1399 -0.0457 -0.2542 -0.3472 0.0523 The controller output matrix CK is -0.0372 -0.0456 -0.0040 0.0962 -0.2059 -0.0571 0.1999 0.2994 0.1335 -0.0251 -0.3108 0.2048 The controller matrix DK is 0.0629 -0.0022 0.0363 -0.0228 0.0195 0.0600 The estimated condition numbers are 0.27949D-03 0.66679D-03 0.45677D-01 0.23433D-07 0.68495D-01 0.76854D-01 slicot-5.0+20101122/examples/SB16AD.dat000077500000000000000000000005351201767322700167440ustar00rootroot00000000000000 SB16AD EXAMPLE PROGRAM DATA (Continuous system) 3 1 1 3 2 0.0 0.1E0 0.0 C S S F I N F -1. 0. 4. 0. 2. 0. 0. 0. -3. 1. 1. 1. 1. 1. 1. 0. -26.4000 6.4023 4.3868 32.0000 0 0 0 8.0000 0 -16 0 0 9.2994 1.1624 0.1090 0 slicot-5.0+20101122/examples/SB16AD.res000077500000000000000000000007021201767322700167610ustar00rootroot00000000000000 SB16AD EXAMPLE PROGRAM RESULTS The order of reduced controller = 2 The Hankel singular values of weighted ALPHA-stable part are 3.8253 0.2005 The reduced controller state dynamics matrix Ac is 9.1900 0.0000 0.0000 -34.5297 The reduced controller input/state matrix Bc is -11.9593 86.3137 The reduced controller state/output matrix Cc is 2.8955 -1.3566 The reduced controller input/output matrix Dc is 0.0000 slicot-5.0+20101122/examples/SB16BD.dat000077500000000000000000000021111201767322700167350ustar00rootroot00000000000000 SB16BD EXAMPLE PROGRAM DATA (Continuous system) 8 1 1 4 0.1E0 0.0 C D F L S F 0 1.0000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 -0.0150 0.7650 0 0 0 0 0 0 -0.7650 -0.0150 0 0 0 0 0 0 0 0 -0.0280 1.4100 0 0 0 0 0 0 -1.4100 -0.0280 0 0 0 0 0 0 0 0 -0.0400 1.850 0 0 0 0 0 0 -1.8500 -0.040 0.0260 -0.2510 0.0330 -0.8860 -4.0170 0.1450 3.6040 0.2800 -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026 0.0 4.4721e-002 6.6105e-001 4.6986e-003 3.6014e-001 1.0325e-001 -3.7541e-002 -4.2685e-002 3.2873e-002 4.1089e-001 8.6846e-002 3.8523e-004 -3.6194e-003 -8.8037e-003 8.4205e-003 1.2349e-003 4.2632e-003 slicot-5.0+20101122/examples/SB16BD.res000077500000000000000000000012011201767322700167550ustar00rootroot00000000000000 SB16BD EXAMPLE PROGRAM RESULTS The order of reduced controller = 4 The Hankel singular values of extended system are: 4.9078 4.8745 3.8455 3.7811 1.2289 1.1785 0.5176 0.1148 The reduced controller state dynamics matrix Ac is 0.5946 -0.7336 0.1914 -0.3368 0.5960 -0.0184 -0.1088 0.0207 1.2253 0.2043 0.1009 -1.4948 -0.0330 -0.0243 1.3440 0.0035 The reduced controller input/state matrix Bc is 0.0015 -0.0202 0.0159 -0.0544 The reduced controller state/output matrix Cc is 0.3534 0.0274 0.0337 -0.0320 The reduced controller input/output matrix Dc is 0.0000 slicot-5.0+20101122/examples/SB16CD.dat000077500000000000000000000024111201767322700167410ustar00rootroot00000000000000 SB16CD EXAMPLE PROGRAM DATA (Continuous system) 8 1 1 2 0.1E0 C D F R F 0 1.0000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 -0.0150 0.7650 0 0 0 0 0 0 -0.7650 -0.0150 0 0 0 0 0 0 0 0 -0.0280 1.4100 0 0 0 0 0 0 -1.4100 -0.0280 0 0 0 0 0 0 0 0 -0.0400 1.850 0 0 0 0 0 0 -1.8500 -0.040 0.0260 -0.2510 0.0330 -0.8860 -4.0170 0.1450 3.6040 0.2800 -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026 0.0 4.472135954999638e-002 6.610515358414598e-001 4.698598960657579e-003 3.601363251422058e-001 1.032530880771415e-001 -3.754055214487997e-002 -4.268536964759344e-002 3.287284547842979e-002 4.108939884667451e-001 8.684600000000012e-002 3.852317308197148e-004 -3.619366874815911e-003 -8.803722876359955e-003 8.420521094001852e-003 1.234944428038507e-003 4.263205617645322e-003 slicot-5.0+20101122/examples/SB16CD.res000077500000000000000000000006571201767322700167740ustar00rootroot00000000000000 SB16CD EXAMPLE PROGRAM RESULTS The order of reduced controller = 2 The frequency-weighted Hankel singular values are: 3.3073 0.7274 0.1124 0.0784 0.0242 0.0182 0.0101 0.0094 The reduced controller state dynamics matrix Ac is -0.4334 0.4884 -0.1950 -0.1093 The reduced controller input/state matrix Bc is -0.4231 -0.1785 The reduced controller state/output matrix Cc is -0.0326 -0.2307 slicot-5.0+20101122/examples/SG02AD.dat000077500000000000000000000003351201767322700167420ustar00rootroot00000000000000 SG02AD EXAMPLE PROGRAM DATA 2 1 3 0.0 C B B U Z N S N 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 1.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/SG02AD.res000077500000000000000000000001421201767322700167570ustar00rootroot00000000000000 SG02AD EXAMPLE PROGRAM RESULTS The solution matrix X is 1.7321 1.0000 1.0000 1.7321 slicot-5.0+20101122/examples/SG03AD.dat000077500000000000000000000004201201767322700167360ustar00rootroot00000000000000 SG03AD EXAMPLE PROGRAM DATA 3 B C N N U 3.0 1.0 1.0 1.0 3.0 0.0 1.0 0.0 2.0 1.0 3.0 0.0 3.0 2.0 1.0 1.0 0.0 1.0 -64.0 -73.0 -28.0 0.0 -70.0 -25.0 0.0 0.0 -18.0 slicot-5.0+20101122/examples/SG03AD.res000077500000000000000000000003071201767322700167630ustar00rootroot00000000000000 SG03AD EXAMPLE PROGRAM RESULTS SEP = 0.29D+00 FERR = 0.40D-13 SCALE = 0.10D+01 The solution matrix X is -2.0000 -1.0000 0.0000 -1.0000 -3.0000 -1.0000 0.0000 -1.0000 -3.0000 slicot-5.0+20101122/examples/SG03BD.dat000077500000000000000000000003211201767322700167370ustar00rootroot00000000000000 SG03BD EXAMPLE PROGRAM DATA 3 1 C N N -1.0 3.0 -4.0 0.0 5.0 -2.0 -4.0 4.0 1.0 2.0 1.0 3.0 2.0 0.0 1.0 4.0 5.0 1.0 2.0 -1.0 7.0 slicot-5.0+20101122/examples/SG03BD.res000077500000000000000000000002711201767322700167640ustar00rootroot00000000000000 SG03BD EXAMPLE PROGRAM RESULTS SCALE = 1.0000 The Cholesky factor U of the solution matrix is 1.6003 -0.4418 -0.1523 0.0000 0.6795 -0.2499 0.0000 0.0000 0.2041 slicot-5.0+20101122/examples/TAB01MD.f000077500000000000000000000051341201767322700165310ustar00rootroot00000000000000* AB01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDZ PARAMETER ( LDA = NMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), TAU(NMAX), $ Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB01MD, DORGQR * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( B(I), I = 1,N ) * Find a controllable realization for the given system. CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT ) IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' AB01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01MD = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2,//' The state dynamics matrix A of a controlla', $ 'ble realization is ') 99996 FORMAT (/' The input/state vector B of a controllable realizatio', $ 'n is ',/(1X,F8.4)) 99995 FORMAT (/' The similarity transformation matrix Z is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TAB01ND.f000077500000000000000000000071701201767322700165340ustar00rootroot00000000000000* AB01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX, 3*MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, INDCON, J, M, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK), $ TAU(NMAX), Z(LDZ,NMAX) INTEGER IWORK(LIWORK), NBLK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB01ND, DORGQR * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) * Find a controllable ssr for the given system. CALL AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) ( NBLK(I), I = 1,INDCON ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) INDCON IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, $ INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01ND = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2) 99996 FORMAT (/' The transformed state dynamics matrix of a controllab', $ 'le realization is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' and the dimensions of its diagonal blocks are ', $ /20(1X,I2)) 99993 FORMAT (/' The transformed input/state matrix B of a controllabl', $ 'e realization is ') 99992 FORMAT (/' The controllability index of the transformed system r', $ 'epresentation = ',I2) 99991 FORMAT (/' The similarity transformation matrix Z is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TAB01OD.f000077500000000000000000000055471201767322700165430ustar00rootroot00000000000000* AB01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDU, LDV PARAMETER ( LDA = NMAX, LDB = NMAX, LDU = NMAX, $ LDV = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX + MAX( NMAX, 3*MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INDCON, INFO, J, M, N, NCONT CHARACTER*1 JOBU, JOBV, STAGES * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK), $ U(LDU,NMAX), V(LDV,MMAX) INTEGER IWORK(LIWORK), KSTAIR(NMAX) * .. External Subroutines .. EXTERNAL AB01OD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, STAGES, JOBU, JOBV IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) * Reduce the matrices A and B to upper "staircase" form. CALL AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U, $ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) INDCON WRITE ( NOUT, FMT = 99993 ) ( KSTAIR(I), I = 1,INDCON ) END IF END IF END IF STOP * 99999 FORMAT (' AB01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01OD = ',I2) 99997 FORMAT (' The transformed state transition matrix is ') 99996 FORMAT (/' The transformed input matrix is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The number of stairs in the staircase form = ',I3,/) 99993 FORMAT (' The dimensions of the stairs are ',/(20(I3,2X))) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TAB04MD.f000077500000000000000000000062421201767322700165350ustar00rootroot00000000000000* AB04MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA INTEGER I, INFO, J, M, N, P CHARACTER*1 TYPE * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL AB04MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TYPE, ALPHA, BETA IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N ) READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M ) * Transform the parameters (A,B,C,D). CALL AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB04MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB04MD = ',I2) 99997 FORMAT (' The transformed state matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed input matrix is ') 99994 FORMAT (/' The transformed output matrix is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) 99990 FORMAT (/' The transformed input/output matrix is ') END slicot-5.0+20101122/examples/TAB05MD.f000077500000000000000000000117431201767322700165400ustar00rootroot00000000000000* AB05MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, P1MAX, P2MAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, P1MAX = 20, P2MAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2, LDWORK PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX,LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = P2MAX, LDC1 = P1MAX, LDC2 = P2MAX, $ LDD = P2MAX, LDD1 = P1MAX, LDD2 = P2MAX, $ LDWORK = P1MAX*N1MAX ) * .. Local Scalars .. CHARACTER*1 OVER, UPLO INTEGER I, INFO, J, M1, N, N1, N2, P1, P2 * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,M1MAX), B1(LDB1,M1MAX), B2(LDB2,P1MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,M1MAX), D1(LDD1,M1MAX), D2(LDD2,P1MAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB05MD * .. Executable Statements .. * UPLO = 'Lower' OVER = 'N' WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2, P2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99990 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,P1 ) IF ( P2.LE.0 .OR. P2.GT.P2MAX ) THEN WRITE ( NOUT, FMT = 99988 ) P2 ELSE READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P2 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,P1 ), I = 1,P2 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M1 ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P2 WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P2 WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M1 ) 80 CONTINUE END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05MD = ',I2) 99997 FORMAT (' The state transition matrix of the cascaded system is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the cascaded system is ') 99994 FORMAT (/' The state/output matrix of the cascaded system is ') 99993 FORMAT (/' The input/output matrix of the cascaded system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) 99988 FORMAT (/' P2 is out of range.',/' P2 = ',I5) END slicot-5.0+20101122/examples/TAB05ND.f000077500000000000000000000112621201767322700165350ustar00rootroot00000000000000* AB05ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, P1MAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, P1MAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = P1MAX, LDC1 = P1MAX, LDC2 = M1MAX, $ LDD = P1MAX, LDD1 = P1MAX, LDD2 = M1MAX ) INTEGER LDWORK PARAMETER ( LDWORK = P1MAX*P1MAX ) DOUBLE PRECISION ONE PARAMETER ( ONE=1.0D0 ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M1, N, N1, N2, P1 DOUBLE PRECISION ALPHA * .. Local Arrays .. INTEGER IWORK(P1MAX) DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,M1MAX), B1(LDB1,M1MAX), B2(LDB2,P1MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,M1MAX), D1(LDD1,M1MAX), D2(LDD2,P1MAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB05ND * .. Executable Statements .. * OVER = 'N' ALPHA = ONE WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99990 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,P1 ) READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,M1 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,P1 ), I = 1,M1 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M1 ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M1 ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05ND = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) END slicot-5.0+20101122/examples/TAB05OD.f000077500000000000000000000117321201767322700165400ustar00rootroot00000000000000* AB05OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, M2MAX, MMAX, P1MAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, M2MAX = 20, MMAX = M1MAX+M2MAX, $ P1MAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = P1MAX, LDC1 = P1MAX, LDC2 = P1MAX, $ LDD = P1MAX, LDD1 = P1MAX, LDD2 = P1MAX ) DOUBLE PRECISION ONE PARAMETER ( ONE=1.0D0 ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M, M1, M2, N, N1, N2, P1 DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,MMAX), B1(LDB1,M1MAX), B2(LDB2,M2MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,MMAX), D1(LDD1,M1MAX), D2(LDD2,M2MAX) * .. External Subroutines .. EXTERNAL AB05OD * .. Executable Statements .. * OVER = 'N' ALPHA = ONE WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2, M2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99993 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99990 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) IF ( M2.LE.0 .OR. M2.GT.M2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) M2 ELSE READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,M2 ) READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P1 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,M2 ), I = 1,P1 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05OD = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) END slicot-5.0+20101122/examples/TAB05PD.f000077500000000000000000000107511201767322700165410ustar00rootroot00000000000000* AB05PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, MMAX, PMAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ MMAX = 20, PMAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = PMAX, LDC1 = PMAX, LDC2 = PMAX, $ LDD = PMAX, LDD1 = PMAX, LDD2 = PMAX ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M, N, N1, N2, P DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,MMAX), B1(LDB1,MMAX), B2(LDB2,MMAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,MMAX), D1(LDD1,MMAX), D2(LDD2,MMAX) * .. External Subroutines .. EXTERNAL AB05PD * .. Executable Statements .. * OVER = 'N' WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M, P, N2, ALPHA IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M ), I = 1,P ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,M ) READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,M ), I = 1,P ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05PD = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) END slicot-5.0+20101122/examples/TAB05QD.f000077500000000000000000000125531201767322700165440ustar00rootroot00000000000000* AB05QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, M2MAX, MMAX, P1MAX, $ P2MAX, PMAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, M2MAX = 20, MMAX = M1MAX+M2MAX, $ P1MAX = 20, P2MAX = 20, PMAX = P1MAX+P2MAX ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = PMAX, LDC1 = P1MAX, LDC2 = P1MAX, $ LDD = PMAX, LDD1 = P1MAX, LDD2 = P1MAX ) DOUBLE PRECISION ONE PARAMETER ( ONE=1.0D0 ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M, M1, M2, N, N1, N2, P, P1, P2 * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,MMAX), B1(LDB1,M1MAX), B2(LDB2,M2MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,MMAX), D1(LDD1,M1MAX), D2(LDD2,M2MAX) * .. External Subroutines .. EXTERNAL AB05QD * .. Executable Statements .. * OVER = 'N' WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2, M2, P2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99990 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) IF ( M2.LE.0 .OR. M2.GT.M2MAX ) THEN WRITE ( NOUT, FMT = 99988 ) M2 ELSE READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,M2 ) IF ( P2.LE.0 .OR. P2.GT.P2MAX ) THEN WRITE ( NOUT, FMT = 99987 ) P2 ELSE READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P2 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,M2 ), I = 1,P2 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05QD = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) 99988 FORMAT (/' M2 is out of range.',/' M2 = ',I5) 99987 FORMAT (/' P2 is out of range.',/' P2 = ',I5) END slicot-5.0+20101122/examples/TAB05RD.f000077500000000000000000000132251201767322700165420ustar00rootroot00000000000000* AB05RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, MVMAX, PMAX, PZMAX PARAMETER ( NMAX = 20, MMAX = 20, MVMAX = 20, $ PMAX = 20, PZMAX = 20 ) INTEGER LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, LDF, LDG, $ LDH, LDK, LDWORK, LIWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDBC = NMAX, $ LDC = PMAX, LDCC = PZMAX, $ LDD = PMAX, LDDC = PZMAX, LDF = MMAX, $ LDG = MMAX, LDH = PZMAX, LDK = MMAX, $ LDWORK = MAX( MMAX, PMAX*MVMAX, $ PMAX*PMAX + 4*PMAX ), LIWORK = 2*PMAX ) * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. Local Scalars .. LOGICAL LJOBD, OUTPF CHARACTER*1 FBTYPE, JOBD INTEGER I, INFO, J, M, MV, N, P, PZ DOUBLE PRECISION ALPHA, BETA, RCOND * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), BC(LDBC,MVMAX), $ C(LDC,NMAX), CC(LDCC,NMAX), $ D(LDD,MMAX), DC(LDDC,MVMAX), DWORK(LDWORK), $ F(LDF,PMAX), G(LDG,MVMAX), H(LDH,PMAX), $ K(LDK,NMAX) * .. External functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB05RD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, MV, PZ, ALPHA, BETA, FBTYPE, JOBD OUTPF = LSAME( FBTYPE, 'O' ) LJOBD = LSAME( JOBD, 'D' ) IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( BETA.NE.ZERO ) $ READ ( NIN, FMT = * ) ( ( K(I,J), J = 1,N ), I = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LJOBD ) $ READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF ( OUTPF.AND.ALPHA.NE.ZERO ) $ READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,P ), I = 1,M ) IF ( MV.LE.0 .OR. MV.GT.MVMAX ) THEN WRITE ( NOUT, FMT = 99989 ) MV ELSE READ ( NIN, FMT = * ) $ ( ( G(I,J), J = 1,MV ), I = 1,M ) IF ( PZ.LE.0 .OR. PZ.GT.PZMAX ) THEN WRITE ( NOUT, FMT = 99988 ) PZ ELSE READ ( NIN, FMT = * ) $ ( ( H(I,J), J = 1,P ), I = 1,PZ ) * Find the state-space model (A,B,C,D). CALL 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 ) * WRITE ( NOUT, FMT = 99987 ) RCOND IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( BC(I,J), J = 1,MV ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, PZ WRITE ( NOUT, FMT = 99996 ) $ ( CC(I,J), J = 1,N ) 60 CONTINUE IF ( LJOBD ) THEN WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, PZ WRITE ( NOUT, FMT = 99996 ) $ ( DC(I,J), J = 1,MV ) 80 CONTINUE END IF END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05RD = ',I2) 99997 FORMAT (' The state transition matrix of the closed-loop system is $') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the closed-loop system is ') 99994 FORMAT (/' The state/output matrix of the closed-loop system is ') 99993 FORMAT (/' The input/output matrix of the closed-loop system is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) 99989 FORMAT (/' MV is out of range.',/' MV = ',I5) 99988 FORMAT (/' PZ is out of range.',/' PZ = ',I5) 99987 FORMAT ( ' The reciprocal condition number of the matrix ', $ ' I - alpha*D*F is',F8.4,/1X) END slicot-5.0+20101122/examples/TAB07MD.f000077500000000000000000000064311201767322700165400ustar00rootroot00000000000000* AB07MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP ) * .. Local Scalars .. CHARACTER*1 JOBD INTEGER I, INFO, J, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP) * .. External functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB07MD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBD IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the dual of the ssr (A,B,C,D). CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, $ LDD, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,P ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE IF ( LSAME( JOBD, 'D' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,P ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB07MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB07MD = ',I2) 99997 FORMAT (' The dual state dynamics matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The dual input/state matrix is ') 99994 FORMAT (/' The dual state/output matrix is ') 99993 FORMAT (/' The dual direct transmission matrix is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TAB07ND.f000077500000000000000000000056211201767322700165410ustar00rootroot00000000000000* AB07ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MMAX, $ LDD = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 4*MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N DOUBLE PRECISION RCOND * .. Local Arrays .. INTEGER IWORK(2*MMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB07ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,M ) * Find the inverse of the ssr (A,B,C,D). CALL AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND, $ IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' AB07ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB07ND = ',I2) 99997 FORMAT (' The state dynamics matrix of the inverse system is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the inverse system is ') 99994 FORMAT (/' The state/output matrix of the inverse system is ') 99993 FORMAT (/' The feedthrough matrix of the inverse system is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TAB08ND.f000077500000000000000000000215111201767322700165360ustar00rootroot00000000000000* AB08ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER MPMAX PARAMETER ( MPMAX = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDAF, LDBF, LDQ, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDAF = NMAX+MPMAX, $ LDBF = NMAX+PMAX, LDQ = 1, LDZ = 1 ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( MAX( MPMAX+1, NMAX ) + $ MAX( 3*(MPMAX+1), NMAX+MPMAX ), $ 8*NMAX ) ) * PARAMETER ( LDWORK = 10*NMAX + 5*MPMAX + 4 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, II, J, M, N, NINFZ, NKROL, NKROR, $ NU, P, RANK CHARACTER*1 EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AF(LDAF,NMAX+PMAX), ALFI(NMAX), $ ALFR(NMAX), B(LDB,MMAX), BETA(NMAX), $ BF(LDBF,MMAX+NMAX), C(LDC,NMAX), D(LDD,MMAX), $ DWORK(LDWORK), Q(LDQ,1), Z(LDZ,1) INTEGER INFZ(NMAX), IWORK(MPMAX+1), KRONL(NMAX+1), $ KRONR(NMAX+1), LINFZ(NMAX) * .. External Subroutines .. EXTERNAL AB08ND, DGEGV * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AB08ND( EQUIL, N, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99993 ) ELSE WRITE ( NOUT, FMT = 99992 ) N - NU WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 20 CONTINUE END IF END IF * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AB08ND( EQUIL, N, M, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99987 ) ELSE WRITE ( NOUT, FMT = 99986 ) N - NU WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 40 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 40 CONTINUE END IF END IF * Compute the structural invariants of the given system. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99984 ) NU IF ( NU.GT.0 ) THEN * Compute the invariant zeros of the given system. * Workspace: need 8*NU. WRITE ( NOUT, FMT = 99983 ) CALL DGEGV( 'No vectors', 'No vectors', NU, AF, $ LDAF, BF, LDBF, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 60 I = 1, NU IF ( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 60 CONTINUE WRITE ( NOUT, FMT = 99982 ) END IF END IF NINFZ = 0 II = 1 DO 100 I = 1, N IF ( INFZ(I).GT.0 ) THEN NINFZ = NINFZ + INFZ(I) DO 80 J = 1, INFZ(I) LINFZ(II) = I II = II + 1 80 CONTINUE END IF 100 CONTINUE WRITE ( NOUT, FMT = 99978 ) NINFZ IF ( NINFZ.GT.0 ) $ WRITE ( NOUT, FMT = 99977 ) $ ( LINFZ(I), I = 1,NINFZ ) WRITE ( NOUT, FMT = 99976 ) NKROR IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AB08ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB08ND = ',I2) 99997 FORMAT (' INFO on exit from DGEGV = ',I2) 99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X))) 99993 FORMAT (/' The system (A,C) is completely observable ') 99992 FORMAT (/' The dimension of the observable subspace = ',I3) 99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th', $ 'e matrix AF. ') 99990 FORMAT (/' The matrix AF is ') 99989 FORMAT (20(1X,F8.4)) 99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X) $ )) 99987 FORMAT (/' The system (A,B) is completely controllable ') 99986 FORMAT (/' The dimension of the controllable subspace = ',I3) 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' matrix AF. ') 99984 FORMAT (//' The number of finite invariant zeros = ',I3) 99983 FORMAT (/' The finite invariant zeros are ') 99982 FORMAT (/' which correspond to the generalized eigenvalues of (l', $ 'ambda*BF - AF).') 99981 FORMAT (/' real part imag part ') 99980 FORMAT (1X,F9.4) 99979 FORMAT (1X,F9.4,6X,F9.4) 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT (/' The orders of the infinite zeros are ',/(20(I3,2X))) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TAB08NZ.f000077500000000000000000000214641201767322700165730ustar00rootroot00000000000000* AB08NZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER MPMAX PARAMETER ( MPMAX = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDAF, LDBF, LDQ, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDAF = NMAX+MPMAX, $ LDBF = NMAX+PMAX, LDQ = 1, LDZ = 1 ) INTEGER LDWORK PARAMETER ( LDWORK = 8*NMAX ) INTEGER LZWORK PARAMETER ( LZWORK = $ MAX( MIN( PMAX, MMAX ) + $ MAX( 3*MMAX - 1, NMAX ), $ MIN( PMAX, NMAX ) + $ MAX( 3*PMAX, NMAX+PMAX, NMAX+MMAX ), $ MIN( MMAX, NMAX ) + $ MAX( 3*MMAX, NMAX+MMAX ), 1 ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, II, J, M, N, NINFZ, NKROL, NKROR, $ NU, P, RANK CHARACTER*1 EQUIL * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), AF(LDAF,NMAX+PMAX), ALPHA(NMAX), $ B(LDB,MMAX), BETA(NMAX), BF(LDBF,MMAX+NMAX), $ C(LDC,NMAX), D(LDD,MMAX), Q(LDQ,1), Z(LDZ,1), $ ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK) INTEGER INFZ(NMAX), IWORK(MPMAX+1), KRONL(NMAX+1), $ KRONR(NMAX+1), LINFZ(NMAX) * .. External Subroutines .. EXTERNAL AB08NZ, ZGEGV * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AB08NZ( EQUIL, N, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99993 ) ELSE WRITE ( NOUT, FMT = 99992 ) N - NU WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 20 CONTINUE END IF END IF * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AB08NZ( EQUIL, N, M, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99987 ) ELSE WRITE ( NOUT, FMT = 99986 ) N - NU WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 40 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 40 CONTINUE END IF END IF * Compute the structural invariants of the given system. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99984 ) NU IF ( NU.GT.0 ) THEN * Compute the invariant zeros of the given system. * Complex Workspace: need 2*NU. * Real Workspace: need 8*NU. WRITE ( NOUT, FMT = 99983 ) CALL ZGEGV( 'No vectors', 'No vectors', NU, AF, $ LDAF, BF, LDBF, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 60 I = 1, NU WRITE ( NOUT, FMT = 99980 ) ALPHA(I)/BETA(I) 60 CONTINUE WRITE ( NOUT, FMT = 99982 ) END IF END IF NINFZ = 0 II = 1 DO 100 I = 1, N IF ( INFZ(I).GT.0 ) THEN NINFZ = NINFZ + INFZ(I) DO 80 J = 1, INFZ(I) LINFZ(II) = I II = II + 1 80 CONTINUE END IF 100 CONTINUE WRITE ( NOUT, FMT = 99978 ) NINFZ IF ( NINFZ.GT.0 ) $ WRITE ( NOUT, FMT = 99977 ) $ ( LINFZ(I), I = 1,NINFZ ) WRITE ( NOUT, FMT = 99976 ) NKROR IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AB08NZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB08NZ = ',I2) 99997 FORMAT (' INFO on exit from ZGEGV = ',I2) 99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X))) 99993 FORMAT (/' The system (A,C) is completely observable ') 99992 FORMAT (/' The dimension of the observable subspace = ',I3) 99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th', $ 'e matrix AF. ') 99990 FORMAT (/' The matrix AF is ') 99989 FORMAT (20(1X,F9.4,SP,F9.4,S,'i ')) 99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X) $ )) 99987 FORMAT (/' The system (A,B) is completely controllable ') 99986 FORMAT (/' The dimension of the controllable subspace = ',I3) 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' matrix AF. ') 99984 FORMAT (//' The number of finite invariant zeros = ',I3) 99983 FORMAT (/' The finite invariant zeros are ') 99982 FORMAT (/' which correspond to the generalized eigenvalues of (l', $ 'ambda*BF - AF).') 99981 FORMAT (/' real part imag part ') 99980 FORMAT (1X,F9.4,SP,F9.4,S,'i ') 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT (/' The orders of the infinite zeros are ',/(20(I3,2X))) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TAB09AD.f000077500000000000000000000067041201767322700165310ustar00rootroot00000000000000* AB09AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + 5 + $ MAX( NMAX, MMAX, PMAX ) ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NR, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, TOL, DICO, JOB, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, $ A, LDA, B, LDB, C, LDC, HSV, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09AD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values HSV are') END slicot-5.0+20101122/examples/TAB09BD.f000077500000000000000000000076131201767322700165320ustar00rootroot00000000000000* AB09BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + 5 + $ MAX( NMAX, MMAX, PMAX ) ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09BD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, TOL1, TOL2, DICO, JOB, EQUIL, $ ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09BD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values are') END slicot-5.0+20101122/examples/TAB09CD.f000077500000000000000000000101631201767322700165250ustar00rootroot00000000000000* AB09CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( NMAX, MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*( 2*NMAX + $ MAX( NMAX, MMAX, PMAX ) + 5 ) + $ ( NMAX*( NMAX + 1 ) )/2, $ NMAX*( MMAX + PMAX + 2 ) + $ 2*MMAX*PMAX + $ MIN( NMAX, MMAX ) + MAX( 3*MMAX + 1, $ MIN( NMAX, MMAX ) + PMAX ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, P CHARACTER*1 DICO, EQUIL, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09CD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, TOL1, TOL2, DICO, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, $ A, LDA, B, LDB, C, LDC, D, LDD, HSV, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09CD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values are') END slicot-5.0+20101122/examples/TAB09DD.f000077500000000000000000000066211201767322700165320ustar00rootroot00000000000000* AB09DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX ) * .. Local Scalars .. DOUBLE PRECISION RCOND INTEGER I, INFO, J, M, N, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09DD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, $ D, LDD, RCOND, IWORK, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RCOND IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09DD = ',I2) 99997 FORMAT (' The computed reciprocal condition number = ',1PD12.5) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TAB09ED.f000077500000000000000000000104571201767322700165350ustar00rootroot00000000000000* AB09ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( NMAX, MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*( 2*NMAX + $ MAX( NMAX, MMAX, PMAX ) + $ 5 ) + ( NMAX*( NMAX + 1 ) )/2, $ NMAX*( MMAX + PMAX + 2 ) + $ 2*MMAX*PMAX + MIN( NMAX, MMAX ) + $ MAX( 3*MMAX + 1, $ MIN( NMAX, MMAX ) + $ PMAX ) ) ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09ED * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, $ DICO, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09ED = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are') END slicot-5.0+20101122/examples/TAB09FD.f000077500000000000000000000071621201767322700165350ustar00rootroot00000000000000* AB09FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( NMAX, MMAX, PMAX ) ) * The formula below uses that NMAX = MMAX = PMAX. INTEGER LDWORK PARAMETER ( LDWORK = 10*NMAX*NMAX + 5*NMAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09FD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, $ DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) * Find a reduced ssr for (A,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NQ ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09FD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of coprime factors are') END slicot-5.0+20101122/examples/TAB09GD.f000077500000000000000000000077711201767322700165440ustar00rootroot00000000000000* AB09GD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*NMAX, MMAX, PMAX ) ) * The formula below uses that NMAX = MMAX = PMAX. INTEGER LDWORK PARAMETER ( LDWORK = 10*NMAX*NMAX + 5*NMAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3 INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09GD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, TOL3, $ DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NQ ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09GD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09GD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of coprime factors are') END slicot-5.0+20101122/examples/TAB09HD.f000077500000000000000000000103411201767322700165300ustar00rootroot00000000000000* AB09HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LBWORK, LIWORK PARAMETER ( LBWORK = 2*NMAX, LIWORK = 2*NMAX ) INTEGER LDWORK, MBMAX PARAMETER ( MBMAX = MMAX + PMAX ) PARAMETER ( LDWORK = 2*NMAX*NMAX + MBMAX*(NMAX+PMAX) + $ MAX( NMAX*(MAX( NMAX, MMAX, PMAX) + 5), $ 2*NMAX*PMAX + MAX( PMAX*(MBMAX+2), $ 10*NMAX*(NMAX+1) ) ) ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) LOGICAL BWORK(LBWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09HD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, BETA, TOL1, TOL2, $ DICO, JOB, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09HD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The stochastic Hankel singular values of ALPHA-stable' $ ,' part are') END slicot-5.0+20101122/examples/TAB09ID.f000077500000000000000000000223041201767322700165330ustar00rootroot00000000000000* AB09ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, MWMAX, NMAX, NVMAX, NWMAX, PMAX, PVMAX PARAMETER ( MMAX = 20, MWMAX = 20, $ NMAX = 20, NVMAX = 20, NWMAX = 20, $ PMAX = 20, PVMAX = 20 ) INTEGER LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW PARAMETER ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX, $ LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX, $ LDC = PMAX, LDCV = PVMAX, LDCW = MMAX, $ LDD = PMAX, LDDV = PVMAX, LDDW = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*NMAX, $ NVMAX + MAX( PMAX, PVMAX ), $ NWMAX + MAX( MMAX, MWMAX ) ) ) INTEGER LDW1, LDW2, LDW3, LDW4, LDW5, LDW6, LDW7, LDW8, $ LDWORK PARAMETER ( LDW1 = NMAX + NVMAX, LDW2 = NMAX + NWMAX, $ LDW3 = MAX( LDW1*( LDW1 + MAX( LDW1, PVMAX ) + $ 5 ), NMAX*( PMAX + 5 ) ), $ LDW4 = MAX( LDW2*( LDW2 + MAX( LDW2, MWMAX ) + $ 5 ), NMAX*( MMAX + 5 ) ), $ LDW5 = PVMAX*( NVMAX + PVMAX ) + PVMAX*NVMAX + $ MAX( NVMAX*( NVMAX + 5 ), 4*PVMAX, $ PVMAX*( PVMAX + 2 ), 4*PMAX ), $ LDW6 = MAX( PMAX, PVMAX )*( 2*NVMAX + $ MAX( PMAX, PVMAX ) ) + $ MAX( LDW5, NVMAX + $ MAX( NVMAX, 3*PMAX, 3*PVMAX ) $ ), $ LDW7 = MAX( NWMAX + MAX( NWMAX, 3*MMAX ), $ 2*NWMAX*MAX( MMAX, MWMAX ) + $ NWMAX + MAX( NWMAX, 3*MMAX, $ 3*MWMAX ) ), $ LDW8 = MWMAX*( NWMAX + MWMAX ) + $ MAX( NWMAX*( NWMAX + 5 ), 4*MWMAX, $ MWMAX*( MWMAX + 2 ), 4*MMAX ) ) PARAMETER ( LDWORK = MAX( LDW6, LDW7, LDW8, $ 2*NMAX*NMAX + $ MAX( 1, LDW3, LDW4, $ 2*NMAX*NMAX + 5*NMAX, $ NMAX*MAX( MMAX, PMAX ) ) ) $ ) * .. Local Scalars .. LOGICAL LEFTW, RIGHTW DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, MW, N, NR, NS, NV, NW, P, $ PV CHARACTER*1 DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX), $ B(LDB,MMAX), BV(LDBV,PMAX), BW(LDBW,MWMAX), $ C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX), $ D(LDD,MMAX), DV(LDDV,PMAX), DW(LDDW,MWMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB09ID * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NV, PV, NW, MW, NR, $ ALPHA, ALPHAC, ALPHAO, TOL1, TOL2, $ DICO, JOBC, JOBO, JOB, WEIGHT, $ EQUIL, ORDSEL LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( LEFTW ) THEN IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NV ELSE IF( NV.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AV(I,J), J = 1,NV ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( BV(I,J), J = 1,P ), I = 1,NV ) IF( PV.LE.0 .OR. PV.GT.PVMAX ) THEN WRITE ( NOUT, FMT = 99985 ) PV ELSE READ ( NIN, FMT = * ) $ ( ( CV(I,J), J = 1,NV ), I = 1,PV ) END IF END IF IF( PV.LE.0 .OR. PV.GT.PVMAX ) THEN WRITE ( NOUT, FMT = 99985 ) PV ELSE READ ( NIN, FMT = * ) $ ( ( DV(I,J), J = 1,P ), I = 1,PV ) END IF END IF END IF IF( RIGHTW ) THEN IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN WRITE ( NOUT, FMT = 99984 ) NW ELSE IF( NW.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AW(I,J), J = 1,NW ), I = 1,NW ) IF( MW.LE.0 .OR. MW.GT.MWMAX ) THEN WRITE ( NOUT, FMT = 99983 ) MW ELSE READ ( NIN, FMT = * ) $ ( ( BW(I,J), J = 1,MW ), I = 1,NW ) END IF READ ( NIN, FMT = * ) $ ( ( CW(I,J), J = 1,NW ), I = 1,M ) END IF IF( MW.LE.0 .OR. MW.GT.MWMAX ) THEN WRITE ( NOUT, FMT = 99983 ) MW ELSE READ ( NIN, FMT = * ) $ ( ( DW(I,J), J = 1,MW ), I = 1,M ) END IF END IF END IF * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99982 ) IWARN WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09ID = ',I2) 99997 FORMAT (/' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NV is out of range.',/' NV = ',I5) 99985 FORMAT (/' PV is out of range.',/' PV = ',I5) 99984 FORMAT (/' NW is out of range.',/' NW = ',I5) 99983 FORMAT (/' MW is out of range.',/' MW = ',I5) 99982 FORMAT (' IWARN on exit from AB09ID = ',I2) END slicot-5.0+20101122/examples/TAB09JD.f000077500000000000000000000177321201767322700165450ustar00rootroot00000000000000* AB09JD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, NVMAX, NVPMAX, NWMAX, NWMMAX, PMAX PARAMETER ( MMAX = 20, NMAX = 20, NVMAX = 10, NWMAX = 10, $ PMAX = 20, NVPMAX = NVMAX + PMAX, $ NWMMAX = NWMAX + MMAX ) INTEGER LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW PARAMETER ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX, $ LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX, $ LDC = PMAX, LDCV = PMAX, LDCW = MMAX, $ LDD = PMAX, LDDV = PMAX, LDDW = MMAX ) INTEGER LIW1, LIW2, LIW3, LIWORK PARAMETER ( LIW1 = 2*MAX( MMAX, PMAX ), $ LIW2 = MAX( NVPMAX, NWMMAX ) + NMAX + 6, $ LIW3 = MAX( 2*NVMAX + PMAX + 2, $ 2*NWMAX + MMAX + 2 ) ) PARAMETER ( LIWORK = MAX( LIW1, LIW2, LIW3 ) ) INTEGER LDW1, LDW2, LDW3, LDW4, LDWORK PARAMETER ( LDW1 = 2*NVPMAX*( NVPMAX + PMAX ) + PMAX*PMAX + $ MAX( 2*NVPMAX*NVPMAX + $ MAX( 11*NVPMAX + 16, PMAX*NVPMAX ), $ NVPMAX*NMAX + $ MAX( NVPMAX*NMAX + NMAX*NMAX, $ PMAX*NMAX, PMAX*MMAX ) ) ) PARAMETER ( LDW2 = 2*NWMMAX*( NWMMAX + MMAX ) + MMAX*MMAX + $ MAX( 2*NWMMAX*NWMMAX + $ MAX( 11*NWMMAX + 16, MMAX*NWMMAX ), $ NWMMAX*NMAX + $ MAX( NWMMAX*NMAX + NMAX*NMAX, $ MMAX*NMAX, PMAX*MMAX ) ) ) PARAMETER ( LDW3 = NMAX*( 2*NMAX + MAX( NMAX, MMAX, PMAX ) $ + 5 ) + ( NMAX*( NMAX + 1 ) )/2 ) PARAMETER ( LDW4 = NMAX*( MMAX + PMAX + 2 ) + 2*MMAX*PMAX + $ MIN( NMAX, MMAX ) + $ MAX( 3*MMAX + 1, $ MIN( NMAX, MMAX ) + PMAX ) ) PARAMETER ( LDWORK = MAX( LDW1, LDW2, LDW3, LDW4 ) ) * .. Local Scalars .. LOGICAL LEFTW, RIGHTW DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, NV, NW, P CHARACTER*1 DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX), $ B(LDB,MMAX), BV(LDBV,PMAX), BW(LDBW,MMAX), $ C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX), $ D(LDD,MMAX), DV(LDDV,PMAX), DW(LDDW,MMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB09JD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NV, NW, NR, ALPHA, TOL1, TOL2, $ JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL LEFTW = .NOT.LSAME( JOBV, 'N' ) RIGHTW = .NOT.LSAME( JOBW, 'N' ) IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( LEFTW ) THEN IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NV ELSE IF( NV.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AV(I,J), J = 1,NV ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( BV(I,J), J = 1,P ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( CV(I,J), J = 1,NV ), I = 1,P ) END IF IF( LEFTW ) $ READ ( NIN, FMT = * ) $ ( ( DV(I,J), J = 1,P ), I = 1,P ) END IF END IF IF( RIGHTW ) THEN IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN WRITE ( NOUT, FMT = 99985 ) NW ELSE IF( NW.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AW(I,J), J = 1,NW ), I = 1,NW ) READ ( NIN, FMT = * ) $ ( ( BW(I,J), J = 1,M ), I = 1,NW ) READ ( NIN, FMT = * ) $ ( ( CW(I,J), J = 1,NW ), I = 1,M ) END IF READ ( NIN, FMT = * ) $ ( ( DW(I,J), J = 1,M ), I = 1,M ) END IF END IF * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99994 ) IWARN WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09JD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09JD = ',I2) 99997 FORMAT (/' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' IWARN on exit from AB09JD = ',I2) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NV is out of range.',/' NV = ',I5) 99985 FORMAT (/' NW is out of range.',/' NW = ',I5) END slicot-5.0+20101122/examples/TAB09KD.f000077500000000000000000000161301201767322700165350ustar00rootroot00000000000000* AB09KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, NVMAX, NWMAX, PMAX PARAMETER ( MMAX = 20, NMAX = 20, NVMAX = 10, NWMAX = 10, $ PMAX = 20 ) INTEGER LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW PARAMETER ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX, $ LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX, $ LDC = PMAX, LDCV = PMAX, LDCW = MMAX, $ LDD = PMAX, LDDV = PMAX, LDDW = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAX( MMAX, PMAX ) ) INTEGER LDW1, LDW2, LDW3, LDW4, LDWORK PARAMETER ( LDW1 = MAX( NVMAX*( NVMAX + 5 ), NVMAX*NMAX + $ MAX( 2*NVMAX, PMAX*NMAX, PMAX*MMAX ) )) PARAMETER ( LDW2 = MAX( NWMAX*( NWMAX + 5 ), NWMAX*NMAX + $ MAX( 2*NWMAX, MMAX*NMAX, PMAX*MMAX ) )) PARAMETER ( LDW3 = NMAX*( 2*NMAX + MAX( NMAX, MMAX, PMAX ) $ + 5 ) + ( NMAX*( NMAX + 1 ) )/2 ) PARAMETER ( LDW4 = NMAX*( MMAX + PMAX + 2 ) + 2*MMAX*PMAX + $ MIN( NMAX, MMAX ) + $ MAX( 3*MMAX + 1, $ MIN( NMAX, MMAX ) + PMAX ) ) PARAMETER ( LDWORK = MAX( LDW1, LDW2, LDW3, LDW4 ) ) * .. Local Scalars .. LOGICAL LEFTW, RIGHTW DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, NV, NW, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL, WEIGHT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX), $ B(LDB,MMAX), BV(LDBV,PMAX), BW(LDBW,MMAX), $ C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX), $ D(LDD,MMAX), DV(LDDV,PMAX), DW(LDDW,MMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB09KD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NV, NW, NR, ALPHA, TOL1, TOL2, $ JOB, DICO, WEIGHT, EQUIL, ORDSEL LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF( P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( LEFTW .OR. NV.GT.0 ) THEN IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NV ELSE IF( NV.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AV(I,J), J = 1,NV ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( BV(I,J), J = 1,P ), I = 1, NV ) READ ( NIN, FMT = * ) $ ( ( CV(I,J), J = 1,NV ), I = 1,P ) END IF IF( LEFTW ) READ ( NIN, FMT = * ) $ ( ( DV(I,J), J = 1,P ), I = 1,P ) END IF END IF IF( RIGHTW ) THEN IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN WRITE ( NOUT, FMT = 99985 ) NW ELSE IF( NW.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AW(I,J), J = 1,NW ), I = 1,NW ) READ ( NIN, FMT = * ) $ ( ( BW(I,J), J = 1,M ), I = 1, NW ) READ ( NIN, FMT = * ) $ ( ( CW(I,J), J = 1,NW ), I = 1,M ) END IF READ ( NIN, FMT = * ) $ ( ( DW(I,J), J = 1,M ), I = 1,M ) END IF END IF * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99984 ) IWARN WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09KD = ',I2) 99997 FORMAT (/' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NV is out of range.',/' NV = ',I5) 99985 FORMAT (/' NW is out of range.',/' NW = ',I5) 99984 FORMAT (' IWARN on exit from AB09KD = ',I2) END slicot-5.0+20101122/examples/TAB09MD.f000077500000000000000000000070201201767322700165350ustar00rootroot00000000000000* AB09MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + $ MAX( NMAX, MMAX, PMAX ) + 5 ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09MD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL, DICO, JOB, EQUIL, $ ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, $ ALPHA, A, LDA, B, LDB, C, LDC, NS, HSV, $ TOL, IWORK, DWORK, LDWORK, IWARN, INFO) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09MD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are') END slicot-5.0+20101122/examples/TAB09ND.f000077500000000000000000000077341201767322700165520ustar00rootroot00000000000000* AB09ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + $ MAX( NMAX, MMAX, PMAX ) + 5 ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09ND * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, $ DICO, JOB, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09ND = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are') END slicot-5.0+20101122/examples/TAB13AD.f000077500000000000000000000052711201767322700165220ustar00rootroot00000000000000* AB13AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( MAX( NMAX, MMAX, PMAX ) + 5 ) $ + ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, SHNORM INTEGER I, INFO, J, M, N, NS, P CHARACTER*1 DICO, EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) * .. External Functions .. DOUBLE PRECISION AB13AD EXTERNAL AB13AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Compute the Hankel-norm of the ALPHA-stable projection of * (A,B,C). SHNORM = AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, LDA, B, $ LDB, C, LDC, NS, HSV, DWORK, LDWORK, $ INFO) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) SHNORM WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) END IF END IF END IF END IF STOP * 99999 FORMAT (' AB13AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB13AD = ',I2) 99997 FORMAT (' The Hankel-norm of the ALPHA-projection = ',1PD14.5) 99995 FORMAT (20(1X,F8.4)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-projection are') END slicot-5.0+20101122/examples/TAB13BD.f000077500000000000000000000057641201767322700165320ustar00rootroot00000000000000* AB13BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( MMAX*( NMAX + MMAX ) + $ MAX( NMAX*( NMAX + 5 ), $ MMAX*( MMAX + 2 ), 4*PMAX ), $ NMAX*( MAX( NMAX, PMAX ) + 4 ) + $ MIN( NMAX, PMAX ) ) ) * .. Local Scalars .. DOUBLE PRECISION S2NORM, TOL INTEGER I, INFO, IWARN, J, M, N, NQ, P CHARACTER*1 DICO, JOBN * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION AB13BD EXTERNAL AB13BD, LSAME * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Compute the H2 or L2 norm of (A,B,C,D). S2NORM = AB13BD( DICO, JOBN, N, M, P, A, LDA, B, LDB, * C, LDC, D, LDD, NQ, TOL, DWORK, LDWORK, * IWARN, INFO) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( LSAME( JOBN, 'H' ) ) THEN WRITE ( NOUT, FMT = 99997 ) S2NORM ELSE WRITE ( NOUT, FMT = 99996 ) S2NORM END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB13BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB13BD = ',I2) 99997 FORMAT (' The H2-norm of the system = ',1PD14.5) 99996 FORMAT (' The L2-norm of the system = ',1PD14.5) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TAB13CD.f000077500000000000000000000061021201767322700165160ustar00rootroot00000000000000* AB13CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LCWORK PARAMETER ( LCWORK = ( NMAX + MMAX )*( NMAX + PMAX ) + $ 3*MAX( MMAX, PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX*NMAX + 2*MMAX*MMAX + $ 2*PMAX*PMAX + 3*NMAX*MMAX + $ 2*NMAX*PMAX + MMAX*PMAX + 10*NMAX + $ 6*MAX( MMAX, PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION FPEAK, HNORM, TOL INTEGER I, INFO, J, M, N, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) COMPLEX*16 CWORK( LCWORK ) * .. External Functions .. DOUBLE PRECISION AB13CD EXTERNAL AB13CD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) TOL * Computing the Hinf norm HNORM = AB13CD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, TOL, $ IWORK, DWORK, LDWORK, CWORK, LCWORK, BWORK, $ INFO ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99991 ) HNORM FPEAK = DWORK(2) WRITE ( NOUT, FMT = 99996 ) WRITE ( NOUT, FMT = 99991 ) FPEAK ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from AB13CD =',I2) 99997 FORMAT (/' The H_infty norm of the system is'/) 99996 FORMAT (/' The peak frequency is'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT (D17.10) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples/TAB13DD.f000077500000000000000000000075301201767322700165250ustar00rootroot00000000000000* AB13DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDE PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDE = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LCWORK PARAMETER ( LCWORK = ( NMAX + MMAX )*( NMAX + PMAX ) + $ 2*MIN( PMAX, MMAX ) + $ MAX( PMAX, MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 15*NMAX*NMAX + PMAX*PMAX + MMAX*MMAX + $ ( 6*NMAX + 3 )*( PMAX + MMAX ) + $ 4*PMAX*MMAX + NMAX*MMAX + 22*NMAX + $ 7*MIN( PMAX, MMAX ) ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, P CHARACTER DICO, EQUIL, JOBD, JOBE * .. Local Arrays .. INTEGER IWORK( LIWORK ) DOUBLE PRECISION A( LDA, NMAX ), B( LDB, MMAX ), C( LDC, NMAX ), $ D( LDD, MMAX ), DWORK( LDWORK ), E( LDE, NMAX ), $ FPEAK( 2 ), GPEAK( 2 ) COMPLEX*16 CWORK( LCWORK ) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB13DD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, FPEAK, TOL, DICO, JOBE, EQUIL, JOBD IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOBE, 'G' ) ) $ READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( JOBD, 'D' ) ) $ READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Computing the Linf norm. CALL 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 ) * IF ( INFO.EQ.0 ) THEN IF ( GPEAK( 2 ).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99991 ) ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99995 ) GPEAK( 1 ) END IF IF ( FPEAK( 2 ).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99990 ) ELSE WRITE ( NOUT, FMT = 99996 ) WRITE ( NOUT, FMT = 99995 ) FPEAK( 1 ) END IF ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from AB13DD =',I2) 99997 FORMAT (/' The L_infty norm of the system is'/) 99996 FORMAT (/' The peak frequency is'/) 99995 FORMAT (D17.10) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' The L_infty norm of the system is infinite') 99990 FORMAT (/' The peak frequency is infinite'/) END slicot-5.0+20101122/examples/TAB13ED.f000077500000000000000000000032471201767322700165270ustar00rootroot00000000000000* AB13ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX*( NMAX + 1 ) ) * .. Local Scalars .. INTEGER I, INFO, J, N DOUBLE PRECISION HIGH, LOW, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB13ED, UD01MD * .. * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) * Read N, TOL and next A (row wise). READ ( NIN, FMT = * ) N, TOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE DO 10 I = 1, N READ ( NIN, FMT = * ) ( A(I,J), J = 1, N ) 10 CONTINUE * WRITE ( NOUT, FMT = 99998 ) N, TOL CALL UD01MD( N, N, 5, NOUT, A, LDA, 'Matrix A', INFO ) * CALL AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, INFO ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) LOW, HIGH ELSE WRITE ( NOUT, FMT = 99996 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13ED EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' N =', I4, 2X, 'TOL =', D10.3) 99997 FORMAT (' LOW =', D18.11, /' HIGH =', D18.11) 99996 FORMAT (' INFO on exit from AB13ED = ', I2) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TAB13FD.f000077500000000000000000000034741201767322700165320ustar00rootroot00000000000000* AB13FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX*( NMAX + 2 ) ) INTEGER LCWORK PARAMETER ( LCWORK = NMAX*( NMAX + 3 ) ) * .. Local Scalars .. INTEGER I, INFO, J, N DOUBLE PRECISION BETA, OMEGA, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK) COMPLEX*16 CWORK(LCWORK) * .. External Subroutines .. EXTERNAL AB13FD, UD01MD * .. * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) * Read N, TOL and next A (row wise). READ ( NIN, FMT = * ) N, TOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE DO 10 I = 1, N READ ( NIN, FMT = * ) ( A(I,J), J = 1, N ) 10 CONTINUE * WRITE ( NOUT, FMT = 99998 ) N, TOL CALL UD01MD( N, N, 5, NOUT, A, LDA, 'A', INFO ) * CALL AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, CWORK, $ LCWORK, INFO ) * IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99996 ) INFO WRITE ( NOUT, FMT = 99997 ) BETA, OMEGA END IF * 99999 FORMAT (' AB13FD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' N =', I2, 3X, 'TOL =', D10.3) 99997 FORMAT (' Stability radius :', D18.11, / * ' Minimizing omega :', D18.11) 99996 FORMAT (' INFO on exit from AB13FD = ', I2) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TAB13MD.f000077500000000000000000000045701201767322700165370ustar00rootroot00000000000000* AB13MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDZ PARAMETER ( LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 4*MMAX-2, NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NMAX*NMAX*MMAX - NMAX*NMAX + $ 9*MMAX*MMAX + NMAX*MMAX + 11*NMAX + $ 33*MMAX - 11 ) INTEGER LZWORK PARAMETER ( LZWORK = 6*NMAX*NMAX*MMAX + 12*NMAX*NMAX + $ 6*MMAX + 6*NMAX - 3 ) * .. Local Scalars .. INTEGER I, INFO, J, M, N DOUBLE PRECISION BOUND * .. Local Arrays .. INTEGER ITYPE(MMAX), IWORK(LIWORK), NBLOCK(MMAX) DOUBLE PRECISION D(NMAX), DWORK(LDWORK), G(NMAX), X(2*MMAX-1) COMPLEX*16 Z(LDZ,NMAX), ZWORK(LZWORK) * .. External Subroutines .. EXTERNAL AB13MD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( NBLOCK(I), I = 1, M ) READ ( NIN, FMT = * ) ( ITYPE(I), I = 1, M ) READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N ) * Computing mu. CALL AB13MD( 'N', N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, G, $ IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99991 ) BOUND ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB13MD =',I2) 99997 FORMAT (' The value of the structured singular value is'/) 99991 FORMAT (D17.10) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TAG08BD.f000077500000000000000000000413721201767322700165360ustar00rootroot00000000000000* AG08BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, MMAX, NMAX, PMAX PARAMETER ( LMAX = 20, MMAX = 20, NMAX = 20, PMAX = 20 ) INTEGER LDA, LDAEMX, LDB, LDC, LDD, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDD = PMAX, LDE = LMAX, LDQ = 1, LDZ = 1, $ LDAEMX = MAX( PMAX + LMAX, NMAX + MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 4*( LMAX + NMAX ), 8*NMAX, $ LDAEMX*LDAEMX + $ MAX( 1, 5*LDAEMX ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, J, L, M, N, NFZ, NINFE, NIZ, $ NKROL, NKROR, NRANK, P CHARACTER*1 EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFI(NMAX), ALFR(NMAX), $ ASAVE(LDA,NMAX), B(LDB,MMAX), BETA(NMAX), $ BSAVE(LDB,MMAX), C(LDC,NMAX), CSAVE(LDC,NMAX), $ D(LDD,MMAX), DSAVE(LDD,MMAX), DWORK(LDWORK), $ E(LDE,NMAX), ESAVE(LDE,NMAX), Q(LDQ,1), Z(LDZ,1) INTEGER INFE(1+LMAX+PMAX), INFZ(NMAX+1), $ IWORK(NMAX+MMAX), KRONL(LMAX+PMAX+1), $ KRONR(NMAX+MMAX+1) * .. External Subroutines .. EXTERNAL AG08BD, DGEGV, DLACPY * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL, EQUIL IF( ( L.LT.0 .OR. L.GT.LMAX ) .OR. ( N.LT.0 .OR. N.GT.NMAX ) ) $ THEN WRITE ( NOUT, FMT = 99972 ) L, N ELSE IF( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE IF( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) CALL DLACPY( 'F', L, N, A, LDA, ASAVE, LDA ) CALL DLACPY( 'F', L, N, E, LDE, ESAVE, LDE ) CALL DLACPY( 'F', L, M, B, LDB, BSAVE, LDB ) CALL DLACPY( 'F', P, N, C, LDC, CSAVE, LDC ) CALL DLACPY( 'F', P, M, D, LDD, DSAVE, LDD ) * Compute poles (call the routine with M = 0, P = 0). CALL AG08BD( EQUIL, L, N, 0, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99968 ) NIZ DO 10 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 10 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99958 ) $ ( INFE(I), I = 1,NINFE ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99965 ) ELSE WRITE ( NOUT, FMT = 99966 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 30 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 40 CONTINUE END IF END IF END IF CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AG08BD( EQUIL, L, N, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99964 ) NIZ DO 50 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 50 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99960 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,NKROL ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99993 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99957 ) ELSE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 70 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 70 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 80 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 80 CONTINUE END IF END IF END IF CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL DLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AG08BD( EQUIL, L, N, M, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99963 ) NIZ DO 90 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 90 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99959 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,NKROR ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99987 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99956 ) ELSE WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 100 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 100 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 110 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 110 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99982 ) DO 120 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 120 CONTINUE END IF END IF END IF CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL DLACPY( 'F', L, M, BSAVE, LDB, B, LDB ) CALL DLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) CALL DLACPY( 'F', P, M, DSAVE, LDD, D, LDD ) * Compute the structural invariants of the given system. CALL 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( L.EQ.N ) THEN WRITE ( NOUT, FMT = 99969 ) NRANK - N ELSE WRITE ( NOUT, FMT = 99955 ) NRANK END IF WRITE ( NOUT, FMT = 99984 ) NFZ IF( NFZ.GT.0 ) THEN * Compute the finite zeros of the given system. * Workspace: need 8*NFZ. WRITE ( NOUT, FMT = 99983 ) WRITE ( NOUT, FMT = 99990 ) DO 130 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 130 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 140 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 140 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 150 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 150 CONTINUE END IF END IF WRITE ( NOUT, FMT = 99978 ) NIZ DO 160 I = 1, DINFZ WRITE ( NOUT, FMT = 99977 ) INFZ(I), I 160 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99961 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99976 ) NKROR IF( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AG08BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AG08BD = ',I2) 99997 FORMAT (' INFO on exit from DGEGV = ',I2) 99996 FORMAT (/'Unobservable finite eigenvalues'/ $ ' real part imag part ') 99995 FORMAT (/' The matrix Ef is ') 99994 FORMAT (/' The left Kronecker indices of [A-lambda*E;C] are ', $ /(20(I3,2X))) 99993 FORMAT (/' The system (A-lambda*E,C) is completely observable ') 99991 FORMAT (/' The finite output decoupling zeros are the eigenvalues' $ ,' of the pair (Af,Ef). ') 99990 FORMAT (/' The matrix Af is ') 99989 FORMAT (20(1X,F8.4)) 99988 FORMAT (/' The right Kronecker indices of [A-lambda*E,B] are ', $ /( 20(I3,2X) ) ) 99987 FORMAT (/' The system (A-lambda*E,B) is completely controllable ') 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' pair (Af,Ef). ') 99984 FORMAT (/' The number of finite zeros = ',I3) 99983 FORMAT (/' The finite zeros are the eigenvalues ', $ 'of the pair (Af,Ef)') 99982 FORMAT (/'Uncontrollable finite eigenvalues'/ $ ' real part imag part ') 99981 FORMAT (/'Finite zeros'/' real part imag part ') 99980 FORMAT (1X,F9.4) 99979 FORMAT (1X,F9.4,6X,F9.4) 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT ( I4,' infinite zero(s) of order ',I3) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99972 FORMAT (/' L or N is out of range.',/' L = ', I5, ' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) 99969 FORMAT (/' Normal rank of transfer function matrix = ',I3) 99968 FORMAT (//' The number of infinite poles = ',I3) 99967 FORMAT ( I4,' infinite pole(s) of order ',I3) 99966 FORMAT (/' The finite poles are the eigenvalues', $ ' of the pair (Af,Ef). ') 99965 FORMAT (/' The system has no finite poles ') 99964 FORMAT (//' The number of unobservable infinite poles = ',I3) 99963 FORMAT (//' The number of uncontrollable infinite poles = ',I3) 99962 FORMAT (/' The number of infinite Kronecker blocks = ',I3) 99961 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B;C,D] are ', /(20(I3,2X))) 99960 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E;C] are ', /(20(I3,2X))) 99959 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B] are ', /(20(I3,2X))) 99958 FORMAT (/' Multiplicities of infinite eigenvalues of A-lambda*E' $ ,' are ', /(20(I3,2X))) 99957 FORMAT (/' The system (A-lambda*E,C) has no finite output', $ ' decoupling zeros ') 99956 FORMAT (/' The system (A-lambda*E,B) has no finite input', $ ' decoupling zeros ') 99955 FORMAT (/' Normal rank of system pencil = ',I3) END slicot-5.0+20101122/examples/TAG08BZ.f000077500000000000000000000376221201767322700165670ustar00rootroot00000000000000* AG08BZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, MMAX, NMAX, PMAX PARAMETER ( LMAX = 20, MMAX = 20, NMAX = 20, PMAX = 20 ) INTEGER LDA, LDAEMX, LDB, LDC, LDD, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDD = PMAX, LDE = LMAX, LDQ = 1, LDZ = 1, $ LDAEMX = MAX( PMAX + LMAX, NMAX + MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 4*( LMAX + NMAX ), 2*LDAEMX, $ 8*NMAX ) ) INTEGER LZWORK PARAMETER ( LZWORK = MAX( 1, LDAEMX*LDAEMX + $ MAX( MIN( LMAX+PMAX, MMAX+NMAX )+ $ MAX( MIN( LMAX, NMAX ), $ 3*( MMAX+NMAX )-1 ), $ 3*( LMAX+PMAX ) ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, J, L, M, N, NFZ, NINFE, NIZ, $ NKROL, NKROR, NRANK, P CHARACTER*1 EQUIL * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), ALPHA(NMAX), ASAVE(LDA,NMAX), $ B(LDB,MMAX), BETA(NMAX), BSAVE(LDB,MMAX), $ C(LDC,NMAX), CSAVE(LDC,NMAX), $ D(LDD,MMAX), DSAVE(LDD,MMAX), $ E(LDE,NMAX), ESAVE(LDE,NMAX), Q(LDQ,1), Z(LDZ,1), $ ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK) INTEGER INFE(1+LMAX+PMAX), INFZ(NMAX+1), $ IWORK(NMAX+MMAX), KRONL(LMAX+PMAX+1), $ KRONR(NMAX+MMAX+1) * .. External Subroutines .. EXTERNAL AG08BZ, ZGEGV, ZLACPY * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL, EQUIL IF( ( L.LT.0 .OR. L.GT.LMAX ) .OR. ( N.LT.0 .OR. N.GT.NMAX ) ) $ THEN WRITE ( NOUT, FMT = 99972 ) L, N ELSE IF( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE IF( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) CALL ZLACPY( 'F', L, N, A, LDA, ASAVE, LDA ) CALL ZLACPY( 'F', L, N, E, LDE, ESAVE, LDE ) CALL ZLACPY( 'F', L, M, B, LDB, BSAVE, LDB ) CALL ZLACPY( 'F', P, N, C, LDC, CSAVE, LDC ) CALL ZLACPY( 'F', P, M, D, LDD, DSAVE, LDD ) * Compute poles (call the routine with M = 0, P = 0). CALL AG08BZ( EQUIL, L, N, 0, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99968 ) NIZ DO 10 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 10 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99958 ) $ ( INFE(I), I = 1,NINFE ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99965 ) ELSE WRITE ( NOUT, FMT = 99966 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 30 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 40 CONTINUE END IF END IF END IF CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AG08BZ( EQUIL, L, N, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99964 ) NIZ DO 50 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 50 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99960 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,NKROL ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99993 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99957 ) ELSE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 70 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 70 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 80 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 80 CONTINUE END IF END IF END IF CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL ZLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AG08BZ( EQUIL, L, N, M, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99963 ) NIZ DO 90 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 90 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99959 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,NKROR ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99987 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99956 ) ELSE WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 100 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 100 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 110 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 110 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99982 ) DO 120 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 120 CONTINUE END IF END IF END IF CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL ZLACPY( 'F', L, M, BSAVE, LDB, B, LDB ) CALL ZLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) CALL ZLACPY( 'F', P, M, DSAVE, LDD, D, LDD ) * Compute the structural invariants of the given system. CALL 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( L.EQ.N ) THEN WRITE ( NOUT, FMT = 99969 ) NRANK - N ELSE WRITE ( NOUT, FMT = 99955 ) NRANK END IF WRITE ( NOUT, FMT = 99984 ) NFZ IF( NFZ.GT.0 ) THEN * Compute the finite zeros of the given system. * Workspace: need 8*NFZ. WRITE ( NOUT, FMT = 99983 ) WRITE ( NOUT, FMT = 99990 ) DO 130 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 130 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 140 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 140 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 150 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 150 CONTINUE END IF END IF WRITE ( NOUT, FMT = 99978 ) NIZ DO 160 I = 1, DINFZ WRITE ( NOUT, FMT = 99977 ) INFZ(I), I 160 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99961 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99976 ) NKROR IF( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AG08BZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AG08BZ = ',I2) 99997 FORMAT (' INFO on exit from ZGEGV = ',I2) 99996 FORMAT (/' Unobservable finite eigenvalues'/ $ ' real part imag part ') 99995 FORMAT (/' The matrix Ef is ') 99994 FORMAT (/' The left Kronecker indices of [A-lambda*E;C] are ', $ /(20(I3,2X))) 99993 FORMAT (/' The system (A-lambda*E,C) is completely observable ') 99991 FORMAT (/' The finite output decoupling zeros are the eigenvalues' $ , ' of the pair (Af,Ef). ') 99990 FORMAT (/' The matrix Af is ') 99989 FORMAT (20(1X,F9.4,SP,F9.4,S,'i ')) 99988 FORMAT (/' The right Kronecker indices of [A-lambda*E,B] are ', $ /( 20(I3,2X) ) ) 99987 FORMAT (/' The system (A-lambda*E,B) is completely controllable ') 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' pair (Af,Ef). ') 99984 FORMAT (/' The number of finite zeros = ',I3) 99983 FORMAT (/' The finite zeros are the eigenvalues ', $ 'of the pair (Af,Ef)') 99982 FORMAT (/' Uncontrollable finite eigenvalues'/ $ ' real part imag part ') 99981 FORMAT (/' Finite zeros'/' real part imag part ') 99979 FORMAT (1X,F9.4,SP,F9.4,S,'i ') 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT ( I4,' infinite zero(s) of order ',I3) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99972 FORMAT (/' L or N is out of range.',/' L = ', I5, ' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) 99969 FORMAT (/' Normal rank of transfer function matrix = ',I3) 99968 FORMAT (//' The number of infinite poles = ',I3) 99967 FORMAT ( I4,' infinite pole(s) of order ',I3) 99966 FORMAT (/' The finite poles are the eigenvalues', $ ' of the pair (Af,Ef). ') 99965 FORMAT (/' The system has no finite poles ') 99964 FORMAT (//' The number of unobservable infinite poles = ',I3) 99963 FORMAT (//' The number of uncontrollable infinite poles = ',I3) 99962 FORMAT (/' The number of infinite Kronecker blocks = ',I3) 99961 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B;C,D] are ', /(20(I3,2X))) 99960 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E;C] are ', /(20(I3,2X))) 99959 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B] are ', /(20(I3,2X))) 99958 FORMAT (/' Multiplicities of infinite eigenvalues of A-lambda*E' $ ,' are ', /(20(I3,2X))) 99957 FORMAT (/' The system (A-lambda*E,C) has no finite output', $ ' decoupling zeros ') 99956 FORMAT (/' The system (A-lambda*E,B) has no finite input', $ ' decoupling zeros ') 99955 FORMAT (/' Normal rank of system pencil = ',I3) END slicot-5.0+20101122/examples/TB01ID.dat000077500000000000000000000015301201767322700167430ustar00rootroot00000000000000 TB01ID EXAMPLE PROGRAM DATA 5 2 5 A 0.0 0.0 1.0000e+000 0.0 0.0 0.0 -1.5800e+006 -1.2570e+003 0.0 0.0 0.0 3.5410e+014 0.0 -1.4340e+003 0.0 -5.3300e+011 0.0 0.0 0.0 0.0 1.0000e+000 0.0 0.0 0.0 -1.8630e+004 -1.4820e+000 0.0 0.0 1.1030e+002 0.0 0.0 0.0 0.0 0.0 0.0 8.3330e-003 1.0000e+000 0.0 0.0 0.0 0.0 0.0 0.0 1.0000e+000 0.0 0.0 0.0 0.0 0.0 1.0000e+000 0.0 6.6640e-001 0.0 -6.2000e-013 0.0 0.0 0.0 0.0 -1.0000e-003 1.8960e+006 1.5080e+002 slicot-5.0+20101122/examples/TB01ID.res000077500000000000000000000027601201767322700167720ustar00rootroot00000000000000 TB01ID EXAMPLE PROGRAM RESULTS The balanced matrix A ( 5X 5) 1 2 3 4 5 1 0.0000000D+00 0.1000000D+05 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 -0.1580000D+03 -0.1257000D+04 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.3541000D+05 0.0000000D+00 -0.1434000D+04 0.0000000D+00 -0.5330000D+03 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+03 5 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.1863000D+03 -0.1482000D+01 The balanced matrix B ( 5X 2) 1 2 1 0.0000000D+00 0.0000000D+00 2 0.1103000D+04 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 5 0.0000000D+00 0.8333000D+02 The balanced matrix C ( 5X 5) 1 2 3 4 5 1 0.1000000D-04 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.1000000D+06 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D-05 0.0000000D+00 4 0.6664000D-05 0.0000000D+00 -0.6200000D-07 0.0000000D+00 0.0000000D+00 5 0.0000000D+00 0.0000000D+00 -0.1000000D+03 0.1896000D+01 0.1508000D-01 The scaling vector SCALE ( 1X 5) 1 2 3 4 5 1 0.1000000D-04 0.1000000D+00 0.1000000D+06 0.1000000D-05 0.1000000D-03 MAXRED is 0.3488E+10 slicot-5.0+20101122/examples/TB01IZ.dat000077500000000000000000000022621201767322700167740ustar00rootroot00000000000000 TB01IZ EXAMPLE PROGRAM DATA 5 2 5 A 0.0 (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.5800e+006,0.0) (-1.2570e+003,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (3.5410e+014,0.0) (0.0,0.0) (-1.4340e+003,0.0) (0.0,0.0) (-5.3300e+011,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.8630e+004,0.0) (-1.4820e+000,0.0) (0.0,0.0) (0.0,0.0) (1.1030e+002,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (8.3330e-003,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (6.6640e-001,0.0) (0.0,0.0) (-6.2000e-013,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.0000e-003,0.0) (1.8960e+006,0.0) (1.5080e+002,0.0) slicot-5.0+20101122/examples/TB01IZ.res000077500000000000000000000054721201767322700170230ustar00rootroot00000000000000 TB01IZ EXAMPLE PROGRAM RESULTS The balanced matrix A ( 5X 5) 1 2 3 1 0.0000000D+00 +0.0000000D+00i 0.1000000D+05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 -0.1580000D+03 +0.0000000D+00i -0.1257000D+04 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.3541000D+05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i -0.1434000D+04 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 5 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 5 1 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.0000000D+00 +0.0000000D+00i -0.5330000D+03 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.1000000D+03 +0.0000000D+00i 5 -0.1863000D+03 +0.0000000D+00i -0.1482000D+01 +0.0000000D+00i The balanced matrix B ( 5X 2) 1 2 1 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.1103000D+04 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 5 0.0000000D+00 +0.0000000D+00i 0.8333000D+02 +0.0000000D+00i The balanced matrix C ( 5X 5) 1 2 3 1 0.1000000D-04 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.1000000D+06 +0.0000000D+00i 3 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 0.6664000D-05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i -0.6200000D-07 +0.0000000D+00i 5 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i -0.1000000D+03 +0.0000000D+00i 4 5 1 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.1000000D-05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 5 0.1896000D+01 +0.0000000D+00i 0.1508000D-01 +0.0000000D+00i The scaling vector SCALE ( 1X 5) 1 2 3 4 5 1 0.1000000D-04 0.1000000D+00 0.1000000D+06 0.1000000D-05 0.1000000D-03 MAXRED is 0.3488E+10 slicot-5.0+20101122/examples/TB01KD.dat000077500000000000000000000010411201767322700167420ustar00rootroot00000000000000 TB01KD EXAMPLE PROGRAM DATA (Continuous system) 5 2 3 -1.0 C U G -0.04165 4.9200 -4.9200 0 0 -1.387944 -3.3300 0 0 0 0.5450 0 0 -0.5450 0 0 0 4.9200 -0.04165 4.9200 0 0 0 -1.387944 -3.3300 0 0 3.3300 0 0 0 0 0 0 3.3300 1 0 0 0 0 0 0 1 0 0 0 0 0 1 0 slicot-5.0+20101122/examples/TB01KD.res000077500000000000000000000021731201767322700167720ustar00rootroot00000000000000 TB01KD EXAMPLE PROGRAM RESULTS The number of eigenvalues in the domain of interest = 2 The eigenvalues of state dynamics matrix A are ( -0.7483, 2.9940 ) ( -0.7483, -2.9940 ) ( -1.6858, 2.0311 ) ( -1.6858, -2.0311 ) ( -1.8751, 0.0000 ) The transformed state dynamics matrix inv(U)*A*U is -0.7483 -8.6406 0.0000 0.0000 0.0000 1.0374 -0.7483 0.0000 0.0000 0.0000 0.0000 0.0000 -1.6858 5.5669 0.0000 0.0000 0.0000 -0.7411 -1.6858 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8751 The transformed input/state matrix inv(U)*B is 2.0240 -2.0240 -1.1309 1.1309 -0.8621 -0.8621 2.1912 2.1912 -1.5555 1.5555 The transformed state/output matrix C*U is 0.6864 -0.0987 0.6580 0.2589 0.9650 -0.0471 0.6873 0.0000 0.0000 -0.5609 -0.6864 0.0987 0.6580 0.2589 -0.9650 The similarity transformation matrix U is 0.6864 -0.0987 0.6580 0.2589 0.9650 -0.1665 -0.5041 -0.2589 0.6580 -0.9205 -0.0471 0.6873 0.0000 0.0000 -0.5609 -0.6864 0.0987 0.6580 0.2589 -0.9650 0.1665 0.5041 -0.2589 0.6580 0.9205 slicot-5.0+20101122/examples/TB01LD.dat000077500000000000000000000010411201767322700167430ustar00rootroot00000000000000 TB01LD EXAMPLE PROGRAM DATA (Continuous system) 5 2 3 -1.0 C U G -0.04165 4.9200 -4.9200 0 0 -1.387944 -3.3300 0 0 0 0.5450 0 0 -0.5450 0 0 0 4.9200 -0.04165 4.9200 0 0 0 -1.387944 -3.3300 0 0 3.3300 0 0 0 0 0 0 3.3300 1 0 0 0 0 0 0 1 0 0 0 0 0 1 0 slicot-5.0+20101122/examples/TB01LD.res000077500000000000000000000021641201767322700167730ustar00rootroot00000000000000 TB01LD EXAMPLE PROGRAM RESULTS The number of eigenvalues in the domain of interest = 2 The eigenvalues of state dynamics matrix A are ( -0.7483, 2.9940 ) ( -0.7483, -2.9940 ) ( -1.6858, 2.0311 ) ( -1.6858, -2.0311 ) ( -1.8751, 0.0000 ) The transformed state dynamics matrix U'*A*U is -0.7483 -8.6406 0.0000 0.0000 1.1745 1.0374 -0.7483 0.0000 0.0000 -2.1164 0.0000 0.0000 -1.6858 5.5669 0.0000 0.0000 0.0000 -0.7411 -1.6858 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8751 The transformed input/state matrix U'*B is -0.5543 0.5543 -1.6786 1.6786 -0.8621 -0.8621 2.1912 2.1912 -1.5555 1.5555 The transformed state/output matrix C*U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 The similarity transformation matrix U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.1665 -0.5041 -0.2589 0.6580 -0.4671 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 0.1665 0.5041 -0.2589 0.6580 0.4671 slicot-5.0+20101122/examples/TB01MD.dat000077500000000000000000000006041201767322700167500ustar00rootroot00000000000000 TB01MD EXAMPLE PROGRAM DATA 6 3 N U 35.0 1.0 6.0 26.0 19.0 24.0 3.0 32.0 7.0 21.0 23.0 25.0 31.0 9.0 2.0 22.0 27.0 20.0 8.0 28.0 33.0 17.0 10.0 15.0 30.0 5.0 34.0 12.0 14.0 16.0 4.0 36.0 29.0 13.0 18.0 11.0 1.0 5.0 11.0 -1.0 4.0 11.0 -5.0 1.0 9.0 -11.0 -4.0 5.0 -19.0 -11.0 -1.0 -29.0 -20.0 -9.0 slicot-5.0+20101122/examples/TB01MD.res000077500000000000000000000011431201767322700167700ustar00rootroot00000000000000 TB01MD EXAMPLE PROGRAM RESULTS The transformed state transition matrix is 60.3649 58.8853 5.0480 -5.4406 2.1382 -7.3870 54.5832 33.1865 36.5234 6.3272 -3.1377 8.8154 17.6406 21.4501 -13.5942 0.5417 1.6926 0.0786 -9.0567 10.7202 0.3531 1.5444 -1.2846 24.6407 0.0000 6.8796 -20.1372 -2.6440 2.4983 -21.8071 0.0000 0.0000 0.0000 0.0000 0.0000 27.0000 The transformed input matrix is -16.8819 -8.8260 13.9202 0.0000 13.8240 39.9205 0.0000 0.0000 4.1928 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples/TB01ND.dat000077500000000000000000000004541201767322700167540ustar00rootroot00000000000000 TB01ND EXAMPLE PROGRAM DATA 5 3 N U 15.0 21.0 -3.0 3.0 9.0 20.0 1.0 2.0 8.0 9.0 4.0 1.0 7.0 13.0 14.0 5.0 6.0 12.0 13.0 -6.0 5.0 11.0 17.0 -7.0 -1.0 7.0 -1.0 3.0 -6.0 -3.0 4.0 5.0 6.0 -2.0 -3.0 9.0 8.0 5.0 2.0 1.0 slicot-5.0+20101122/examples/TB01ND.res000077500000000000000000000007421201767322700167750ustar00rootroot00000000000000 TB01ND EXAMPLE PROGRAM RESULTS The transformed state transition matrix is 7.1637 -0.9691 -16.5046 0.2869 0.9205 -2.3285 11.5431 -8.7471 3.4122 -3.7118 -10.5440 -7.6032 -0.3215 3.6571 -0.4335 -3.6845 5.6449 0.5906 -15.6996 17.4267 0.0000 -6.4260 1.5591 14.4317 32.3143 The transformed output matrix is 0.0000 0.0000 7.6585 5.2973 -4.1576 0.0000 0.0000 0.0000 5.8305 -7.4837 0.0000 0.0000 0.0000 0.0000 -13.2288 slicot-5.0+20101122/examples/TB01PD.dat000077500000000000000000000002641201767322700167550ustar00rootroot00000000000000 TB01PD EXAMPLE PROGRAM DATA 3 1 2 0.0 M N 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/TB01PD.res000077500000000000000000000007001201767322700167710ustar00rootroot00000000000000 TB01PD EXAMPLE PROGRAM RESULTS The order of the minimal realization = 3 The transformed state dynamics matrix of a minimal realization is 1.0000 -1.4142 1.4142 -2.8284 0.0000 1.0000 2.8284 1.0000 0.0000 The transformed input/state matrix of a minimal realization is -1.0000 0.7071 0.7071 The transformed state/output matrix of a minimal realization is 0.0000 0.0000 -1.4142 0.0000 0.7071 0.7071 slicot-5.0+20101122/examples/TB01TD.dat000077500000000000000000000005361201767322700167630ustar00rootroot00000000000000 TB01TD EXAMPLE PROGRAM DATA 5 2 2 0.0 0.0 1.0 4.0 5.0 50.0 10.0 1.0 0.0 0.0 0.0 0.0 90.0 10.0 0.0 0.0 1.0 1.0 1.0 1.0 100.0 0.0 0.0 0.0 70.0 0.0 2.0 0.0 1.0 2.0 0.0 20.0 100.0 1.0 0.0 1.0 0.0 0.0 1.0 0.0 1.0 1.0 0.0 2.0 1.0 1.0 1.0 1.0 1.0 slicot-5.0+20101122/examples/TB01TD.res000077500000000000000000000013301201767322700167750ustar00rootroot00000000000000 TB01TD EXAMPLE PROGRAM RESULTS LOW = 1 IGH = 5 The balanced state dynamics matrix A is 0.0000 0.0000 1.0000 4.0000 40.0000 6.2500 10.0000 0.1250 0.0000 0.0000 0.0000 0.0000 90.0000 10.0000 0.0000 0.0000 8.0000 1.0000 1.0000 8.0000 12.5000 0.0000 0.0000 0.0000 70.0000 The balanced input/state matrix B is 0.0000 0.0000 16.0000 2.5000 0.0000 100.0000 64.0000 1.0000 16.0000 0.0000 The balanced state/output matrix C is 32.0000 0.0000 0.0000 32.0000 0.0000 4.0000 32.0000 0.0000 8.0000 32.0000 The scaled direct transmission matrix D is 2048.0000 32.0000 256.0000 4.0000 slicot-5.0+20101122/examples/TB01UD.dat000077500000000000000000000003011201767322700167520ustar00rootroot00000000000000 TB01UD EXAMPLE PROGRAM DATA 3 2 2 0.0 I -1.0 0.0 0.0 -2.0 -2.0 -2.0 -1.0 0.0 -3.0 1.0 0.0 0.0 0.0 2.0 1.0 0.0 2.0 1.0 1.0 0.0 0.0 slicot-5.0+20101122/examples/TB01UD.res000077500000000000000000000012571201767322700170060ustar00rootroot00000000000000 TB01UD EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 2 The transformed state dynamics matrix of a controllable realization is -3.0000 2.2361 0.0000 -1.0000 and the dimensions of its diagonal blocks are 2 The transformed input/state matrix B of a controllable realization is 0.0000 -2.2361 1.0000 0.0000 The transformed output/state matrix C of a controllable realization is -2.2361 0.0000 0.0000 1.0000 The controllability index of the transformed system representation = 1 The similarity transformation matrix Z is 0.0000 1.0000 0.0000 -0.8944 0.0000 -0.4472 -0.4472 0.0000 0.8944 slicot-5.0+20101122/examples/TB01WD.dat000077500000000000000000000010061201767322700167570ustar00rootroot00000000000000 TB01WD EXAMPLE PROGRAM DATA (Continuous system) 5 2 3 -0.04165 4.9200 -4.9200 0 0 -1.387944 -3.3300 0 0 0 0.5450 0 0 -0.5450 0 0 0 4.9200 -0.04165 4.9200 0 0 0 -1.387944 -3.3300 0 0 3.3300 0 0 0 0 0 0 3.3300 1 0 0 0 0 0 0 1 0 0 0 0 0 1 0 slicot-5.0+20101122/examples/TB01WD.res000077500000000000000000000020661201767322700170070ustar00rootroot00000000000000 TB01WD EXAMPLE PROGRAM RESULTS The eigenvalues of state dynamics matrix A are ( -0.7483, 2.9940 ) ( -0.7483, -2.9940 ) ( -1.6858, 2.0311 ) ( -1.6858, -2.0311 ) ( -1.8751, 0.0000 ) The transformed state dynamics matrix U'*A*U is -0.7483 -8.6406 0.0000 0.0000 1.1745 1.0374 -0.7483 0.0000 0.0000 -2.1164 0.0000 0.0000 -1.6858 5.5669 0.0000 0.0000 0.0000 -0.7411 -1.6858 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8751 The transformed input/state matrix U'*B is -0.5543 0.5543 -1.6786 1.6786 -0.8621 -0.8621 2.1912 2.1912 -1.5555 1.5555 The transformed state/output matrix C*U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 The similarity transformation matrix U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.1665 -0.5041 -0.2589 0.6580 -0.4671 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 0.1665 0.5041 -0.2589 0.6580 0.4671 slicot-5.0+20101122/examples/TB01ZD.dat000077500000000000000000000002501201767322700167620ustar00rootroot00000000000000 TB01ZD EXAMPLE PROGRAM DATA 3 2 0.0 I 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 0.0 slicot-5.0+20101122/examples/TB01ZD.res000077500000000000000000000011061201767322700170040ustar00rootroot00000000000000 TB01ZD EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 3 The state dynamics matrix A of a controllable realization is 1.0000 1.4142 0.0000 2.8284 -1.0000 2.8284 0.0000 1.4142 1.0000 The input/state vector B of a controllable realization is -1.4142 0.0000 0.0000 The output/state matrix C of a controllable realization is -0.7071 -2.0000 0.7071 -0.7071 0.0000 -0.7071 The similarity transformation matrix Z is -0.7071 0.0000 -0.7071 0.0000 -1.0000 0.0000 -0.7071 0.0000 0.7071 slicot-5.0+20101122/examples/TB03AD.dat000077500000000000000000000003011201767322700167300ustar00rootroot00000000000000 TB03AD EXAMPLE PROGRAM DATA 3 1 2 0.0 R N 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 0.0 1.0 slicot-5.0+20101122/examples/TB03AD.res000077500000000000000000000014451201767322700167630ustar00rootroot00000000000000 TB03AD EXAMPLE PROGRAM RESULTS The order of the minimal state-space representation = 3 The transformed state dynamics matrix of a minimal realization is 1.0000 -1.4142 0.0000 -2.8284 -1.0000 2.8284 0.0000 1.4142 1.0000 and the dimensions of its diagonal blocks are 1 1 1 The transformed input/state matrix of a minimal realization is -1.4142 0.0000 0.0000 The transformed state/output matrix of a minimal realization is 0.7071 1.0000 0.7071 -0.7071 0.0000 -0.7071 The controllability index of the transformed minimal system representation = 3 INDEX is 3 The denominator matrix P(s) is 0.1768 -0.1768 -1.5910 1.5910 The numerator matrix Q(s) is 0.0000 -0.1768 0.7071 0.8839 0.1768 0.0000 -1.5910 0.0000 slicot-5.0+20101122/examples/TB04AD.dat000077500000000000000000000003431201767322700167370ustar00rootroot00000000000000 TB04AD EXAMPLE PROGRAM DATA 3 2 2 0.0 0.0 R -1.0 0.0 0.0 0.0 -2.0 0.0 0.0 0.0 -3.0 0.0 1.0 -1.0 1.0 1.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/TB04AD.res000077500000000000000000000024341201767322700167630ustar00rootroot00000000000000 TB04AD EXAMPLE PROGRAM RESULTS The order of the transformed state-space representation = 3 The transformed state dynamics matrix A is -2.5000 -0.2887 -0.4082 -0.2887 -1.5000 -0.7071 -0.4082 -0.7071 -2.0000 The transformed input/state matrix B is -1.4142 -0.7071 0.0000 1.2247 0.0000 0.0000 The transformed state/output matrix C is 0.0000 0.8165 1.1547 0.0000 1.6330 0.5774 The controllability index of the transformed state-space representation = 2 The dimensions of the diagonal blocks of the transformed A are 2 1 The degrees of the denominator polynomials are 2 3 The coefficients of polynomials in the transfer matrix T(s) are element ( 1, 1) is 1.00 5.00 7.00 0.00 ----------------------------- 1.00 5.00 6.00 0.00 element ( 1, 2) is 0.00 1.00 3.00 0.00 ----------------------------- 1.00 5.00 6.00 0.00 element ( 2, 1) is 0.00 0.00 1.00 1.00 ----------------------------- 1.00 6.00 11.00 6.00 element ( 2, 2) is 1.00 8.00 20.00 15.00 ----------------------------- 1.00 6.00 11.00 6.00 slicot-5.0+20101122/examples/TB04BD.dat000077500000000000000000000003501201767322700167360ustar00rootroot00000000000000 TB04BD EXAMPLE PROGRAM DATA 3 2 2 0.0 D I N -1.0 0.0 0.0 0.0 -2.0 0.0 0.0 0.0 -3.0 0.0 1.0 -1.0 1.0 1.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/TB04BD.res000077500000000000000000000012331201767322700167600ustar00rootroot00000000000000 TB04BD EXAMPLE PROGRAM RESULTS The polynomial coefficients appear in increasing order of the powers of the indeterminate The coefficients of polynomials in the transfer matrix T(s) are element ( 1, 1) is 7.00 5.00 1.00 ---------------------- 6.00 5.00 1.00 element ( 2, 1) is 1.00 ---------------------- 6.00 5.00 1.00 element ( 1, 2) is 1.00 --------------- 2.00 1.00 element ( 2, 2) is 5.00 5.00 1.00 ---------------------- 2.00 3.00 1.00 slicot-5.0+20101122/examples/TB04CD.dat000077500000000000000000000003421201767322700167400ustar00rootroot00000000000000 TB04CD EXAMPLE PROGRAM DATA 3 2 2 0.0 D N -1.0 0.0 0.0 0.0 -2.0 0.0 0.0 0.0 -3.0 0.0 1.0 -1.0 1.0 1.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/TB04CD.res000077500000000000000000000017141201767322700167650ustar00rootroot00000000000000 TB04CD EXAMPLE PROGRAM RESULTS The poles, zeros and gains of the transfer matrix elements: zeros of element ( 1, 1) are real part imag part -2.5000 0.8660 -2.5000 -0.8660 poles of element ( 1, 1) are real part imag part -2.0000 0.0000 -3.0000 0.0000 gain of element ( 1, 1) is 1.0000 no zeros for element ( 2, 1) poles of element ( 2, 1) are real part imag part -2.0000 0.0000 -3.0000 0.0000 gain of element ( 2, 1) is 1.0000 no zeros for element ( 1, 2) poles of element ( 1, 2) are real part imag part -2.0000 0.0000 gain of element ( 1, 2) is 1.0000 zeros of element ( 2, 2) are real part imag part -3.6180 0.0000 -1.3820 0.0000 poles of element ( 2, 2) are real part imag part -1.0000 0.0000 -2.0000 0.0000 gain of element ( 2, 2) is 1.0000 slicot-5.0+20101122/examples/TB05AD.dat000077500000000000000000000002721201767322700167410ustar00rootroot00000000000000 TB05AD EXAMPLE PROGRAM DATA 3 1 2 (0.0,0.5) G A 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 1.0 0.0 -1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples/TB05AD.res000077500000000000000000000004521201767322700167620ustar00rootroot00000000000000 TB05AD EXAMPLE PROGRAM RESULTS RCOND = 0.22 Eigenvalues of the state transmission matrix A are 3.00 0.00*j -3.00 0.00*j 1.00 0.00*j The frequency response matrix G(freq) is ( 0.69, 0.35) (-0.80,-0.40) H(inverse)*B is (-0.11,-0.05) (-0.43, 0.00) (-0.80,-0.40) slicot-5.0+20101122/examples/TBB01AD.f000077500000000000000000000140371201767322700165200ustar00rootroot00000000000000* BB01AD EXAMPLE PROGRAM TEXT * * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 100, NMAX = 100, PMAX = 100 ) INTEGER LDA, LDB, LDC, LDG, LDQ, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDG = NMAX, LDQ = NMAX, LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*MAX( 4, NMAX ) ) * .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, ISYMM, J, LBPAR, LDPAR, LIPAR, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB,MMAX), C(LDC, NMAX), $ DPAR(7), DWORK(LDWORK), G(LDG, NMAX), $ Q(LDQ, NMAX), X(LDX, NMAX) INTEGER IPAR(3), NR(2) LOGICAL BPAR(6), VEC(9) CHARACTER CHPAR(255) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL BB01AD, MA02DD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ( NIN, FMT = '()' ) READ( NIN, FMT = * ) DEF READ( NIN, FMT = * ) ( NR(I), I = 1, 2 ) IF( LSAME( DEF, 'N' ) ) THEN READ( NIN, FMT = * ) LBPAR IF( LBPAR.GT.0 ) READ( NIN, FMT = * ) ( BPAR(I), I = 1, LBPAR ) READ( NIN, FMT = * ) LDPAR IF( LDPAR.GT.0 ) READ( NIN, FMT = * ) ( DPAR(I), I = 1, LDPAR ) READ( NIN, FMT = * ) LIPAR IF( LIPAR.GT.0 ) READ( NIN, FMT = * ) ( IPAR(I), I = 1, LIPAR ) END IF * Generate benchmark example CALL BB01AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, A, $ LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, DWORK, $ LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99998 ) INFO ELSE WRITE( NOUT, FMT = * ) CHPAR(1:70) WRITE( NOUT, FMT = 99997 ) N WRITE( NOUT, FMT = 99996 ) M WRITE( NOUT, FMT = 99995 ) P WRITE( NOUT, FMT = 99994 ) DO 10 I = 1, N WRITE( NOUT, FMT = 99979 ) ( A(I,J), J = 1, N ) 10 CONTINUE IF( VEC(5) ) THEN WRITE( NOUT, FMT = 99993 ) DO 20 I = 1, N WRITE( NOUT, FMT = 99979 ) ( B(I,J), J = 1, M ) 20 CONTINUE ELSE WRITE( NOUT, FMT = 99992 ) END IF IF( VEC(6) ) THEN WRITE( NOUT,FMT = 99991 ) DO 30 I = 1, P WRITE( NOUT, FMT = 99979 ) ( C(I,J), J = 1, N ) 30 CONTINUE ELSE WRITE( NOUT, FMT = 99990 ) END IF IF( .NOT.VEC(5) ) THEN WRITE( NOUT, FMT = 99989 ) IF( .NOT.BPAR(2) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, G, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, G, LDG, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, G, LDG, DWORK ) END IF END IF DO 40 I = 1, N WRITE( NOUT, FMT = 99979 ) ( G(I,J), J = 1, N ) 40 CONTINUE ELSE WRITE( NOUT, FMT = 99988 ) END IF IF( .NOT.VEC(6) ) THEN IF( .NOT. BPAR(5) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99987 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99979 ) ( Q(I,J), J = 1, N ) 50 CONTINUE ELSE WRITE( NOUT, FMT = 99986 ) END IF IF( VEC(6) ) THEN IF( .NOT.BPAR(5) ) THEN ISYMM = ( P * ( P + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', P, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', P, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99985 ) DO 60 I = 1, N WRITE( NOUT, FMT = 99979 ) ( Q(I,J), J = 1, N ) 60 CONTINUE ELSE WRITE( NOUT, FMT = 99984 ) END IF IF( VEC(5) ) THEN IF( .NOT.BPAR(2) ) THEN ISYMM = ( M * ( M + 1 ) ) / 2 CALL DCOPY( ISYMM, G, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', M, G, LDG, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', M, G, LDG, DWORK ) END IF END IF WRITE( NOUT, FMT = 99983 ) DO 70 I = 1, N WRITE( NOUT, FMT = 99979 ) ( G(I,J), J = 1, N ) 70 CONTINUE ELSE WRITE( NOUT, FMT = 99982 ) END IF IF( VEC(9) ) THEN WRITE( NOUT, FMT = 99981 ) DO 80 I = 1, N WRITE( NOUT, FMT = 99979 ) ( X(I,J), J = 1, N ) 80 CONTINUE ELSE WRITE( NOUT, FMT = 99980 ) END IF END IF STOP * 99999 FORMAT (' BB01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB03AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (' A = ') 99993 FORMAT (' B = ') 99992 FORMAT (' B is not provided.') 99991 FORMAT (' C = ') 99990 FORMAT (' C is not provided.') 99989 FORMAT (' G = ') 99988 FORMAT (' G is not provided.') 99987 FORMAT (' Q = ') 99986 FORMAT (' Q is not provided.') 99985 FORMAT (' W = ') 99984 FORMAT (' W is not provided.') 99983 FORMAT (' R = ') 99982 FORMAT (' R is not provided.') 99981 FORMAT (' X = ') 99980 FORMAT (' X is not provided.') 99979 FORMAT (20(1X,F8.4)) * END slicot-5.0+20101122/examples/TBB02AD.f000077500000000000000000000145001201767322700165140ustar00rootroot00000000000000* BB02AD EXAMPLE PROGRAM TEXT * * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 100, NMAX = 100, PMAX = 100 ) INTEGER LDA, LDB, LDC, LDQ, LDR, LDS, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDQ = NMAX, LDR = NMAX, LDS = NMAX, $ LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*NMAX ) * .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, ISYMM, J, LBPAR, LDPAR, LIPAR, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB,MMAX), C(LDC, NMAX), $ DPAR(4), DWORK(LDWORK), Q(LDQ, NMAX), $ R(LDR, NMAX), S(LDS, NMAX), X(LDX, NMAX) INTEGER IPAR(3), NR(2) LOGICAL BPAR(7), VEC(10) CHARACTER CHPAR(255) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL BB02AD, MA02DD * .. Executable Statements .. WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ( NIN, FMT = '()' ) READ( NIN, FMT = * ) DEF READ( NIN, FMT = * ) ( NR(I), I = 1, 2 ) IF( LSAME( DEF, 'N' ) ) THEN READ( NIN, FMT = * ) LBPAR IF( LBPAR.GT.0 ) READ( NIN, FMT = * ) ( BPAR(I), I = 1, LBPAR ) READ( NIN, FMT = * ) LDPAR IF( LDPAR.GT.0 ) READ( NIN, FMT = * ) ( DPAR(I), I = 1, LDPAR ) READ( NIN, FMT = * ) LIPAR IF( LIPAR.GT.0 ) READ( NIN, FMT = * ) ( IPAR(I), I = 1, LIPAR ) END IF * Generate benchmark example CALL BB02AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, A, $ LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, X, LDX, $ DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99998 ) INFO ELSE WRITE( NOUT, FMT = * ) CHPAR(1:70) WRITE( NOUT, FMT = 99997 ) N WRITE( NOUT, FMT = 99996 ) M WRITE( NOUT, FMT = 99995 ) P WRITE( NOUT, FMT = 99994 ) DO 10 I = 1, N WRITE( NOUT, FMT = 99977 ) ( A(I,J), J = 1, N ) 10 CONTINUE IF( VEC(5) ) THEN WRITE( NOUT, FMT = 99993 ) DO 20 I = 1, N WRITE( NOUT, FMT = 99977 ) ( B(I,J), J = 1, M ) 20 CONTINUE ELSE WRITE( NOUT, FMT = 99992 ) END IF IF( VEC(6) ) THEN WRITE( NOUT,FMT = 99991 ) DO 30 I = 1, P WRITE( NOUT, FMT = 99977 ) ( C(I,J), J = 1, N ) 30 CONTINUE ELSE WRITE( NOUT, FMT = 99990 ) END IF IF( .NOT.VEC(5) ) THEN WRITE( NOUT, FMT = 99989 ) IF( .NOT.BPAR(2) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, R, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, R, LDR, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, R, LDR, DWORK ) END IF END IF DO 40 I = 1, N WRITE( NOUT, FMT = 99977 ) ( R(I,J), J = 1, N ) 40 CONTINUE ELSE WRITE( NOUT, FMT = 99988 ) END IF IF( .NOT.VEC(6) ) THEN IF( .NOT.BPAR(5) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99987 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99977 ) ( Q(I,J), J = 1, N ) 50 CONTINUE ELSE WRITE( NOUT, FMT = 99986 ) END IF IF( VEC(6) ) THEN IF( .NOT.BPAR(5) ) THEN ISYMM = ( P * ( P + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', P, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', P, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99985 ) DO 60 I = 1, P WRITE( NOUT, FMT = 99977 ) ( Q(I,J), J = 1, P ) 60 CONTINUE ELSE WRITE( NOUT, FMT = 99984 ) END IF IF( VEC(5) ) THEN IF( .NOT.BPAR(2) ) THEN ISYMM = ( M * ( M + 1 ) ) / 2 CALL DCOPY( ISYMM, R, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', M, R, LDR, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', M, R, LDR, DWORK ) END IF END IF WRITE( NOUT, FMT = 99983 ) DO 70 I = 1, M WRITE( NOUT, FMT = 99977 ) ( R(I,J), J = 1, M ) 70 CONTINUE ELSE WRITE( NOUT, FMT = 99982 ) END IF IF( VEC(9) ) THEN WRITE( NOUT, FMT = 99981 ) DO 80 I = 1, N WRITE( NOUT, FMT = 99977 ) ( S(I,J), J = 1, M ) 80 CONTINUE ELSE WRITE( NOUT, FMT = 99980 ) END IF IF( VEC(10) ) THEN WRITE( NOUT, FMT = 99979 ) DO 90 I = 1, N WRITE( NOUT, FMT = 99977 ) ( X(I,J), J = 1, N ) 90 CONTINUE ELSE WRITE( NOUT, FMT = 99978 ) END IF END IF STOP * 99999 FORMAT (' BB02AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB02AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (' A = ') 99993 FORMAT (' B = ') 99992 FORMAT (' B is not provided.') 99991 FORMAT (' C = ') 99990 FORMAT (' C is not provided.') 99989 FORMAT (' G = ') 99988 FORMAT (' G is not provided.') 99987 FORMAT (' Q = ') 99986 FORMAT (' Q is not provided.') 99985 FORMAT (' Q0 = ') 99984 FORMAT (' Q0 is not provided.') 99983 FORMAT (' R = ') 99982 FORMAT (' R is not provided.') 99981 FORMAT (' S = ') 99980 FORMAT (' S is not provided.') 99979 FORMAT (' X = ') 99978 FORMAT (' X is not provided.') 99977 FORMAT (20(1X,F8.4)) * END slicot-5.0+20101122/examples/TBB03AD.f000077500000000000000000000070371201767322700165240ustar00rootroot00000000000000C BB03AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX PARAMETER (NMAX = 100, MMAX = 100) INTEGER LDE, LDA, LDY, LDB, LDX, LDU, LDWORK PARAMETER (LDE = NMAX, LDA = NMAX, LDY = NMAX, LDB = MMAX, 1 LDX = NMAX, LDU = NMAX, LDWORK = 2*NMAX) C .. Local Scalars .. CHARACTER DEF INTEGER INFO, N, M, I, J, LDPAR, LIPAR CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION E(LDE,NMAX), A(LDA, NMAX), Y(LDY, NMAX), 1 B(LDB,NMAX), X(LDX, NMAX), U(LDU, NMAX), 2 DPAR(2), DWORK(LDWORK) INTEGER NR(2), IPAR(1) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BB03AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, Y, 1 LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, LDWORK, 2 INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M IF (VEC(3)) THEN WRITE (NOUT, FMT = 99995) DO 10 I = 1, N WRITE (NOUT, FMT = 99985) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99994) END IF WRITE (NOUT,FMT = 99993) DO 20 I = 1, N WRITE (NOUT, FMT = 99985) (A(I,J), J = 1, N) 20 CONTINUE IF (VEC(6)) THEN WRITE (NOUT,FMT = 99992) DO 30 I = 1, M WRITE (NOUT, FMT = 99985) (B(I,J), J = 1, N) 30 CONTINUE ELSE WRITE (NOUT, FMT = 99991) END IF WRITE (NOUT,FMT = 99990) DO 40 I = 1, N WRITE (NOUT, FMT = 99985) (Y(I,J), J = 1, N) 40 CONTINUE IF (VEC(7)) THEN WRITE (NOUT, FMT = 99989) DO 50 I = 1, N WRITE (NOUT, FMT = 99985) (X(I,J), J = 1, N) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF IF (VEC(8)) THEN WRITE (NOUT, FMT = 99987) DO 60 I = 1, N WRITE (NOUT, FMT = 99985) (U(I,J), J = 1, N) 60 CONTINUE ELSE WRITE (NOUT, FMT = 99986) END IF END IF C 99999 FORMAT (' BB03AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB03AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of rows in matrix B: M = ', I3) 99995 FORMAT (/' E = ') 99994 FORMAT (/' E is the identity matrix.') 99993 FORMAT (' A = ') 99992 FORMAT (' B = ') 99991 FORMAT (' B is not provided.') 99990 FORMAT (' Y = ') 99989 FORMAT (' X = ') 99988 FORMAT (' X is not provided.') 99987 FORMAT (' U = ') 99986 FORMAT (' U is not provided.') 99985 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples/TBB04AD.f000077500000000000000000000070371201767322700165250ustar00rootroot00000000000000C BB04AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX PARAMETER (NMAX = 100, MMAX = 100) INTEGER LDE, LDA, LDY, LDB, LDX, LDU, LDWORK PARAMETER (LDE = NMAX, LDA = NMAX, LDY = NMAX, LDB = MMAX, 1 LDX = NMAX, LDU = NMAX, LDWORK = 2*NMAX) C .. Local Scalars .. CHARACTER DEF INTEGER INFO, N, M, I, J, LDPAR, LIPAR CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION E(LDE,NMAX), A(LDA, NMAX), Y(LDY, NMAX), 1 B(LDB,NMAX), X(LDX, NMAX), U(LDU, NMAX), 2 DPAR(2), DWORK(LDWORK) INTEGER NR(2), IPAR(1) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BB04AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, Y, 1 LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, LDWORK, 2 INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M IF (VEC(3)) THEN WRITE (NOUT, FMT = 99995) DO 10 I = 1, N WRITE (NOUT, FMT = 99985) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99994) END IF WRITE (NOUT,FMT = 99993) DO 20 I = 1, N WRITE (NOUT, FMT = 99985) (A(I,J), J = 1, N) 20 CONTINUE IF (VEC(6)) THEN WRITE (NOUT,FMT = 99992) DO 30 I = 1, M WRITE (NOUT, FMT = 99985) (B(I,J), J = 1, N) 30 CONTINUE ELSE WRITE (NOUT, FMT = 99991) END IF WRITE (NOUT,FMT = 99990) DO 40 I = 1, N WRITE (NOUT, FMT = 99985) (Y(I,J), J = 1, N) 40 CONTINUE IF (VEC(7)) THEN WRITE (NOUT, FMT = 99989) DO 50 I = 1, N WRITE (NOUT, FMT = 99985) (X(I,J), J = 1, N) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF IF (VEC(8)) THEN WRITE (NOUT, FMT = 99987) DO 60 I = 1, N WRITE (NOUT, FMT = 99985) (U(I,J), J = 1, N) 60 CONTINUE ELSE WRITE (NOUT, FMT = 99986) END IF END IF C 99999 FORMAT (' BB04AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB04AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of rows in matrix B: M = ', I3) 99995 FORMAT (/' E = ') 99994 FORMAT (/' E is the identity matrix.') 99993 FORMAT (' A = ') 99992 FORMAT (' B = ') 99991 FORMAT (' B is not provided.') 99990 FORMAT (' Y = ') 99989 FORMAT (' X = ') 99988 FORMAT (' X is not provided.') 99987 FORMAT (' U = ') 99986 FORMAT (' U is not provided.') 99985 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples/TBD01AD.f000077500000000000000000000062401201767322700165170ustar00rootroot00000000000000C BD01AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX, PMAX PARAMETER (NMAX = 421, MMAX = 211, PMAX = 211) INTEGER LDA, LDB, LDC, LDD, LDE, LDWORK PARAMETER (LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, 1 LDE = NMAX, LDWORK = 4*NMAX) C .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, J, LDPAR, LIPAR, M, N, P CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), 1 D(LDD,MMAX), DPAR(7), DWORK(LDWORK), E(LDE,NMAX) INTEGER NR(2), IPAR(7) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BD01AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BD01AD(DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, LDA, 1 B, LDB, C, LDC, D, LDD, NOTE, DWORK, LDWORK, INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M WRITE (NOUT, FMT = 99995) P IF (VEC(4)) THEN WRITE (NOUT, FMT = 99994) DO 10 I = 1, N WRITE (NOUT, FMT = 99987) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99993) END IF WRITE (NOUT,FMT = 99992) DO 20 I = 1, N WRITE (NOUT, FMT = 99987) (A(I,J), J = 1, N) 20 CONTINUE WRITE (NOUT,FMT = 99991) DO 30 I = 1, N WRITE (NOUT, FMT = 99987) (B(I,J), J = 1, M) 30 CONTINUE WRITE (NOUT,FMT = 99990) DO 40 I = 1, P WRITE (NOUT, FMT = 99987) (C(I,J), J = 1, N) 40 CONTINUE IF (VEC(8)) THEN WRITE (NOUT,FMT = 99989) DO 50 I = 1, P WRITE (NOUT, FMT = 99987) (D(I,J), J = 1, M) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF END IF C 99999 FORMAT (' BD01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BD01AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (/' E = ') 99993 FORMAT (/' E is the identity matrix.') 99992 FORMAT (' A = ') 99991 FORMAT (' B = ') 99990 FORMAT (' C = ') 99989 FORMAT (' D = ') 99988 FORMAT (' D is of zeros.') 99987 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples/TBD02AD.f000077500000000000000000000062331201767322700165220ustar00rootroot00000000000000C BD02AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX, PMAX PARAMETER (NMAX = 421, MMAX = 211, PMAX = 211) INTEGER LDA, LDB, LDC, LDD, LDE, LDWORK PARAMETER (LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, 1 LDE = NMAX, LDWORK = 1) C .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, J, LDPAR, LIPAR, M, N, P CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), 1 D(LDD,MMAX), DPAR(7), DWORK(LDWORK), E(LDE,NMAX) INTEGER NR(2), IPAR(7) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BD02AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BD02AD(DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, LDA, 1 B, LDB, C, LDC, D, LDD, NOTE, DWORK, LDWORK, INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M WRITE (NOUT, FMT = 99995) P IF (VEC(4)) THEN WRITE (NOUT, FMT = 99994) DO 10 I = 1, N WRITE (NOUT, FMT = 99987) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99993) END IF WRITE (NOUT,FMT = 99992) DO 20 I = 1, N WRITE (NOUT, FMT = 99987) (A(I,J), J = 1, N) 20 CONTINUE WRITE (NOUT,FMT = 99991) DO 30 I = 1, N WRITE (NOUT, FMT = 99987) (B(I,J), J = 1, M) 30 CONTINUE WRITE (NOUT,FMT = 99990) DO 40 I = 1, P WRITE (NOUT, FMT = 99987) (C(I,J), J = 1, N) 40 CONTINUE IF (VEC(8)) THEN WRITE (NOUT,FMT = 99989) DO 50 I = 1, P WRITE (NOUT, FMT = 99987) (D(I,J), J = 1, M) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF END IF C 99999 FORMAT (' BD02AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BD02AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (/' E = ') 99993 FORMAT (/' E is the identity matrix.') 99992 FORMAT (' A = ') 99991 FORMAT (' B = ') 99990 FORMAT (' C = ') 99989 FORMAT (' D = ') 99988 FORMAT (' D is of zeros.') 99987 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples/TC01OD.dat000077500000000000000000000003141201767322700167510ustar00rootroot00000000000000 TC01OD EXAMPLE PROGRAM DATA 2 2 3 L 2.0 3.0 1.0 4.0 -1.0 -1.0 5.0 7.0 -6.0 3.0 2.0 2.0 6.0 -1.0 5.0 1.0 7.0 5.0 1.0 1.0 1.0 4.0 1.0 -1.0 slicot-5.0+20101122/examples/TC01OD.res000077500000000000000000000010011201767322700167640ustar00rootroot00000000000000 TC01OD EXAMPLE PROGRAM RESULTS The coefficients of the denominator matrix of the dual system are element ( 1, 1) is 2.00 3.00 1.00 element ( 1, 2) is 5.00 7.00 -6.00 element ( 2, 1) is 4.00 -1.00 -1.00 element ( 2, 2) is 3.00 2.00 2.00 The coefficients of the numerator matrix of the dual system are element ( 1, 1) is 6.00 -1.00 5.00 element ( 1, 2) is 1.00 1.00 1.00 element ( 2, 1) is 1.00 7.00 5.00 element ( 2, 2) is 4.00 1.00 -1.00 slicot-5.0+20101122/examples/TC04AD.dat000077500000000000000000000003211201767322700167340ustar00rootroot00000000000000 TC04AD EXAMPLE PROGRAM DATA 2 2 L 2 2 2.0 3.0 1.0 4.0 -1.0 -1.0 5.0 7.0 -6.0 3.0 2.0 2.0 6.0 -1.0 5.0 1.0 7.0 5.0 1.0 1.0 1.0 4.0 1.0 -1.0 slicot-5.0+20101122/examples/TC04AD.res000077500000000000000000000011061201767322700167570ustar00rootroot00000000000000 TC04AD EXAMPLE PROGRAM RESULTS The order of the resulting state-space representation = 4 RCOND = 0.25 The state dynamics matrix A is 0.0000 0.5714 0.0000 -0.4286 1.0000 1.0000 0.0000 -1.0000 0.0000 -2.0000 0.0000 2.0000 0.0000 0.7857 1.0000 -1.7143 The input/state matrix B is 8.0000 3.8571 4.0000 4.0000 -9.0000 5.0000 4.0000 -5.0714 The state/output matrix C is 0.0000 -0.2143 0.0000 0.2857 0.0000 0.3571 0.0000 -0.1429 The direct transmission matrix D is -1.0000 0.9286 2.0000 -0.2143 slicot-5.0+20101122/examples/TC05AD.dat000077500000000000000000000003371201767322700167440ustar00rootroot00000000000000 TC05AD EXAMPLE PROGRAM DATA 2 2 (0.0,0.5) L 2 2 2.0 3.0 1.0 4.0 -1.0 -1.0 5.0 7.0 -6.0 3.0 2.0 2.0 6.0 -1.0 5.0 1.0 7.0 5.0 1.0 1.0 1.0 4.0 1.0 -1.0 slicot-5.0+20101122/examples/TC05AD.res000077500000000000000000000002311201767322700167560ustar00rootroot00000000000000 TC05AD EXAMPLE PROGRAM RESULTS RCOND = 0.19 The frequency response matrix T(SVAL) is (-0.25,-0.33) ( 0.26,-0.45) (-1.48, 0.35) (-2.25,-1.11) slicot-5.0+20101122/examples/TD03AD.dat000077500000000000000000000003431201767322700167400ustar00rootroot00000000000000 TD01ND EXAMPLE PROGRAM DATA 2 2 0.0 R L N 3 3 1.0 6.0 11.0 6.0 1.0 6.0 11.0 6.0 1.0 6.0 12.0 7.0 0.0 1.0 4.0 3.0 0.0 0.0 1.0 1.0 1.0 8.0 20.0 15.0 slicot-5.0+20101122/examples/TD03AD.res000077500000000000000000000016721201767322700167670ustar00rootroot00000000000000 TD03AD EXAMPLE PROGRAM RESULTS The order of the resulting minimal realization = 3 The state dynamics matrix A is 0.5000 0.9478 10.1036 0.0000 -1.0000 0.0000 -0.8660 -0.6156 -5.5000 The input/state matrix B is 2.0000 12.5000 0.0000 -5.6273 0.0000 -2.0207 The state/output matrix C is 0.0000 0.0296 -0.5774 0.0000 -0.1481 -0.5774 The direct transmission matrix D is 1.0000 0.0000 0.0000 1.0000 The observability index of the minimal realization = 2 The dimensions of the diagonal blocks of the state dynamics matrix are 2 1 The row degrees of the denominator matrix P(s) are 2 1 The denominator matrix P(s) is 1.6667 4.3333 6.6667 0.3333 5.6667 5.3333 5.6273 5.6273 0.0000 -5.6273 -5.6273 0.0000 The numerator matrix Q(s) is 1.6667 4.3333 8.6667 0.3333 8.0000 16.6667 5.6273 5.6273 0.0000 -5.6273 -11.2546 0.0000 slicot-5.0+20101122/examples/TD04AD.dat000077500000000000000000000003271201767322700167430ustar00rootroot00000000000000 TD04AD EXAMPLE PROGRAM DATA 2 2 0.0 R 3 3 1.0 6.0 11.0 6.0 1.0 6.0 11.0 6.0 1.0 6.0 12.0 7.0 0.0 1.0 4.0 3.0 0.0 0.0 1.0 1.0 1.0 8.0 20.0 15.0 slicot-5.0+20101122/examples/TD04AD.res000077500000000000000000000012411201767322700167600ustar00rootroot00000000000000 TD04AD EXAMPLE PROGRAM RESULTS The order of the minimal realization = 3 The state dynamics matrix A of a minimal realization is 0.5000 -0.8028 0.9387 4.4047 -2.3380 2.5076 -5.5541 1.6872 -4.1620 The input/state matrix B of a minimal realization is -0.2000 -1.2500 0.0000 -0.6097 0.0000 2.2217 The state/output matrix C of a minimal realization is 0.0000 -0.8679 0.2119 0.0000 0.0000 0.9002 The direct transmission matrix D is 1.0000 0.0000 0.0000 1.0000 The observability index of a minimal state-space representation = 2 The dimensions of the diagonal blocks of the state dynamics matrix are 2 1 slicot-5.0+20101122/examples/TD05AD.dat000077500000000000000000000001721201767322700167420ustar00rootroot00000000000000 TD05AD EXAMPLE PROGRAM DATA 6 4 1.0 R C 1.0 1.0 0.0 0.0 2.0 1.0 6.0 2.0 3.0 1.0 slicot-5.0+20101122/examples/TD05AD.res000077500000000000000000000001171201767322700167620ustar00rootroot00000000000000 TD05AD EXAMPLE PROGRAM RESULTS Complex value of G(jW) = 0.8462 -0.2308*j slicot-5.0+20101122/examples/TDE01OD.f000077500000000000000000000032051201767322700165360ustar00rootroot00000000000000* DE01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 CONV * .. Local Arrays .. DOUBLE PRECISION A(NMAX), B(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DE01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, CONV IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( A(I), B(I), I = 1,N ) * Perform convolution on A and B. CALL DE01OD( CONV, N, A, B, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( CONV, 'C' ) ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99996 ) END IF DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DE01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DE01OD = ',I2) 99997 FORMAT (' Convolution ',//' i A(i)',/) 99996 FORMAT (' Deconvolution ',//' i A(i)',/) 99995 FORMAT (I4,1X,F8.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TDE01PD.f000077500000000000000000000032431201767322700165410ustar00rootroot00000000000000* DE01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 CONV, WGHT * .. Local Arrays .. DOUBLE PRECISION A(NMAX), B(NMAX), W(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DE01PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, CONV, WGHT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( A(I), B(I), I = 1,N ) * Perform convolution on A and B. CALL DE01PD( CONV, WGHT, N, A, B, W, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( CONV, 'C' ) ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99996 ) END IF DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DE01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DE01PD = ',I2) 99997 FORMAT (' Convolution ',//' i A(i)',/) 99996 FORMAT (' Deconvolution ',//' i A(i)',/) 99995 FORMAT (I4,1X,F8.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TDF01MD.f000077500000000000000000000035641201767322700165450ustar00rootroot00000000000000* DF01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 129 ) * .. Local Scalars .. DOUBLE PRECISION DT INTEGER I, INFO, N CHARACTER*1 SICO * .. Local Arrays .. DOUBLE PRECISION A(NMAX), DWORK(NMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DF01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DT, SICO IF ( N.LE.1 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,N ) * Compute the sine/cosine transform of the given real signal. CALL DF01MD( SICO, N, DT, A, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( SICO, 'S' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 20 CONTINUE ELSE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 40 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' DF01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DF01MD = ',I2) 99997 FORMAT (' Components of sine transform are',//' i',6X,'A(i)',/) 99996 FORMAT (' Components of cosine transform are',//' i',6X,'A(i)', $ /) 99995 FORMAT (I4,3X,F8.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TDG01MD.f000077500000000000000000000027301201767322700165400ustar00rootroot00000000000000* DG01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 INDI * .. Local Arrays .. DOUBLE PRECISION XI(NMAX), XR(NMAX) * .. External Subroutines .. EXTERNAL DG01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, INDI IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( XR(I), XI(I), I = 1,N ) * Find the Fourier transform of the given complex signal. CALL DG01MD( INDI, N, XR, XI, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, XR(I), XI(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DG01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DG01MD = ',I2) 99997 FORMAT (' Components of Fourier transform are',//' i',6X, $ 'XR(i)',6X,'XI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TDG01ND.f000077500000000000000000000034571201767322700165500ustar00rootroot00000000000000* DG01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, IEND, INFO, N CHARACTER*1 INDI * .. Local Arrays .. DOUBLE PRECISION A(2*NMAX), XI(NMAX+1), XR(NMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DG01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, INDI IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,2*N ) * Copy the odd and even parts of A into XR and XI respectively. DO 20 I = 1, N XR(I) = A(2*I-1) XI(I) = A(2*I) 20 CONTINUE * Find the Fourier transform of the given real signal. CALL DG01ND( INDI, N, XR, XI, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) IEND = N IF ( LSAME( INDI, 'D' ) ) IEND = N + 1 DO 40 I = 1, IEND WRITE ( NOUT, FMT = 99996 ) I, XR(I), XI(I) 40 CONTINUE END IF END IF STOP * 99999 FORMAT (' DG01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DG01ND = ',I2) 99997 FORMAT (' Components of Fourier transform are',//' i',6X, $ 'XR(i)',6X,'XI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TDG01OD.f000077500000000000000000000026051201767322700165430ustar00rootroot00000000000000* DG01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 SCR, WGHT * .. Local Arrays .. DOUBLE PRECISION A(NMAX), W(NMAX) * .. External Subroutines .. EXTERNAL DG01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, SCR, WGHT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,N ) * Compute the Hartley transform. CALL DG01OD( SCR, WGHT, N, A, W, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, A(I) 10 CONTINUE END IF END IF STOP * 99999 FORMAT (' DG01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DG01OD = ',I2) 99997 FORMAT (' Hartley transform ',//' i A(i)',/) 99996 FORMAT (I4,1X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TDK01MD.f000077500000000000000000000026371201767322700165520ustar00rootroot00000000000000* DK01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) * .. Local Scalars .. CHARACTER*1 TYPE INTEGER I, INFO, N * .. Local Arrays .. DOUBLE PRECISION A(NMAX) * .. External Subroutines .. EXTERNAL DK01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TYPE IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,N ) * Apply a Hamming window to the given signal. CALL DK01MD( TYPE, N, A, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, A(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DK01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DK01MD = ',I2) 99997 FORMAT (' Components of the windowing function are',//' k ', $ ' A(k)',/) 99996 FORMAT (I4,3X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TF01MD.dat000077500000000000000000000007231201767322700167560ustar00rootroot00000000000000 TF01MD EXAMPLE PROGRAM DATA 3 2 2 10 0.0000 -0.0700 0.0150 1.0000 0.8000 -0.1500 0.0000 0.0000 0.5000 0.0000 2.0000 1.0000 -1.0000 -0.1000 1.0000 0.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.5000 0.0000 0.5000 1.0000 1.0000 1.0000 -0.6922 -1.4934 0.3081 -2.7726 2.0039 0.2614 -0.9160 -0.6030 1.2556 0.2951 -1.5734 1.5639 -0.9942 1.8957 0.8988 0.4118 -1.4893 -0.9344 1.2506 -0.0701 slicot-5.0+20101122/examples/TF01MD.res000077500000000000000000000006731201767322700170030ustar00rootroot00000000000000 TF01MD EXAMPLE PROGRAM RESULTS The output sequence Y(1),...,Y(10) is Y( 1) : 0.3078 -0.0928 Y( 2) : -1.5125 1.2611 Y( 3) : -1.2577 3.4002 Y( 4) : -0.2947 -0.7060 Y( 5) : -0.5632 5.4532 Y( 6) : -1.0846 1.1846 Y( 7) : -1.2427 2.2286 Y( 8) : 1.8097 -1.9534 Y( 9) : 0.6685 -4.4965 Y(10) : -0.0896 1.1654 slicot-5.0+20101122/examples/TF01ND.dat000077500000000000000000000007311201767322700167560ustar00rootroot00000000000000 TF01ND EXAMPLE PROGRAM DATA 3 2 2 10 U 0.0000 -0.0700 0.0000 1.0000 0.8000 -0.1500 0.0000 0.0000 0.5000 0.0000 2.0000 1.0000 -1.0000 -0.1000 1.0000 0.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.5000 0.0000 0.5000 1.0000 1.0000 1.0000 -0.6922 -1.4934 0.3081 -2.7726 2.0039 0.2614 -0.9160 -0.6030 1.2556 0.2951 -1.5734 1.5639 -0.9942 1.8957 0.8988 0.4118 -1.4893 -0.9344 1.2506 -0.0701 slicot-5.0+20101122/examples/TF01ND.res000077500000000000000000000006731201767322700170040ustar00rootroot00000000000000 TF01ND EXAMPLE PROGRAM RESULTS The output sequence Y(1),...,Y(10) is Y( 1) : 0.3078 -0.0928 Y( 2) : -1.5275 1.2611 Y( 3) : -1.3026 3.4002 Y( 4) : -0.3512 -0.7060 Y( 5) : -0.5922 5.4532 Y( 6) : -1.1693 1.1846 Y( 7) : -1.3029 2.2286 Y( 8) : 1.7529 -1.9534 Y( 9) : 0.6793 -4.4965 Y(10) : -0.0349 1.1654 slicot-5.0+20101122/examples/TF01OD.dat000077500000000000000000000003361201767322700167600ustar00rootroot00000000000000 TF01OD EXAMPLE PROGRAM DATA 2 2 3 3 1.0647 -0.4282 -0.4922 -1.2072 -0.3043 0.6883 -0.0926 0.7167 -0.1844 -0.8507 0.4441 -0.0478 0.7195 0.0500 -0.3955 0.5674 1.3387 -0.2801 0.1073 -0.5315 slicot-5.0+20101122/examples/TF01OD.res000077500000000000000000000006061201767322700170010ustar00rootroot00000000000000 TF01OD EXAMPLE PROGRAM RESULTS The 6 by 6 matrix T is 1.0647 -0.4922 -0.3043 -0.0926 -0.1844 0.4441 -0.4282 -1.2072 0.6883 0.7167 -0.8507 -0.0478 -0.3043 -0.0926 -0.1844 0.4441 0.7195 -0.3955 0.6883 0.7167 -0.8507 -0.0478 0.0500 0.5674 -0.1844 0.4441 0.7195 -0.3955 1.3387 0.1073 -0.8507 -0.0478 0.0500 0.5674 -0.2801 -0.5315 slicot-5.0+20101122/examples/TF01PD.dat000077500000000000000000000003361201767322700167610ustar00rootroot00000000000000 TF01PD EXAMPLE PROGRAM DATA 2 2 3 3 1.0647 -0.4282 -0.4922 -1.2072 -0.3043 0.6883 -0.0926 0.7167 -0.1844 -0.8507 0.4441 -0.0478 0.7195 0.0500 -0.3955 0.5674 1.3387 -0.2801 0.1073 -0.5315 slicot-5.0+20101122/examples/TF01PD.res000077500000000000000000000006061201767322700170020ustar00rootroot00000000000000 TF01PD EXAMPLE PROGRAM RESULTS The 6 by 6 matrix T is -0.1844 0.4441 -0.3043 -0.0926 1.0647 -0.4922 -0.8507 -0.0478 0.6883 0.7167 -0.4282 -1.2072 0.7195 -0.3955 -0.1844 0.4441 -0.3043 -0.0926 0.0500 0.5674 -0.8507 -0.0478 0.6883 0.7167 1.3387 0.1073 0.7195 -0.3955 -0.1844 0.4441 -0.2801 -0.5315 0.0500 0.5674 -0.8507 -0.0478 slicot-5.0+20101122/examples/TF01QD.dat000077500000000000000000000003131201767322700167550ustar00rootroot00000000000000 TF01QD EXAMPLE PROGRAM DATA 8 10 2 2 2 1.0 -0.5 0.6 -0.2 1 1.0 -0.8 3 0.5 -0.4 0.3 0.8 0.4 0.1 4 1.0 0.5 -0.5 0.0 -0.8 0.6 0.0 -0.2 slicot-5.0+20101122/examples/TF01QD.res000077500000000000000000000010031201767322700167730ustar00rootroot00000000000000 TF01QD EXAMPLE PROGRAM RESULTS The Markov Parameters M(1),...,M(8) are M(1) : 1.0000 1.0000 0.5000 1.0000 M(2) : -1.1000 0.8000 -0.8000 1.3000 M(3) : 0.8600 0.6400 0.7400 -0.0600 M(4) : -0.7360 0.5120 -0.3220 -0.8280 M(5) : 0.6136 0.4096 0.0416 -0.4264 M(6) : -0.5154 0.3277 0.0215 0.4157 M(7) : 0.4319 0.2621 -0.0017 0.5764 M(8) : -0.3622 0.2097 -0.0114 0.0461 slicot-5.0+20101122/examples/TF01RD.dat000077500000000000000000000003251201767322700167610ustar00rootroot00000000000000 TF01RD EXAMPLE PROGRAM DATA 5 3 2 2 0.000 -0.070 0.015 1.000 0.800 -0.150 0.000 0.000 0.500 0.000 2.000 1.000 -1.000 -0.100 1.000 0.000 1.000 0.000 0.000 1.000 0.000 slicot-5.0+20101122/examples/TF01RD.res000077500000000000000000000005361201767322700170060ustar00rootroot00000000000000 TF01RD EXAMPLE PROGRAM RESULTS The Markov Parameters M(1),...,M(5) are M(1) : 1.0000 1.0000 0.0000 -1.0000 M(2) : 0.2000 0.5000 2.0000 -0.1000 M(3) : -0.1100 0.2500 1.6000 -0.0100 M(4) : -0.2020 0.1250 1.1400 -0.0010 M(5) : -0.2039 0.0625 0.8000 -0.0001 slicot-5.0+20101122/examples/TFB01QD.f000077500000000000000000000103541201767322700165420ustar00rootroot00000000000000* FB01QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDK, LDQ, LDR, LDS PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDK = NMAX, LDQ = MMAX, LDR = PMAX, $ LDS = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*(PMAX+NMAX)+2*PMAX, $ NMAX*(NMAX+MMAX+2), 3*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBK, MULTBQ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DIAG(PMAX), DWORK(LDWORK), K(LDK,PMAX), $ Q(LDQ,MMAX), R(LDR,PMAX), S(LDS,NMAX) INTEGER IWORK(PMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01QD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBK, TOL, MULTBQ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( LSAME( MULTBQ, 'N' ) ) READ ( NIN, FMT = *) $ ( ( Q(I,J), J = 1,M ), I = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,P ), I = 1,P ) * Save the strict lower triangle of R in its strict upper * triangle and the diagonal in the array DIAG. DO 10 I = 2, P CALL DCOPY( I, R(I,1), LDR, R(1,I), 1 ) 10 CONTINUE CALL DCOPY( P, R, LDR+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter recursion * (in square root covariance form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the lower triangle of R. DO 30 I = 2, P CALL DCOPY( I, R(1,I), 1, R(I,1), LDR ) 30 CONTINUE CALL DCOPY( P, DIAG, 1, R, LDR+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( S(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBK, 'K' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( K(I,J), J = 1,P ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01QD = ',I2) 99997 FORMAT (' The square root of the state covariance matrix is ') 99996 FORMAT (/' The Kalman gain matrix is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TFB01RD.f000077500000000000000000000104171201767322700165430ustar00rootroot00000000000000* FB01RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDK, LDQ, LDR, LDS PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDK = NMAX, $ LDQ = MMAX, LDR = PMAX, LDS = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*(PMAX+NMAX+1), $ NMAX*(PMAX+NMAX)+2*PMAX, $ NMAX*(NMAX+MMAX+2), 3*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBK, MULTBQ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DIAG(PMAX), DWORK(LDWORK), K(LDK,PMAX), $ Q(LDQ,MMAX), R(LDR,PMAX), S(LDS,NMAX) INTEGER IWORK(PMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01RD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBK, TOL, MULTBQ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( LSAME( MULTBQ, 'N' ) ) READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,M ), I = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,P ), I = 1,P ) * Save the strict lower triangle of R in its strict upper * triangle and the diagonal in the array DIAG. DO 10 I = 2, P CALL DCOPY( I, R(I,1), LDR, R(1,I), 1 ) 10 CONTINUE CALL DCOPY( P, R, LDR+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter recursion * (in square root covariance form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the lower triangle of R. DO 30 I = 2, P CALL DCOPY( I, R(1,I), 1, R(I,1), LDR ) 30 CONTINUE CALL DCOPY( P, DIAG, 1, R, LDR+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( S(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBK, 'K' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( K(I,J), J = 1,P ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01QD = ',I2) 99997 FORMAT (' The square root of the state covariance matrix is ') 99996 FORMAT (/' The Kalman gain matrix is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TFB01SD.f000077500000000000000000000114051201767322700165420ustar00rootroot00000000000000* FB01SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV PARAMETER ( LDAINV = NMAX, LDB = NMAX, LDC = PMAX, $ LDQINV = MMAX, LDRINV = PMAX, LDSINV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*(NMAX + 2*MMAX) + 3*MMAX, $ (NMAX + PMAX)*(NMAX + 1) + 2*NMAX, $ 3*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBX, MULTAB, MULTRC * .. Local Arrays .. DOUBLE PRECISION AINV(LDAINV,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DIAG(MMAX), DWORK(LDWORK), E(PMAX), $ QINV(LDQINV,MMAX), RINV(LDRINV,PMAX), $ RINVY(PMAX), SINV(LDSINV,NMAX), X(NMAX), Z(MMAX) INTEGER IWORK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01SD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBX, TOL, MULTAB, MULTRC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( AINV(I,J), J = 1,N ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( MULTRC, 'N' ) ) READ ( NIN, FMT = * ) $ ( ( RINV(I,J), J = 1,P ), I = 1,P ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QINV(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( SINV(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( Z(J), J = 1,M ) READ ( NIN, FMT = * ) ( X(J), J = 1,N ) READ ( NIN, FMT = * ) ( RINVY(J), J = 1,P ) * Save the strict upper triangle of QINV in its strict * lower triangle and the diagonal in the array DIAG. DO 10 I = 2, M CALL DCOPY( I, QINV(1,I), 1, QINV(I,1), LDQINV ) 10 CONTINUE CALL DCOPY( M, QINV, LDQINV+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter recursion * (in square root information form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the upper triangle of QINV. DO 30 I = 2, M CALL DCOPY( I, QINV(I,1), LDQINV, QINV(1,I), 1 ) 30 CONTINUE CALL DCOPY( M, DIAG, 1, QINV, LDQINV+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( SINV(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBX, 'X' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99994 ) I, X(I) 50 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01SD = ',I2) 99997 FORMAT (' The inverse of the square root of the state covariance', $ ' matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The components of the estimated filtered state are ', $ //' k X(k)',/) 99994 FORMAT (I4,3X,F8.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TFB01TD.f000077500000000000000000000115441201767322700165470ustar00rootroot00000000000000* FB01TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDAINB, LDAINV, LDC, LDQINV, LDRINV, LDSINV PARAMETER ( LDAINB = NMAX, LDAINV = NMAX, LDC = PMAX, $ LDQINV = MMAX, LDRINV = PMAX, LDSINV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*(NMAX + 2*MMAX) + 3*MMAX, $ (NMAX + PMAX)*(NMAX + 1) + NMAX + $ MAX( NMAX - 1, MMAX + 1 ), $ 3*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBX, MULTRC * .. Local Arrays .. DOUBLE PRECISION AINV(LDAINV,NMAX), AINVB(LDAINB,MMAX), $ C(LDC,NMAX), DIAG(MMAX), DWORK(LDWORK), E(PMAX), $ QINV(LDQINV,MMAX), RINV(LDRINV,PMAX), $ RINVY(PMAX), SINV(LDSINV,NMAX), X(NMAX), Z(MMAX) INTEGER IWORK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01TD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBX, TOL, MULTRC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( AINV(I,J), J = 1,N ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( MULTRC, 'N' ) ) READ ( NIN, FMT = * ) $ ( ( RINV(I,J), J = 1,P ), I = 1,P ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) $ ( ( AINVB(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QINV(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( SINV(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( Z(J), J = 1,M ) READ ( NIN, FMT = * ) ( X(J), J = 1,N ) READ ( NIN, FMT = * ) ( RINVY(J), J = 1,P ) * Save the strict upper triangle of QINV in its strict * lower triangle and the diagonal in the array DIAG. DO 10 I = 2, M CALL DCOPY( I, QINV(1,I), 1, QINV(I,1), LDQINV ) 10 CONTINUE CALL DCOPY( M, QINV, LDQINV+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter * recursion (in square root information form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the upper triangle of QINV. DO 30 I = 2, M CALL DCOPY( I, QINV(I,1), LDQINV, QINV(1,I), 1 ) 30 CONTINUE CALL DCOPY( M, DIAG, 1, QINV, LDQINV+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( SINV(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBX, 'X' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99994 ) I, X(I) 50 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01TD = ',I2) 99997 FORMAT (' The inverse of the square root of the state covariance', $ ' matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The components of the estimated filtered state are ', $ //' k X(k)',/) 99994 FORMAT (I4,3X,F8.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TFB01VD.f000077500000000000000000000066711201767322700165560ustar00rootroot00000000000000* FB01VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, LMAX PARAMETER ( NMAX = 20, MMAX = 20, LMAX = 20 ) INTEGER LDA, LDB, LDC, LDK, LDP, LDQ, LDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = LMAX, LDK = NMAX, $ LDP = NMAX, LDQ = MMAX, LDR = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( LMAX*NMAX + 3*LMAX, NMAX*NMAX, $ MMAX*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, L, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), K(LDK,LMAX), P(LDP,NMAX), $ Q(LDQ,MMAX), R(LDR,LMAX) INTEGER IWORK(LMAX) * .. External Subroutines .. EXTERNAL DCOPY, FB01VD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, L, TOL IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( P(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,M ), I = 1,M ) IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99991 ) L ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,L ), I = 1,L ) * Perform one iteration of the (Kalman) filter recursion. CALL FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, $ Q, LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N CALL DCOPY( I-1, P(1,I), 1, P(I,1), LDP ) WRITE ( NOUT, FMT = 99994 ) ( P(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( K(I,J), J = 1,L ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, L WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1,L ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01VD = ',I3) 99997 FORMAT (' The state covariance matrix is ') 99996 FORMAT (/' The Kalman filter gain matrix is ') 99995 FORMAT (/' The square root of the covariance matrix of the innov', $ 'ations is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' L is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TFD01AD.f000077500000000000000000000100241201767322700165160ustar00rootroot00000000000000* FD01AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT, NOUT1 PARAMETER ( NIN = 5, NOUT = 6, NOUT1 = 7 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER IMAX, LMAX PARAMETER ( IMAX = 500, LMAX = 10 ) DOUBLE PRECISION LAMBDA PARAMETER ( LAMBDA = 0.99D0 ) * .. Local Scalars .. CHARACTER JP INTEGER I, INFO, IWARN, L DOUBLE PRECISION DELTA, EFOR, EOUT, EPOS, XIN, YIN * .. Local Arrays .. DOUBLE PRECISION CTETA(LMAX), EPSBCK(LMAX+1), SALPH(LMAX), $ STETA(LMAX), XF(LMAX), YQ(LMAX) * .. External Functions .. DOUBLE PRECISION XFCN, YFCN EXTERNAL XFCN, YFCN * NOTE: XFCN() generates at each iteration the next sample of the * input sequence. YFCN() generates at each iteration the next * sample of the reference sequence. These functions are user * defined (obtained from data acquisition devices, for * example). * .. External Subroutines .. EXTERNAL FD01AD * * .. File for the output error sequence .. OPEN ( UNIT = NOUT1, FILE = 'ERR.OUT', STATUS = 'REPLACE' ) * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, DELTA, JP IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE IF ( DELTA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99991 ) ELSE * DO 10 I = 1, L CTETA(I) = ONE STETA(I) = ZERO EPSBCK(I) = ZERO XF(I) = ZERO YQ(I) = ZERO 10 CONTINUE EPSBCK(L+1) = ONE EFOR = DELTA * .. Run least squares filter. DO 20 I = 1, IMAX XIN = XFCN(I) YIN = YFCN(I) CALL FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK, $ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN, $ INFO) WRITE(NOUT1,*) EOUT 20 CONTINUE CLOSE(NOUT1) * NOTE: File 'ERR.OUT' now contains the output error * sequence. * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99996 ) I, XF(I), YQ(I), EPSBCK(I) 30 CONTINUE WRITE ( NOUT, FMT = 99995 ) L+1, EPSBCK(L+1) WRITE ( NOUT, FMT = 99994 ) EFOR IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99993 ) IWARN END IF END IF END IF END IF STOP * 99999 FORMAT (' FD01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from FD01AD = ', I2) 99997 FORMAT (' i', 7X, 'XF(i)', 7X, 'YQ(i)', 6X, 'EPSBCK(i)', /1X) 99996 FORMAT ( I3, 2X, 3(2X, F10.6)) 99995 FORMAT ( I3, 28X, F10.6, /1X) 99994 FORMAT (' EFOR = ', D10.3) 99993 FORMAT (' IWARN on exit from FD01AD = ', I2) 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' The exponentially weighted forward prediction error', $ ' energy must be non-negative.' ) * END * * .. Example functions .. * DOUBLE PRECISION FUNCTION XFCN( I ) * .. Intrinsic Functions .. INTRINSIC DBLE, SIN * .. Local Scalar .. INTEGER I * .. Executable Statements .. XFCN = SIN( 0.3D0*DBLE( I ) ) * *** Last line of XFCN *** END * DOUBLE PRECISION FUNCTION YFCN( I ) * .. Intrinsic Functions .. INTRINSIC DBLE, SIN * .. Local Scalar .. INTEGER I * .. Executable Statements .. YFCN = 0.5D0 * SIN( 0.3D0*DBLE( I ) ) + $ 2.0D0 * SIN( 0.3D0*DBLE( I-1 ) ) * *** Last line of YFCN *** END slicot-5.0+20101122/examples/TG01AD.dat000077500000000000000000000010211201767322700167330ustar00rootroot00000000000000TG01AD EXAMPLE PROGRAM DATA 4 4 2 2 A 0.0 -1 0 0 0.003 0 0 0.1000 0.02 100 10 0 0.4 0 0 0 0.0 1 0.2 0 0.0 0 1 0 0.01 300 90 6 0.3 0 0 20 0.0 10 0 0 0 0 1000 10000 10000 -0.1 0.0 0.001 0.0 0.0 0.01 -0.001 0.0001 slicot-5.0+20101122/examples/TG01AD.res000077500000000000000000000020421201767322700167600ustar00rootroot00000000000000 TG01AD EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix Dl*A*Dr is -1.0000 0.0000 0.0000 0.3000 0.0000 0.0000 1.0000 2.0000 1.0000 0.1000 0.0000 0.4000 0.0000 0.0000 0.0000 0.0000 The transformed descriptor matrix Dl*E*Dr is 1.0000 0.2000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 3.0000 0.9000 0.6000 0.3000 0.0000 0.0000 0.2000 0.0000 The transformed input/state matrix Dl*B is 100.0000 0.0000 0.0000 0.0000 0.0000 100.0000 100.0000 100.0000 The transformed state/output matrix C*Dr is -0.0100 0.0000 0.0010 0.0000 0.0000 0.0010 -0.0010 0.0010 The diagonal of left scaling matrix Dl is 10.0000 10.0000 0.1000 0.0100 The diagonal of right scaling matrix Dr is 0.1000 0.1000 1.0000 10.0000 Norm of [ A B; C 0] = 1.100D+04 Norm of scaled [ A B; C 0] = 2.000D+02 Norm of E = 3.010D+02 Norm of scaled E = 4.000D+00 slicot-5.0+20101122/examples/TG01AZ.dat000077500000000000000000000012201201767322700167620ustar00rootroot00000000000000TG01AZ EXAMPLE PROGRAM DATA 4 4 2 2 A 0.0 (-1,0) (0,0) (0,0) (0.003,0) (0,0) (0,0) (0.1000,0) (0.02,0) (100,0) (10,0) (0,0) (0.4,0) (0,0) (0,0) (0,0) (0.0,0) (1,0) (0.2,0) (0,0) (0.0,0) (0,0) (1,0) (0,0) ( 0.01,0) (300,0) (90,0) (6,0) (0.3,0) (0,0) (0,0) (20,0) (0.0,0) (10,0) (0,0) (0,0) (0,0) (0,0) (1000,0) (10000,0) (10000,0) (-0.1,0) (0.0,0) (0.001,0) (0.0,0) (0.0,0) (0.01,0) (-0.001,0) (0.0001,0) slicot-5.0+20101122/examples/TG01AZ.res000077500000000000000000000030621201767322700170110ustar00rootroot00000000000000 TG01AZ EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix Dl*A*Dr is -1.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.3000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 1.0000 +0.0000i 2.0000 +0.0000i 1.0000 +0.0000i 0.1000 +0.0000i 0.0000 +0.0000i 0.4000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i The transformed descriptor matrix Dl*E*Dr is 1.0000 +0.0000i 0.2000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 1.0000 +0.0000i 0.0000 +0.0000i 1.0000 +0.0000i 3.0000 +0.0000i 0.9000 +0.0000i 0.6000 +0.0000i 0.3000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.2000 +0.0000i 0.0000 +0.0000i The transformed input/state matrix Dl*B is 100.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 100.0000 +0.0000i 100.0000 +0.0000i 100.0000 +0.0000i The transformed state/output matrix C*Dr is -0.0100 +0.0000i 0.0000 +0.0000i 0.0010 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0010 +0.0000i -0.0010 +0.0000i 0.0010 +0.0000i The diagonal of left scaling matrix Dl is 10.0000 10.0000 0.1000 0.0100 The diagonal of right scaling matrix Dr is 0.1000 0.1000 1.0000 10.0000 Norm of [ A B; C 0] = 1.100D+04 Norm of scaled [ A B; C 0] = 2.000D+02 Norm of E = 3.010D+02 Norm of scaled E = 4.000D+00 slicot-5.0+20101122/examples/TG01CD.dat000077500000000000000000000004621201767322700167450ustar00rootroot00000000000000TG01CD EXAMPLE PROGRAM DATA 4 4 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 1 0 0 0 0 1 1 1 slicot-5.0+20101122/examples/TG01CD.res000077500000000000000000000013341201767322700167650ustar00rootroot00000000000000 TG01CD EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix Q'*A is -0.6325 -0.9487 0.0000 -4.7434 -0.8706 -0.2176 -0.7255 -0.3627 -0.5203 -0.1301 0.3902 1.4307 -0.7559 -0.1890 0.5669 2.0788 The transformed descriptor matrix Q'*E is -3.1623 -9.1706 -5.6921 -2.8460 0.0000 -1.3784 -1.3059 -1.3784 0.0000 0.0000 -2.4279 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed input/state matrix Q'*B is -0.3162 -0.9487 0.6529 -0.2176 -0.4336 -0.9538 1.1339 0.3780 The left transformation matrix Q is -0.3162 0.6529 0.3902 0.5669 0.0000 -0.7255 0.3902 0.5669 -0.9487 -0.2176 -0.1301 -0.1890 0.0000 0.0000 -0.8238 0.5669 slicot-5.0+20101122/examples/TG01DD.dat000077500000000000000000000004601201767322700167440ustar00rootroot00000000000000TG01DD EXAMPLE PROGRAM DATA 4 4 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 -1 0 1 0 0 1 -1 1 slicot-5.0+20101122/examples/TG01DD.res000077500000000000000000000013301201767322700167620ustar00rootroot00000000000000 TG01DD EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix A*Z is 0.4082 3.0773 0.6030 0.0000 0.8165 1.7233 0.6030 -1.0000 2.0412 2.8311 2.4121 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed descriptor matrix E*Z is 0.0000 -0.7385 2.1106 0.0000 0.0000 0.7385 1.2060 0.0000 0.0000 0.0000 9.9499 -6.0000 0.0000 0.0000 0.0000 -2.0000 The transformed input/state matrix C*Z is -0.8165 0.4924 -0.3015 -1.0000 0.0000 0.7385 1.2060 1.0000 The right transformation matrix Z is 0.8165 -0.4924 0.3015 0.0000 -0.4082 -0.1231 0.9045 0.0000 0.0000 0.0000 0.0000 -1.0000 0.4082 0.8616 0.3015 0.0000 slicot-5.0+20101122/examples/TG01ED.dat000077500000000000000000000005531201767322700167500ustar00rootroot00000000000000TG01ED EXAMPLE PROGRAM DATA 4 4 2 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 1 0 0 0 0 1 1 1 -1 0 1 0 0 1 -1 1 slicot-5.0+20101122/examples/TG01ED.res000077500000000000000000000021121201767322700167620ustar00rootroot00000000000000 TG01ED EXAMPLE PROGRAM RESULTS Rank of matrix E = 3 Rank of matrix A22 = 1 The transformed state dynamics matrix Q'*A*Z is 2.1882 -0.8664 -3.5097 -2.1353 -0.4569 -0.2146 1.9802 0.3531 -0.5717 -0.5245 -0.4591 0.4696 -0.4766 -0.5846 2.1414 0.3086 The transformed descriptor matrix Q'*E*Z is 11.8494 0.0000 0.0000 0.0000 0.0000 2.1302 0.0000 0.0000 0.0000 0.0000 1.0270 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed input/state matrix Q'*B is -0.2396 -1.0668 -0.2656 -0.8393 -0.7657 -0.1213 1.1339 0.3780 The transformed state/output matrix C*Z is -0.2499 -1.0573 0.3912 -0.8165 -0.5225 1.3958 0.8825 0.0000 The left transformation matrix Q is -0.1534 0.5377 -0.6049 0.5669 -0.0872 0.2536 0.7789 0.5669 -0.9805 -0.0360 0.0395 -0.1890 -0.0863 -0.8033 -0.1608 0.5669 The right transformation matrix Z is -0.2612 0.2017 -0.4737 0.8165 -0.7780 0.4718 -0.0738 -0.4082 -0.5111 -0.8556 -0.0826 0.0000 -0.2556 0.0684 0.8737 0.4082 slicot-5.0+20101122/examples/TG01FD.dat000077500000000000000000000005531201767322700167510ustar00rootroot00000000000000TG01FD EXAMPLE PROGRAM DATA 4 4 2 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 1 0 0 0 0 1 1 1 -1 0 1 0 0 1 -1 1 slicot-5.0+20101122/examples/TG01FD.res000077500000000000000000000021121201767322700167630ustar00rootroot00000000000000 TG01FD EXAMPLE PROGRAM RESULTS Rank of matrix E = 3 Rank of matrix A22 = 1 The transformed state dynamics matrix Q'*A*Z is 2.0278 0.1078 3.9062 -2.1571 -0.0980 0.2544 1.6053 -0.1269 0.2713 0.7760 -0.3692 -0.4853 0.0690 -0.5669 -2.1974 0.3086 The transformed descriptor matrix Q'*E*Z is 10.1587 5.8230 1.3021 0.0000 0.0000 -2.4684 -0.1896 0.0000 0.0000 0.0000 1.0338 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed input/state matrix Q'*B is -0.2157 -0.9705 0.3015 0.9516 0.7595 0.0991 1.1339 0.3780 The transformed state/output matrix C*Z is 0.3651 -1.0000 -0.4472 -0.8165 -1.0954 1.0000 -0.8944 0.0000 The left transformation matrix Q is -0.2157 -0.5088 0.6109 0.5669 -0.1078 -0.2544 -0.7760 0.5669 -0.9705 0.1413 -0.0495 -0.1890 0.0000 0.8102 0.1486 0.5669 The right transformation matrix Z is -0.3651 0.0000 0.4472 0.8165 -0.9129 0.0000 0.0000 -0.4082 0.0000 -1.0000 0.0000 0.0000 -0.1826 0.0000 -0.8944 0.4082 slicot-5.0+20101122/examples/TG01FZ.dat000077500000000000000000000010531201767322700167730ustar00rootroot00000000000000TG01FZ EXAMPLE PROGRAM DATA 4 4 2 2 0.0 (-1,0) (0,0) (0,0) (3,0) (0,0) (0,0) (1,0) (2,0) (1,0) (1,0) (0,0) (4,0) (0,0) (0,0) (0,0) (0,0) (1,0) (2,0) (0,0) (0,0) (0,0) (1,0) (0,0) (1,0) (3,0) (9,0) (6,0) (3,0) (0,0) (0,0) (2,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (1,0) (1,0) (1,0) (-1,0) (0,0) (1,0) (0,0) (0,0) (1,0) (-1,0) (1,0) slicot-5.0+20101122/examples/TG01FZ.res000077500000000000000000000035521201767322700170220ustar00rootroot00000000000000 TG01FZ EXAMPLE PROGRAM RESULTS Rank of matrix E = 3 Rank of matrix A22 = 1 The transformed state dynamics matrix Q'*A*Z is 2.0278 +0.0000i 0.1078 +0.0000i 3.9062 +0.0000i -2.1571 +0.0000i -0.0980 +0.0000i 0.2544 +0.0000i 1.6053 +0.0000i -0.1269 +0.0000i 0.2713 +0.0000i 0.7760 +0.0000i -0.3692 +0.0000i -0.4853 +0.0000i 0.0690 +0.0000i -0.5669 +0.0000i -2.1974 +0.0000i 0.3086 +0.0000i The transformed descriptor matrix Q'*E*Z is 10.1587 +0.0000i 5.8230 +0.0000i 1.3021 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i -2.4684 +0.0000i -0.1896 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 1.0338 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i The transformed input/state matrix Q'*B is -0.2157 +0.0000i -0.9705 +0.0000i 0.3015 +0.0000i 0.9516 +0.0000i 0.7595 +0.0000i 0.0991 +0.0000i 1.1339 +0.0000i 0.3780 +0.0000i The transformed state/output matrix C*Z is 0.3651 +0.0000i -1.0000 +0.0000i -0.4472 +0.0000i -0.8165 +0.0000i -1.0954 +0.0000i 1.0000 +0.0000i -0.8944 +0.0000i 0.0000 +0.0000i The left transformation matrix Q is -0.2157 +0.0000i -0.5088 +0.0000i 0.6109 +0.0000i 0.5669 +0.0000i -0.1078 +0.0000i -0.2544 +0.0000i -0.7760 +0.0000i 0.5669 +0.0000i -0.9705 +0.0000i 0.1413 +0.0000i -0.0495 +0.0000i -0.1890 +0.0000i 0.0000 +0.0000i 0.8102 +0.0000i 0.1486 +0.0000i 0.5669 +0.0000i The right transformation matrix Z is -0.3651 +0.0000i 0.0000 +0.0000i 0.4472 +0.0000i 0.8165 +0.0000i -0.9129 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i -0.4082 +0.0000i 0.0000 +0.0000i -1.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i -0.1826 +0.0000i 0.0000 +0.0000i -0.8944 +0.0000i 0.4082 +0.0000i slicot-5.0+20101122/examples/TG01HD.dat000077500000000000000000000015561201767322700167570ustar00rootroot00000000000000TG01HD EXAMPLE PROGRAM DATA 7 3 2 0.0 C 2 0 2 0 -1 3 1 0 1 0 0 1 0 0 0 0 0 1 0 0 1 0 0 2 0 -1 3 1 0 0 0 1 0 0 1 0 1 0 0 1 0 0 0 0 0 1 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 -1 0 0 1 3 0 2 0 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 3 1 0 0 1 0 0 1 0 -1 1 0 -1 1 0 slicot-5.0+20101122/examples/TG01HD.res000077500000000000000000000050051201767322700167710ustar00rootroot00000000000000 TG01HD EXAMPLE PROGRAM RESULTS Dimension of controllable part = 3 Number of uncontrollable infinite eigenvalues = 1 The staircase form row dimensions are 2 1 The transformed state dynamics matrix Q'*A*Z is 0.0000 0.0000 0.0000 0.0000 -1.2627 0.4334 0.4666 0.0000 2.0000 0.0000 -3.7417 -0.8520 0.2924 -0.4342 0.0000 0.0000 1.7862 0.3780 -0.2651 -0.7723 0.0000 0.0000 0.0000 0.0000 3.7417 0.8520 -0.2924 0.4342 0.0000 0.0000 0.0000 0.0000 -1.5540 0.5334 0.5742 0.0000 0.0000 0.0000 0.0000 -0.6533 0.2242 0.2414 0.0000 0.0000 0.0000 0.0000 -0.5892 0.2022 0.2177 The transformed descriptor matrix Q'*E*Z is -1.8325 1.0000 2.3752 0.0000 -0.8214 0.2819 1.8016 0.4887 0.0000 0.3770 -0.5345 0.1874 0.5461 0.0000 -0.1728 0.0000 -0.1333 -1.1339 0.1325 0.3861 0.0000 0.0000 0.0000 0.0000 0.0000 0.8520 -0.2924 0.4342 0.0000 0.0000 0.0000 0.0000 -1.0260 -0.1496 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.1937 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 The transformed input/state matrix Q'*B is 1.0000 2.0000 3.0000 2.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed state/output matrix C*Z is 0.0000 1.0000 0.0000 0.0000 -1.2627 0.4334 0.4666 0.3665 0.0000 -0.9803 -1.6036 0.1874 0.5461 0.0000 The left transformation matrix Q is 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.7071 0.0000 0.2740 -0.6519 0.0000 0.0000 0.0000 0.0000 0.0000 0.8304 0.3491 -0.4342 0.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.4003 0.1683 0.9008 0.0000 0.0000 0.7071 0.0000 -0.2740 0.6519 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The right transformation matrix Z is 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.6108 0.0000 0.7917 0.0000 0.0000 0.0000 0.0000 0.4887 0.0000 0.3770 -0.5345 0.1874 0.5461 0.0000 0.0000 0.0000 0.0000 0.0000 -0.4107 0.1410 0.9008 0.6108 0.0000 0.4713 0.2673 -0.1874 -0.5461 0.0000 -0.1222 0.0000 -0.0943 -0.8018 -0.1874 -0.5461 0.0000 0.0000 0.0000 0.0000 0.0000 -0.8520 0.2924 -0.4342 slicot-5.0+20101122/examples/TG01ID.dat000077500000000000000000000015571201767322700167610ustar00rootroot00000000000000TG01ID EXAMPLE PROGRAM DATA 7 2 3 0.0 O 2 0 0 0 0 0 0 0 1 0 0 0 1 0 2 0 0 2 0 0 0 0 0 1 0 1 0 1 -1 1 0 -1 0 1 0 3 0 0 3 0 0 0 1 0 1 1 1 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 3 1 0 0 0 0 1 0 0 0 0 0 1 0 2 0 0 0 0 0 -1 0 0 1 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 -1 0 1 1 0 0 -1 0 1 1 0 2 0 0 0 0 0 1 1 0 0 0 0 0 2 0 0 0 0 0 0 3 slicot-5.0+20101122/examples/TG01ID.res000077500000000000000000000050051201767322700167720ustar00rootroot00000000000000 TG01ID EXAMPLE PROGRAM RESULTS Dimension of observable part = 3 Number of unobservable infinite eigenvalues = 1 The staircase form column dimensions are 2 1 The transformed state dynamics matrix Q'*A*Z is 0.2177 0.2414 0.5742 0.4342 0.0000 -0.4342 0.4666 0.2022 0.2242 0.5334 -0.2924 -0.7723 0.2924 0.4334 -0.5892 -0.6533 -1.5540 0.8520 -0.2651 -0.8520 -1.2627 0.0000 0.0000 0.0000 3.7417 0.3780 -3.7417 0.0000 0.0000 0.0000 0.0000 0.0000 1.7862 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed descriptor matrix Q'*E*Z is 1.0000 0.0000 0.0000 0.4342 0.0000 0.0000 1.8016 0.0000 1.1937 -0.1496 -0.2924 0.3861 0.5461 0.2819 0.0000 0.0000 -1.0260 0.8520 0.1325 0.1874 -0.8214 0.0000 0.0000 0.0000 0.0000 -1.1339 -0.5345 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1333 0.3770 2.3752 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -0.1728 0.4887 -1.8325 The transformed input/state matrix Q'*B is 0.4666 0.0000 0.4334 0.5461 -1.2627 0.1874 0.0000 -1.6036 0.0000 -0.9803 1.0000 0.0000 0.0000 0.3665 The transformed state/output matrix C*Z is 0.0000 0.0000 0.0000 0.0000 0.0000 2.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.0000 The left transformation matrix Q is 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.7917 0.0000 -0.6108 0.0000 0.5461 0.1874 -0.5345 0.3770 0.0000 0.4887 0.9008 0.1410 -0.4107 0.0000 0.0000 0.0000 0.0000 0.0000 -0.5461 -0.1874 0.2673 0.4713 0.0000 0.6108 0.0000 -0.5461 -0.1874 -0.8018 -0.0943 0.0000 -0.1222 -0.4342 0.2924 -0.8520 0.0000 0.0000 0.0000 0.0000 The right transformation matrix Z is 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 -0.6519 0.2740 0.0000 0.7071 0.0000 0.0000 -0.4342 0.3491 0.8304 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.9008 0.1683 0.4003 0.0000 0.0000 0.0000 0.0000 0.0000 0.6519 -0.2740 0.0000 0.7071 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples/TG01JD.dat000077500000000000000000000024001201767322700167460ustar00rootroot00000000000000TG01JD EXAMPLE PROGRAM DATA 9 2 2 0.0 I R N -2 -3 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 -2 -3 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 1 0 0 -1 0 0 0 0 -1 0 0 0 0 1 0 1 -3 0 1 0 2 0 0 1 1 3 0 1 0 0 1 slicot-5.0+20101122/examples/TG01JD.res000077500000000000000000000030651201767322700167770ustar00rootroot00000000000000 TG01JD EXAMPLE PROGRAM RESULTS Order of reduced system = 7 Achieved order reductions in different phases Phase 1: 0 elliminated eigenvalue(s) Phase 2: 0 elliminated eigenvalue(s) Phase 3: 2 elliminated eigenvalue(s) Phase 4: 0 elliminated eigenvalue(s) The reduced state dynamics matrix Ar is 1.0000 -0.0393 -0.0980 -0.1066 0.0781 -0.2330 0.0777 0.0000 1.0312 0.2717 0.2609 -0.1533 0.6758 -0.3553 0.0000 0.0000 1.3887 0.6699 -0.4281 1.6389 -0.7615 0.0000 0.0000 0.0000 -1.2147 0.2423 -0.9792 0.4788 0.0000 0.0000 0.0000 0.0000 -1.0545 0.5035 -0.2788 0.0000 0.0000 0.0000 0.0000 0.0000 1.6355 -0.4323 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 The reduced descriptor matrix Er is 0.4100 0.2590 0.5080 -0.3109 0.0705 0.1429 -0.1477 -0.7629 -0.3464 0.0992 -0.3007 0.0619 0.2483 -0.0152 0.1120 -0.2124 -0.4184 -0.1288 0.0569 -0.4213 -0.6182 0.0000 0.1122 -0.0039 0.2771 -0.0758 0.0975 0.3923 0.0000 0.0000 0.3708 -0.4290 0.1006 0.1402 -0.2699 0.0000 0.0000 0.0000 0.0000 0.9458 -0.2211 0.2378 0.0000 0.0000 0.0000 0.5711 0.2648 0.5948 -0.5000 The reduced input/state matrix Br is -0.5597 0.2363 -0.4843 -0.0498 -0.4727 -0.1491 0.1802 1.1574 0.5995 0.1556 -0.1729 -0.3999 0.0000 0.2500 The reduced state/output matrix Cr is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 4.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.1524 -1.7500 slicot-5.0+20101122/examples/TIB01AD.f000077500000000000000000000111551201767322700165250ustar00rootroot00000000000000* IB01AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDR, LDU, LDWORK, LDY, LIWORK, LMAX, MMAX, $ NOBRMX, NSMPMX PARAMETER ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000, $ LDR = MAX( 2*( MMAX + LMAX )*NOBRMX, $ 3*MMAX*NOBRMX ), LDU = NSMPMX, $ LDWORK = MAX( 6*( MMAX + LMAX )*NOBRMX, $ ( MMAX + LMAX )*( 4*NOBRMX* $ ( MMAX + LMAX + 1 ) + 2*NOBRMX ), $ ( MMAX + LMAX )*4*NOBRMX* $ ( NOBRMX + 1 ) ), $ LDY = NSMPMX, LIWORK = ( MMAX + LMAX )*NOBRMX ) * .. Local Scalars .. LOGICAL NGIVEN CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH INTEGER I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE, $ NGIV, NOBR, NSAMPL, NSMP DOUBLE PRECISION RCOND, TOL * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), R(LDR, 2*(MMAX+LMAX)*NOBRMX), $ SV(LMAX*NOBRMX), U(LDU, MMAX), Y(LDY, LMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB01AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * If the value of N is positive, it will be taken as system order. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL, METH, ALG, $ JOBD, BATCH, CONCT, CTRL IF ( LSAME( BATCH, 'F' ) ) THEN READ ( NIN, FMT = * ) NCYCLE ELSE NCYCLE = 1 END IF NSAMPL = NCYCLE*NSMP * NGIVEN = N.GT.0 IF( NGIVEN ) $ NGIV = N IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99997 ) NOBR ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99995 ) L ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR. $ ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'O' ) ) .OR. $ ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'L' ) ) .OR. $ NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR. $ LSAME( BATCH, 'I' ) ) ) THEN WRITE ( NOUT, FMT = 99994 ) NSMP ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN WRITE ( NOUT, FMT = 99993 ) NCYCLE ELSE * Read the matrices U and Y from the input file. IF ( M.GT.0 ) $ READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1, M ), I = 1, NSAMPL ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL ) * Compute the R factor from a QR (or Cholesky) factorization * of the Hankel-like matrix (or correlation matrix). DO 10 ICYCLE = 1, NCYCLE II = ( ICYCLE - 1 )*NSMP + 1 IF ( NCYCLE.GT.1 ) THEN IF ( ICYCLE.GT.1 ) BATCH = 'I' IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L' END IF CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, $ L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR, $ SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN, $ INFO ) 10 CONTINUE IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99990 ) IWARN IF( NGIVEN ) $ N = NGIV WRITE ( NOUT, FMT = 99992 ) N WRITE ( NOUT, FMT = 99991 ) ( SV(I), I = 1,L*NOBR ) END IF END IF STOP 99999 FORMAT ( ' IB01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT ( ' INFO on exit from IB01AD = ',I2) 99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5) 99996 FORMAT (/' M is out of range.',/' M = ', I5) 99995 FORMAT (/' L is out of range.',/' L = ', I5) 99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5) 99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5) 99992 FORMAT ( ' The order of the system is ', I5) 99991 FORMAT ( ' The singular values are ',/ (8(1X,F8.4))) 99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2) END slicot-5.0+20101122/examples/TIB01BD.f000077500000000000000000000237031201767322700165300ustar00rootroot00000000000000* IB01BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDA, LDB, LDC, LDD, LDK, LDQ, LDR, LDRY, LDS, $ LDU, LDW1, LDW2, LDW3, LDWORK, LDY, LIWORK, LMAX, $ MMAX, NMAX, NOBRMX, NSMPMX PARAMETER ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000, $ NMAX = NOBRMX - 1, LDA = NMAX, LDB = NMAX, $ LDC = LMAX, LDD = LMAX, LDK = NMAX, $ LDQ = NMAX, LDRY = LMAX, LDS = NMAX, $ LDR = MAX( 2*( MMAX + LMAX )*NOBRMX, $ 3*MMAX*NOBRMX ), LDU = NSMPMX, $ LDW1 = MAX( LMAX*( NOBRMX - 1 )*NMAX + NMAX + $ MAX( 6*MMAX, 4*LMAX )*NOBRMX, $ LMAX*NOBRMX*NMAX + $ MAX( LMAX*( NOBRMX - 1 )*NMAX + $ 3*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX, $ 2*LMAX*( NOBRMX - 1 )*NMAX + $ NMAX*NMAX + 8*NMAX, $ NMAX + $ 4*( MMAX*NOBRMX + NMAX ) ) ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ MAX( ( NMAX + LMAX )**2, $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW3 = MAX( 4*NMAX*NMAX + 2*NMAX*LMAX + $ LMAX*LMAX + $ MAX( 3*LMAX, NMAX*LMAX ), $ 14*NMAX*NMAX + 12*NMAX + 5 ), $ LDWORK = MAX( 6*( MMAX + LMAX )*NOBRMX, $ ( MMAX + LMAX )*( 4*NOBRMX* $ ( MMAX + LMAX + 2 ) - 2 ), $ ( MMAX + LMAX )*4*NOBRMX* $ ( NOBRMX + 1 ), LDW1, LDW2, $ LDW3 ), $ LDY = NSMPMX, $ LIWORK = MAX( ( MMAX + LMAX )*NOBRMX, $ MMAX*NOBRMX + NMAX, LMAX*NOBRMX, $ MMAX*( NMAX + LMAX ), NMAX*NMAX ) $ ) * .. Local Scalars .. LOGICAL NGIVEN CHARACTER ALG, BATCH, CONCT, CTRL, JOB, JOBCK, JOBD, JOBDA, $ METH, METHA INTEGER I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE, $ NGIV, NOBR, NSAMPL, NSMP DOUBLE PRECISION RCOND, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, MMAX), C(LDC, NMAX), $ D(LDD, MMAX), DWORK(LDWORK), K(LDK, LMAX), $ Q(LDQ, NMAX), R(LDR, 2*(MMAX+LMAX)*NOBRMX), $ RY(LDRY, LMAX), S(LDS, LMAX), SV(LMAX*NOBRMX), $ U(LDU, MMAX), Y(LDY, LMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(2*NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB01AD, IB01BD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * If the value of N is positive, it will be taken as system order. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL READ ( NIN, FMT = * ) METH, ALG, JOBD, BATCH, CONCT, CTRL, JOB, $ JOBCK IF ( LSAME( BATCH, 'F' ) ) THEN READ ( NIN, FMT = * ) NCYCLE ELSE NCYCLE = 1 END IF NSAMPL = NCYCLE*NSMP * NGIVEN = N.GT.0 IF( NGIVEN ) $ NGIV = N IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99997 ) NOBR ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99995 ) L ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR. $ ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'O' ) ) .OR. $ ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'L' ) ) .OR. $ NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR. $ LSAME( BATCH, 'I' ) ) ) THEN WRITE ( NOUT, FMT = 99994 ) NSMP ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN WRITE ( NOUT, FMT = 99993 ) NCYCLE ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99980 ) N ELSE * Read the matrices U and Y from the input file. IF ( M.GT.0 ) $ READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1, M ), I = 1, NSAMPL ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL ) * Read A and C matrices, if METH <> 'M' and JOB = 'B' or 'D'. IF ( .NOT.LSAME( METH, 'M' ) .AND. $ ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'D' ) ) ) THEN DO 10 I = 1, N READ ( NIN, FMT = * ) ( A(I,J), J = 1, N ) 10 CONTINUE DO 20 I = 1, L READ ( NIN, FMT = * ) ( C(I,J), J = 1, N ) 20 CONTINUE END IF * Force some options for IB01AD, depending on the specifications. IF ( LSAME( METH, 'C' ) ) THEN METHA = 'M' JOBDA = 'N' ELSE METHA = METH JOBDA = JOBD END IF * Compute the R factor from a QR (or Cholesky) factorization * of the Hankel-like matrix (or correlation matrix). DO 30 ICYCLE = 1, NCYCLE II = ( ICYCLE - 1 )*NSMP + 1 IF ( NCYCLE.GT.1 ) THEN IF ( ICYCLE.GT.1 ) BATCH = 'I' IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L' END IF CALL IB01AD( METHA, ALG, JOBDA, BATCH, CONCT, CTRL, NOBR, M, $ L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR, $ SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN, $ INFO ) 30 CONTINUE IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99990 ) IWARN IF( NGIVEN ) $ N = NGIV * Compute the system matrices. CALL IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMP, R, $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, $ RY, LDRY, S, LDS, K, LDK, RCOND, IWORK, DWORK, $ LDWORK, BWORK, IWARN, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99992 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99991 ) IWARN IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( A(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( C(I,J), J = 1,N ) 50 CONTINUE END IF IF ( .NOT.LSAME( JOB, 'C' ) ) THEN WRITE ( NOUT, FMT = 99986 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( B(I,J), J = 1,M ) 60 CONTINUE END IF IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'D' ) ) THEN WRITE ( NOUT, FMT = 99985 ) DO 70 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF IF ( LSAME( JOBCK, 'K' ) ) THEN WRITE ( NOUT, FMT = 99984 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( K(I,J), J = 1,L ) 80 CONTINUE END IF IF ( .NOT.LSAME( JOBCK, 'N' ) ) THEN WRITE ( NOUT, FMT = 99983 ) DO 90 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( Q(I,J), J = 1,N ) 90 CONTINUE WRITE ( NOUT, FMT = 99982 ) DO 100 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( RY(I,J), J = 1,L ) 100 CONTINUE WRITE ( NOUT, FMT = 99981 ) DO 110 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( S(I,J), J = 1,L ) 110 CONTINUE END IF END IF END IF END IF STOP 99999 FORMAT ( ' IB01BD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT ( ' INFO on exit from IB01AD = ',I2) 99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5) 99996 FORMAT (/' M is out of range.',/' M = ', I5) 99995 FORMAT (/' L is out of range.',/' L = ', I5) 99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5) 99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5) 99992 FORMAT ( ' INFO on exit from IB01BD = ',I2) 99991 FORMAT ( ' IWARN on exit from IB01BD = ',I2) 99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2) 99989 FORMAT (/' The system state matrix A is ') 99988 FORMAT (20(1X,F8.4)) 99987 FORMAT (/' The system output matrix C is ') 99986 FORMAT (/' The system input matrix B is ') 99985 FORMAT (/' The system input-output matrix D is ') 99984 FORMAT (/' The Kalman gain matrix K is ') 99983 FORMAT (/' The state covariance matrix Q is ') 99982 FORMAT (/' The output covariance matrix Ry is ') 99981 FORMAT (/' The state-output cross-covariance matrix S is ') 99980 FORMAT (/' N is out of range.',/' N = ', I5) END slicot-5.0+20101122/examples/TIB01CD.f000077500000000000000000000254601201767322700165330ustar00rootroot00000000000000* IB01CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDA, LDB, LDC, LDD, LDR, LDU, LDV, LDW1, LDW2, $ LDW4, LDW5, LDWORK, LDY, LIWORK, LMAX, MMAX, $ NMAX, NOBRMX, NSMPMX PARAMETER ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000, $ NMAX = NOBRMX - 1, LDA = NMAX, LDB = NMAX, $ LDC = LMAX, LDD = LMAX, LDV = NMAX, $ LDR = MAX( 2*( MMAX + LMAX )*NOBRMX, $ 3*MMAX*NOBRMX ), LDU = NSMPMX, $ LDW1 = MAX( LMAX*( NOBRMX - 1 )*NMAX + NMAX + $ MAX( 6*MMAX, 4*LMAX )*NOBRMX, $ LMAX*NOBRMX*NMAX + $ MAX( LMAX*( NOBRMX - 1 )*NMAX + $ 3*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX, $ 2*LMAX*( NOBRMX - 1 )*NMAX + $ NMAX*NMAX + 8*NMAX, $ NMAX + $ 4*( MMAX*NOBRMX + NMAX ) ) ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ MAX( ( NMAX + LMAX )**2, $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW4 = NSMPMX*LMAX*NMAX*( MMAX + 1 ) + $ MAX( NMAX + $ MAX( 2*NMAX*NMAX + NMAX, $ MMAX + $ MAX( 2*NMAX*( MMAX + 1 ), $ MMAX ), $ 6*NMAX*( MMAX + 1 ) ), $ 2*MMAX*MMAX*NMAX + 6*MMAX ), $ LDW5 = ( LMAX*MMAX + NMAX*( MMAX + 1 ) )* $ NMAX*( MMAX + 1 ) + $ MAX( ( LMAX*MMAX + $ LMAX*NMAX*( MMAX + 1 ) )* $ NMAX*( MMAX + 1 ) + $ NMAX*NMAX*MMAX + LMAX*NMAX + $ MAX( 2*NMAX*NMAX + NMAX, $ MMAX + $ MAX( 2*NMAX*( MMAX + 1 ), $ MMAX ), $ 6*NMAX*( MMAX + 1 ) ), $ 2*MMAX*MMAX*NMAX + 6*MMAX ), $ LDWORK = MAX( 6*( MMAX + LMAX )*NOBRMX, $ ( MMAX + LMAX )*( 4*NOBRMX* $ ( MMAX + LMAX + 2 ) - 2 ), $ ( MMAX + LMAX )*4*NOBRMX* $ ( NOBRMX + 1 ), LDW1, LDW2, $ 3 + ( NMAX + MMAX + LMAX )*NMAX + $ MAX( 5*NMAX, 3, $ MIN( LDW4, LDW5 ) ) ), $ LDY = NSMPMX, $ LIWORK = MAX( ( MMAX + LMAX )*NOBRMX, $ MMAX*NOBRMX + NMAX, $ MMAX*( NMAX + LMAX ), $ NMAX*MMAX + NMAX, MMAX ) $ ) * .. Local Scalars .. LOGICAL NGIVEN CHARACTER ALG, BATCH, COMUSE, CONCT, CTRL, JOB, JOBBD, $ JOBCK, JOBD, JOBDA, JOBX0, METH, METHA INTEGER I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE, $ NGIV, NOBR, NSAMPL, NSMP DOUBLE PRECISION RCOND, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, MMAX), C(LDC, NMAX), $ D(LDD, MMAX), DUM(1), DWORK(LDWORK), $ R(LDR, 2*(MMAX+LMAX)*NOBRMX), $ SV(LMAX*NOBRMX), U(LDU, MMAX), V(LDV, NMAX), $ X0(NMAX), Y(LDY, LMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB01AD, IB01BD, IB01CD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * If the value of N is positive, it will be taken as system order. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL READ ( NIN, FMT = * ) METH, ALG, JOBD, BATCH, CONCT, CTRL, JOB, $ COMUSE, JOBX0 IF ( LSAME( BATCH, 'F' ) ) THEN READ ( NIN, FMT = * ) NCYCLE ELSE NCYCLE = 1 END IF NSAMPL = NCYCLE*NSMP * NGIVEN = N.GT.0 IF( NGIVEN ) $ NGIV = N IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99997 ) NOBR ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99995 ) L ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR. $ ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'O' ) ) .OR. $ ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'L' ) ) .OR. $ NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR. $ LSAME( BATCH, 'I' ) ) ) THEN WRITE ( NOUT, FMT = 99994 ) NSMP ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN WRITE ( NOUT, FMT = 99993 ) NCYCLE ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99983 ) N ELSE * Read the matrices U and Y from the input file. IF ( M.GT.0 ) $ READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1, M ), I = 1, NSAMPL ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL ) * Force some options, depending on the specifications. IF ( LSAME( METH, 'C' ) ) THEN METHA = 'M' JOBDA = 'N' ELSE METHA = METH JOBDA = JOBD END IF * The covariances and Kalman gain matrix are not computed. JOBCK = 'N' IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN JOBBD = 'D' ELSE JOBBD = JOB END IF IF ( LSAME( COMUSE, 'C' ) ) THEN JOB = 'C' ELSE IF ( LSAME( COMUSE, 'U' ) ) THEN JOB = 'A' END IF * Compute the R factor from a QR (or Cholesky) factorization * of the Hankel-like matrix (or correlation matrix). DO 10 ICYCLE = 1, NCYCLE II = ( ICYCLE - 1 )*NSMP + 1 IF ( NCYCLE.GT.1 ) THEN IF ( ICYCLE.GT.1 ) BATCH = 'I' IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L' END IF CALL IB01AD( METHA, ALG, JOBDA, BATCH, CONCT, CTRL, NOBR, M, $ L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR, $ SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN, $ INFO ) 10 CONTINUE IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99990 ) IWARN IF( NGIVEN ) $ N = NGIV * Compute the system matrices and x0. CALL IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMP, R, $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, DUM, 1, $ DUM, 1, DUM, 1, DUM, 1, RCOND, IWORK, DWORK, $ LDWORK, BWORK, IWARN, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99982 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99981 ) IWARN CALL IB01CD( JOBX0, COMUSE, JOBBD, N, M, L, NSMP, A, LDA, $ B, LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, $ V, LDV, RCOND, IWORK, DWORK, LDWORK, IWARN, $ INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99992 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99991 ) IWARN IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( C(I,J), J = 1,N ) 30 CONTINUE END IF IF ( LSAME( COMUSE, 'C' ) ) THEN WRITE ( NOUT, FMT = 99986 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF ( LSAME( JOBBD, 'D' ) ) THEN WRITE ( NOUT, FMT = 99985 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99988 ) $ ( D(I,J), J = 1,M ) 50 CONTINUE END IF END IF IF ( LSAME( JOBX0, 'X' ) ) THEN WRITE ( NOUT, FMT = 99984 ) WRITE ( NOUT, FMT = 99988 ) ( X0(I), I = 1,N ) END IF END IF END IF END IF END IF STOP 99999 FORMAT ( ' IB01CD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT ( ' INFO on exit from IB01AD = ',I2) 99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5) 99996 FORMAT (/' M is out of range.',/' M = ', I5) 99995 FORMAT (/' L is out of range.',/' L = ', I5) 99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5) 99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5) 99992 FORMAT ( ' INFO on exit from IB01CD = ',I2) 99991 FORMAT ( ' IWARN on exit from IB01CD = ',I2) 99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2) 99989 FORMAT (/' The system state matrix A is ') 99988 FORMAT (20(1X,F8.4)) 99987 FORMAT (/' The system output matrix C is ') 99986 FORMAT (/' The system input matrix B is ') 99985 FORMAT (/' The system input-output matrix D is ') 99984 FORMAT (/' The initial state vector x0 is ') 99983 FORMAT (/' N is out of range.',/' N = ', I5) 99982 FORMAT ( ' INFO on exit from IB01BD = ',I2) 99981 FORMAT ( ' IWARN on exit from IB01BD = ',I2) END slicot-5.0+20101122/examples/TIB03AD.f000077500000000000000000000240711201767322700165300ustar00rootroot00000000000000* IB03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDU, LDY, LIWORK, LMAX, MMAX, NMAX, NNMAX, $ NOBRMX, NSMPMX PARAMETER ( LMAX = 2, MMAX = 3, NOBRMX = 10, NNMAX = 12, $ NMAX = 4, NSMPMX = 1024, $ LDU = NSMPMX, LDY = NSMPMX, $ LIWORK = MAX( MMAX + LMAX, MMAX*NOBRMX + NMAX, $ MMAX*( NMAX + LMAX ) ) ) INTEGER BSNM, L0, L1M, L2M, LDW1, LDW2, LDW3, LDW4, $ LDW5, LDW6, LDW7, LDW8, LDWORK, LTHS, LW1, LW2, $ LW3, LW4, LXM PARAMETER ( BSNM = NNMAX*( LMAX + 2 ) + 1, $ LTHS = NMAX*( LMAX + MMAX + 1 ) + LMAX*MMAX, $ L0 = MAX( NMAX*( NMAX + LMAX ), $ NMAX + MMAX + LMAX ), $ L1M = NSMPMX*LMAX + $ MAX( 2*NNMAX, $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ 2*NMAX + L0 ), $ LXM = BSNM*LMAX + LTHS, $ L2M = MAX( LXM*LXM, 3*LXM + NSMPMX*LMAX ), $ LDW1 = MAX( 2*( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX, $ ( LMAX*NOBRMX - LMAX )*NMAX + $ NMAX*NMAX + 7*NMAX, $ LMAX*NOBRMX*NMAX + $ MAX( ( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX, $ 2*( LMAX*NOBRMX - LMAX )*NMAX $ + NMAX*NMAX + 8*NMAX, $ NMAX + 4*( MMAX*NOBRMX + $ NMAX ) + 1, $ MMAX*NOBRMX + 3*NMAX + LMAX ) $ ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ MAX( ( NMAX + LMAX )**2, $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW3 = NSMPMX*LMAX*( NMAX + 1 ) + 2*NMAX + $ MAX( 2*NMAX*NMAX, 4*NMAX ), $ LDW4 = NMAX*( NMAX + 1 ) + 2*NMAX + $ MAX( NMAX*LMAX*( NMAX + 1 ) + $ 2*NMAX*NMAX + LMAX*NMAX, 4*NMAX ), $ LDW5 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LDW6 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + NMAX + $ MAX( 1, NMAX*NMAX*LMAX + NMAX*LMAX + $ NMAX, NMAX*NMAX + $ MAX( NMAX*NMAX + $ NMAX*MAX( NMAX, LMAX ) + $ 6*NMAX + MIN( NMAX, LMAX ), $ NMAX*MMAX ) ), $ LDW7 = MAX( BSNM*BSNM, 3*BSNM + NSMPMX ), $ LDW8 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LW1 = MAX( 2*( MMAX + LMAX )*NOBRMX* $ ( 2*( MMAX + LMAX )*( NOBRMX + 1 ) $ + 3 ) + LMAX*NOBRMX, $ 4*( MMAX + LMAX )*NOBRMX* $ ( MMAX + LMAX )*NOBRMX + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ MAX( LDW1, LDW2 ), $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ NMAX + NMAX*NMAX + 2 + $ NMAX*( NMAX + MMAX + LMAX ) + $ MAX( 5*NMAX, 2, MIN( LDW3, LDW4 ), $ LDW5, LDW6 ) ), $ LW2 = NSMPMX*LMAX + $ MAX( 5, NSMPMX + 2*BSNM + NSMPMX*BSNM + $ MAX( 2*NNMAX + BSNM, LDW7 ) ), $ LW3 = MAX( LDW8, NSMPMX*LMAX + $ ( NMAX + LMAX )*( 2*NMAX + MMAX )+ $ 2*NMAX ), $ LW4 = MAX( 5, NSMPMX*LMAX + 2*LXM + $ NSMPMX*LMAX*( BSNM + LTHS ) + $ MAX( L1M + LXM, NSMPMX*LMAX + L1M, $ L2M ) ), $ LDWORK = MAX( LW1, LW2, LW3, LW4 ) ) * .. Local Scalars .. LOGICAL INIT1, INITB, INITL, INITN, INITS CHARACTER*1 ALG, INIT, STOR INTEGER BSN, I, INFO, INI, ITER, ITERCG, ITMAX1, ITMAX2, $ IWARN, J, L, L1, L2, LPAR, LX, M, N, NN, NOBR, $ NPRINT, NS, NSMP DOUBLE PRECISION TOL1, TOL2 * .. Array Arguments .. INTEGER IWORK(LIWORK) DOUBLE PRECISION DWORK(LDWORK), U(LDU,MMAX), X(LXM), Y(LDY,LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB03AD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, $ NPRINT, TOL1, TOL2, INIT, ALG, STOR INITL = LSAME( INIT, 'L' ) INITS = LSAME( INIT, 'S' ) INITB = LSAME( INIT, 'B' ) INITN = LSAME( INIT, 'N' ) INIT1 = INITL .OR. INITB IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE NS = N IF( INIT1 ) THEN IF( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99991 ) NOBR STOP ELSEIF( NSMP.LT.2*( M + L + 1 )*NOBR - 1 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.EQ.0 .OR. N.GE.NOBR ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF IF ( N.LT.0 ) $ N = NOBR - 1 ELSE IF( NSMP.LT.0 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF END IF IF( NN.LT.0 .OR. NN.GT.NNMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NN ELSE BSN = NN*( L + 2 ) + 1 L1 = BSN*L L2 = N*( L + M + 1 ) + L*M LX = L1 + L2 INI = 1 IF ( INITL ) THEN LPAR = L1 ELSEIF ( INITS ) THEN INI = L1 + 1 LPAR = L2 ELSEIF ( INITN ) THEN LPAR = LX END IF IF( INIT1 ) $ N = NS * Read the input-output data, initial parameters, and seed. READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,NSMP ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1,L ), I = 1,NSMP ) IF ( .NOT.INITB ) $ READ ( NIN, FMT = * ) ( X(I), I = INI,INI+LPAR-1 ) IF ( INITS .OR. INITB ) $ READ ( NIN, FMT = * ) ( DWORK(I), I = 1,4 ) * Solve a Wiener system identification problem. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99987 ) IWARN ITER = DWORK(3) ITERCG = DWORK(4) WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) ITER, ITERCG, $ IWORK(1), IWORK(2) * Recompute LX is necessary. IF ( INIT1 .AND. NS.LT.0 ) $ LX = L1 + N*( L + M + 1 ) + L*M WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, LX ) END IF END IF END IF END IF STOP * 99999 FORMAT (' IB03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from IB03AD = ',I4) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' Number of iterations = ', I7, $ /' Number of conjugate gradients iterations = ', I7, $ /' Number of function evaluations = ', I7, $ /' Number of Jacobian evaluations = ', I7) 99995 FORMAT (10(1X,F8.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' NOBR is out of range.',/' NOBR = ',I5) 99990 FORMAT (/' NSMP is out of range.',/' NSMP = ',I5) 99989 FORMAT (/' N is out of range.',/' N = ',I5) 99988 FORMAT (/' NN is out of range.',/' NN = ',I5) 99987 FORMAT (' IWARN on exit from IB03AD = ',I4) END slicot-5.0+20101122/examples/TIB03BD.f000077500000000000000000000251251201767322700165320ustar00rootroot00000000000000* IB03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER BSNM, LDU, LDY, LIWORK, LMAX, LTHS, LXM, MMAX, $ NMAX, NNMAX, NOBRMX, NSMPMX PARAMETER ( LMAX = 2, MMAX = 3, NOBRMX = 10, NNMAX = 12, $ NMAX = 4, NSMPMX = 1024, $ BSNM = NNMAX*( LMAX + 2 ) + 1, $ LTHS = NMAX*( LMAX + MMAX + 1 ) + LMAX*MMAX, $ LDU = NSMPMX, LDY = NSMPMX, $ LXM = BSNM*LMAX + LTHS, $ LIWORK = MAX( MMAX + LMAX, MMAX*NOBRMX + NMAX, $ MMAX*( NMAX + LMAX ), 3 + $ MAX( BSNM + 1, LXM + LMAX ) ) ) INTEGER L0, L1M, L2M, L3M, LDW1, LDW2, LDW3, LDW4, LDW5, $ LDW6, LDW7, LDWORK, LW1, LW2, LW3, LW4 PARAMETER ( L0 = MAX( NMAX*( NMAX + LMAX ), $ NMAX + MMAX + LMAX ), $ L1M = NSMPMX*LMAX + $ MAX( 2*NNMAX, $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ 2*NMAX + L0 ), $ L2M = MAX( 4*LXM + 1, BSNM + $ MAX( 3*BSNM + 1, LTHS ), $ NSMPMX*( LMAX - 1 ) ), $ L3M = MAX( 4*LXM, LTHS*BSNM + 2*LXM + $ 2*MAX( BSNM, LTHS ) ), $ LDW1 = MAX( 2*( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX, $ ( LMAX*NOBRMX - LMAX )*NMAX + $ NMAX*NMAX + 7*NMAX, $ LMAX*NOBRMX*NMAX + $ MAX( ( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX, $ 2*( LMAX*NOBRMX - LMAX )*NMAX $ + NMAX*NMAX + 8*NMAX, $ NMAX + 4*( MMAX*NOBRMX + $ NMAX ) + 1, $ MMAX*NOBRMX + 3*NMAX + LMAX ) $ ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ MAX( ( NMAX + LMAX )**2, $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW3 = NSMPMX*LMAX*( NMAX + 1 ) + 2*NMAX + $ MAX( 2*NMAX*NMAX, 4*NMAX ), $ LDW4 = NMAX*( NMAX + 1 ) + 2*NMAX + $ MAX( NMAX*LMAX*( NMAX + 1 ) + $ 2*NMAX*NMAX + LMAX*NMAX, 4*NMAX ), $ LDW5 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LDW6 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + NMAX + $ MAX( 1, NMAX*NMAX*LMAX + NMAX*LMAX + $ NMAX, NMAX*NMAX + $ MAX( NMAX*NMAX + $ NMAX*MAX( NMAX, LMAX ) + $ 6*NMAX + MIN( NMAX, LMAX ), $ NMAX*MMAX ) ), $ LDW7 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LW1 = MAX( 2*( MMAX + LMAX )*NOBRMX* $ ( 2*( MMAX + LMAX )*( NOBRMX + 1 ) $ + 3 ) + LMAX*NOBRMX, $ 4*( MMAX + LMAX )*NOBRMX* $ ( MMAX + LMAX )*NOBRMX + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ MAX( LDW1, LDW2 ), $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ NMAX + NMAX*NMAX + 2 + $ NMAX*( NMAX + MMAX + LMAX ) + $ MAX( 5*NMAX, 2, MIN( LDW3, LDW4 ), $ LDW5, LDW6 ) ), $ LW2 = NSMPMX*LMAX + BSNM + $ MAX( 4, NSMPMX + $ MAX( NSMPMX*BSNM + $ MAX( 2*NNMAX, 5*BSNM + 1 ), $ BSNM**2 + BSNM + $ MAX( NSMPMX + 2*NNMAX, $ 5*BSNM ) ) ), $ LW3 = MAX( LDW7, NSMPMX*LMAX + $ ( NMAX + LMAX )*( 2*NMAX + MMAX )+ $ 2*NMAX ), $ LW4 = NSMPMX*LMAX + LXM + $ MAX( 4, NSMPMX*LMAX + $ MAX( NSMPMX*LMAX*( BSNM + LTHS ) + $ MAX( NSMPMX*LMAX + L1M, $ L2M + LXM ), $ LXM*( BSNM + LTHS ) + $ LXM + $ MAX( NSMPMX*LMAX + L1M, $ LXM + L3M ) ) ), $ LDWORK = MAX( LW1, LW2, LW3, LW4 ) ) * .. Local Scalars .. LOGICAL INIT1, INITB, INITL, INITN, INITS CHARACTER*1 INIT INTEGER BSN, I, INFO, INI, ITER, ITMAX1, ITMAX2, IWARN, $ J, L, L1, L2, LPAR, LX, M, N, NN, NOBR, NPRINT, $ NS, NSMP DOUBLE PRECISION TOL1, TOL2 * .. Array Arguments .. INTEGER IWORK(LIWORK) DOUBLE PRECISION DWORK(LDWORK), U(LDU,MMAX), X(LXM), Y(LDY,LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB03BD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, $ NPRINT, TOL1, TOL2, INIT INITL = LSAME( INIT, 'L' ) INITS = LSAME( INIT, 'S' ) INITB = LSAME( INIT, 'B' ) INITN = LSAME( INIT, 'N' ) INIT1 = INITL .OR. INITB IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE NS = N IF( INIT1 ) THEN IF( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99991 ) NOBR STOP ELSEIF( NSMP.LT.2*( M + L + 1 )*NOBR - 1 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.EQ.0 .OR. N.GE.NOBR ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF IF ( N.LT.0 ) $ N = NOBR - 1 ELSE IF( NSMP.LT.0 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF END IF IF( NN.LT.0 .OR. NN.GT.NNMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NN ELSE BSN = NN*( L + 2 ) + 1 L1 = BSN*L L2 = N*( L + M + 1 ) + L*M LX = L1 + L2 INI = 1 IF ( INITL ) THEN LPAR = L1 ELSEIF ( INITS ) THEN INI = L1 + 1 LPAR = L2 ELSEIF ( INITN ) THEN LPAR = LX END IF IF( INIT1 ) $ N = NS * Read the input-output data, initial parameters, and seed. READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,NSMP ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1,L ), I = 1,NSMP ) IF ( .NOT.INITB ) $ READ ( NIN, FMT = * ) ( X(I), I = INI,INI+LPAR-1 ) IF ( INITS .OR. INITB ) $ READ ( NIN, FMT = * ) ( DWORK(I), I = 1,4 ) * Solve a Wiener system identification problem. CALL IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, $ ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99987 ) IWARN ITER = DWORK(3) WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) ITER, IWORK(1), IWORK(2) * Recompute LX is necessary. IF ( INIT1 .AND. NS.LT.0 ) $ LX = L1 + N*( L + M + 1 ) + L*M WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, LX ) END IF END IF END IF END IF STOP * 99999 FORMAT (' IB03BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from IB03BD = ',I4) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' Number of iterations = ', I7, $ /' Number of function evaluations = ', I7, $ /' Number of Jacobian evaluations = ', I7) 99995 FORMAT (10(1X,F9.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' NOBR is out of range.',/' NOBR = ',I5) 99990 FORMAT (/' NSMP is out of range.',/' NSMP = ',I5) 99989 FORMAT (/' N is out of range.',/' N = ',I5) 99988 FORMAT (/' NN is out of range.',/' NN = ',I5) 99987 FORMAT (' IWARN on exit from IB03BD = ',I4) END slicot-5.0+20101122/examples/TMB01TD.f000077500000000000000000000031501201767322700165500ustar00rootroot00000000000000* MB01TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDB PARAMETER ( LDA = NMAX, LDB = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX-1 ) * .. Local Scalars .. INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,NMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL MB01TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) * Compute the matrix product A*B. CALL MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB01TD = ',I2) 99997 FORMAT (' The matrix product A*B is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB02CD.f000077500000000000000000000064651201767322700165440ustar00rootroot00000000000000* MB02CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 20, NMAX = 20 ) INTEGER LCS, LDG, LDL, LDR, LDT, LDWORK PARAMETER ( LDG = 2*KMAX, LDL = NMAX*KMAX, LDR = NMAX*KMAX, $ LDT = KMAX, LDWORK = ( NMAX - 1 )*KMAX ) PARAMETER ( LCS = 3*LDWORK ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N CHARACTER JOB, TYPET * .. Local Arrays .. (Dimensioned for TYPET = 'R'.) DOUBLE PRECISION CS(LCS), DWORK(LDWORK), G(LDG, NMAX*KMAX), $ L(LDL, NMAX*KMAX), R(LDR, NMAX*KMAX), $ T(LDT, NMAX*KMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLASET, MB02CD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, JOB TYPET = 'R' M = N*K IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99992 ) K ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) * Compute the Cholesky factor(s) and/or the generator. CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, $ LDL, CS, LCS, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'A' ) .OR. $ LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'R' ) ) THEN WRITE ( NOUT, FMT = 99997 ) CALL DLASET( 'Full', K, K, ZERO, ZERO, G(K+1,1), LDG ) DO 10 I = 1, 2*K WRITE ( NOUT, FMT = 99994 ) ( G(I,J), J = 1, M ) 10 CONTINUE END IF IF ( LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( L(I,J), J = 1, M ) 20 CONTINUE END IF IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) $ .OR. LSAME( JOB, 'O' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M ) 30 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' MB02CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02CD = ',I2) 99997 FORMAT (' The generator of the inverse of block Toeplitz matrix', $ ' is ') 99996 FORMAT (/' The lower Cholesky factor of the inverse is ') 99995 FORMAT (/' The upper Cholesky factor of block Toeplitz matrix is ' $ ) 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples/TMB02DD.f000077500000000000000000000147651201767322700165470ustar00rootroot00000000000000* MB02DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, MMAX, NMAX PARAMETER ( KMAX = 20, MMAX = 20, NMAX = 20 ) INTEGER LCS, LDG, LDL, LDR, LDT, LDWORK PARAMETER ( LDG = KMAX*( MMAX + NMAX ), $ LDL = KMAX*( MMAX + NMAX ), $ LDR = KMAX*( MMAX + NMAX ), $ LDT = KMAX*( MMAX + NMAX ), $ LDWORK = ( MMAX + NMAX - 1 )*KMAX ) PARAMETER ( LCS = 3*LDWORK ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N, S CHARACTER JOB, TYPET * .. Local Arrays .. * The arrays are dimensioned for both TYPET = 'R' and TYPET = 'C'. * Arrays G and T could be smaller. * For array G, it is assumed that MMAX + NMAX >= 2. * The matrix TA is also stored in the array T. DOUBLE PRECISION CS(LCS), DWORK(LDWORK), $ G(LDG, KMAX*( MMAX + NMAX )), $ L(LDL, KMAX*( MMAX + NMAX )), $ R(LDR, KMAX*( MMAX + NMAX )), $ T(LDT, KMAX*( MMAX + NMAX )) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLACPY, MB02CD, MB02DD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, M, JOB, TYPET S = ( N + M )*K IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99989 ) N ELSE IF ( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99988 ) K ELSE IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE IF ( LSAME( TYPET, 'R' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,S ), I = 1,K ) ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,S ) END IF * Compute the Cholesky factors. CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, $ LDL, CS, LCS, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N*K WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, N*K ) 10 CONTINUE IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99995 ) IF ( LSAME( TYPET, 'R' ) ) THEN DO 20 I = 1, 2*K WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, N*K ) 20 CONTINUE ELSE DO 30 I = 1, N*K WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, 2*K ) 30 CONTINUE END IF END IF IF ( LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N*K WRITE ( NOUT, FMT = 99990 ) $ ( L(I,J), J = 1, N*K ) 40 CONTINUE END IF * Update the Cholesky factors. IF ( LSAME( TYPET, 'R' ) ) THEN * Copy the last block column of R. CALL DLACPY( 'All', N*K, K, R(1,(N-1)*K+1), LDR, $ R(K+1,N*K+1), LDR ) CALL MB02DD( JOB, TYPET, K, M, N, T(1,N*K+1), LDT, $ T, LDT, G, LDG, R(1,N*K+1), LDR, $ L(N*K+1,1), LDL, CS, LCS, DWORK, $ LDWORK, INFO ) ELSE * Copy the last block row of R. CALL DLACPY( 'All', K, N*K, R((N-1)*K+1,1), LDR, $ R(N*K+1,K+1), LDR ) CALL MB02DD( JOB, TYPET, K, M, N, T(N*K+1,1), LDT, $ T, LDT, G, LDG, R(N*K+1,1), LDR, $ L(1,N*K+1), LDL, CS, LCS, DWORK, $ LDWORK, INFO ) END IF IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99993 ) DO 50 I = 1, S WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, S ) 50 CONTINUE IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) ) $ THEN WRITE ( NOUT, FMT = 99992 ) IF ( LSAME( TYPET, 'R' ) ) THEN DO 60 I = 1, 2*K WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, S ) 60 CONTINUE ELSE DO 70 I = 1, S WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, 2*K ) 70 CONTINUE END IF END IF IF ( LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, S WRITE ( NOUT, FMT = 99990 ) $ ( L(I,J), J = 1, S ) 80 CONTINUE END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT ( ' MB02DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT ( ' INFO on exit from MB02CD = ',I2) 99997 FORMAT ( ' INFO on exit from MB02DD = ',I2) 99996 FORMAT ( ' The Cholesky factor is ') 99995 FORMAT (/' The inverse generator is ') 99994 FORMAT (/' The inverse Cholesky factor is ') 99993 FORMAT (/' The updated Cholesky factor is ') 99992 FORMAT (/' The updated inverse generator is ') 99991 FORMAT (/' The updated inverse Cholesky factor is ') 99990 FORMAT (20(1X,F8.4)) 99989 FORMAT (/' N is out of range.',/' N = ',I5) 99988 FORMAT (/' K is out of range.',/' K = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TMB02ED.f000077500000000000000000000063741201767322700165450ustar00rootroot00000000000000* MB02ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 20, NMAX = 20 ) INTEGER LDB, LDT, LDWORK PARAMETER ( LDB = KMAX*NMAX, LDT = KMAX*NMAX, $ LDWORK = NMAX*KMAX*KMAX + ( NMAX+2 )*KMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N, NRHS CHARACTER TYPET * .. Local Arrays .. * The arrays B and T are dimensioned for both TYPET = 'R' and * TYPET = 'C'. * NRHS is assumed to be not larger than KMAX*NMAX. DOUBLE PRECISION B(LDB, KMAX*NMAX), DWORK(LDWORK), $ T(LDT, KMAX*NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02ED * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, NRHS, TYPET M = N*K IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99993 ) K ELSE IF ( NRHS.LE.0 .OR. NRHS.GT.KMAX*NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NRHS ELSE IF ( LSAME( TYPET, 'R' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,M ) END IF IF ( LSAME( TYPET, 'R' ) ) THEN READ (NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, $ NRHS ) ELSE READ (NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1, $ M ) END IF * Compute the solution of X T = B or T X = B. CALL MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( TYPET, 'R' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, NRHS WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 10 CONTINUE ELSE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, $ NRHS ) 20 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' MB02ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02ED = ',I2) 99997 FORMAT (' The solution of X*T = B is ') 99996 FORMAT (' The solution of T*X = B is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' K is out of range.',/' K = ',I5) 99992 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5) END slicot-5.0+20101122/examples/TMB02FD.f000077500000000000000000000134211201767322700165350ustar00rootroot00000000000000* MB02FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER ITMAX, KMAX, NMAX PARAMETER ( ITMAX = 10, KMAX = 20, NMAX = 20 ) INTEGER LDR, LDT, LDWORK PARAMETER ( LDR = NMAX*KMAX, LDT = KMAX, $ LDWORK = ( NMAX + 1 )*KMAX ) * .. Local Scalars .. INTEGER I, INFO, IT, J, K, LEN, M, N, P, PIT, POS, POSR, $ S1, SCIT CHARACTER TYPET DOUBLE PRECISION NNRM * .. Local Arrays .. (Dimensioned for TYPET = 'R'.) INTEGER S(ITMAX) DOUBLE PRECISION DWORK(LDWORK), R(LDR, NMAX*KMAX), $ T(LDT, NMAX*KMAX), V(NMAX*KMAX), W(NMAX*KMAX), $ Z(NMAX*KMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DNRM2 EXTERNAL DNRM2, LSAME * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLASET, DSCAL, DTRMV, MB02FD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, IT TYPET = 'R' M = N*K IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99992 ) K ELSE IF( IT.LE.0 .OR. IT.GT.ITMAX ) THEN WRITE ( NOUT, FMT = 99991 ) IT ELSE READ ( NIN, FMT = * ) ( S(I), I = 1, IT ) READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) P = 0 POS = 1 WRITE ( NOUT, FMT = 99997 ) DO 90 SCIT = 1, IT CALL MB02FD( TYPET, K, N, P, S(SCIT), T(1,POS), LDT, $ R(POS,POS), LDR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO STOP END IF S1 = S(SCIT) + P IF ( S1.EQ.0 ) THEN * Estimate the 2-norm of the Toeplitz matrix with 5 power * iterations. LEN = N*K CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 ) DO 30 PIT = 1, 5 DO 10 I = 1, N CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE, T, $ LDT, V((I-1)*K+1), 1, ZERO, $ W((I-1)*K+1), 1 ) 10 CONTINUE DO 20 I = 1, N-1 CALL DGEMV( 'Transpose', K, (N-I)*K, ONE, $ T(1,K+1), LDT, V((I-1)*K+1), 1, $ ONE, W(I*K+1), 1 ) 20 CONTINUE CALL DCOPY( LEN, W, 1, V, 1 ) NNRM = DNRM2( LEN, V, 1 ) CALL DSCAL( LEN, ONE/NNRM, V, 1 ) 30 CONTINUE ELSE * Estimate the 2-norm of the Schur complement with 5 power * iterations. LEN = ( N - S1 )*K CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 ) DO 80 PIT = 1, 5 POSR = ( S1 - 1 )*K + 1 DO 40 I = 1, N - S1 CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE, $ T(1,POSR+K), LDT, V((I-1)*K+1), 1, $ ZERO, W((I-1)*K+1), 1 ) 40 CONTINUE DO 50 I = 1, N - S1 CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', K, $ R(POSR,POSR), LDR, V((I-1)*K+1), 1 ) CALL DGEMV( 'NoTranspose', K, LEN-I*K, ONE, $ R(POSR,POSR+K), LDR, V(I*K+1), 1, ONE, $ V((I-1)*K+1), 1 ) 50 CONTINUE CALL DLASET( 'All', LEN, 1, ZERO, ZERO, Z, 1 ) DO 60 I = 1, N - S1 CALL DGEMV( 'Transpose', K, LEN-I*K, ONE, $ R(POSR,POSR+K), LDR, V((I-1)*K+1), 1, $ ONE, Z(I*K+1), 1 ) CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', K, $ R(POSR,POSR), LDR, V((I-1)*K+1), 1 ) CALL DAXPY( K, ONE, V((I-1)*K+1), 1, Z((I-1)*K+1), $ 1 ) 60 CONTINUE CALL DLASET( 'All', LEN, 1, ZERO, ZERO, V, 1 ) DO 70 I = 1, N - S1 CALL DGEMV( 'Transpose', K, LEN-(I-1)*K, ONE, $ T(1,POSR+K), LDT, W((I-1)*K+1), 1, $ ONE, V((I-1)*K+1), 1 ) 70 CONTINUE CALL DAXPY( LEN, -ONE, Z, 1, V, 1 ) NNRM = DNRM2( LEN, V, 1 ) CALL DSCAL( LEN, -ONE/NNRM, V, 1 ) 80 CONTINUE POS = ( S1 - 1 )*K + 1 P = S1 END IF WRITE ( NOUT, FMT = 99995 ) P*K, NNRM 90 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 100 I = 1, P*K WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M ) 100 CONTINUE END IF STOP * 99999 FORMAT (' MB02FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02FD = ',I2) 99997 FORMAT (' Incomplete Cholesky factorization ', $ //' rows norm(Schur complement)',/) 99996 FORMAT (/' The upper ICC factor of the block Toeplitz matrix is ' $ ) 99995 FORMAT (I4,5X,F8.4) 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' K is out of range.',/' K = ',I5) 99991 FORMAT (/' IT is out of range.',/' IT = ',I5) END slicot-5.0+20101122/examples/TMB02GD.f000077500000000000000000000046221201767322700165410ustar00rootroot00000000000000* MB02GD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX, NLMAX PARAMETER ( KMAX = 20, NMAX = 20, NLMAX = 20 ) INTEGER LDRB, LDT, LDWORK PARAMETER ( LDRB = ( NLMAX + 1 )*KMAX, LDT = KMAX*NMAX, $ LDWORK = ( NLMAX + 1 )*KMAX*KMAX + $ ( 3 + NLMAX )*KMAX ) * .. Local Scalars .. INTEGER I, J, INFO, K, M, N, NL, SIZR CHARACTER TRIU, TYPET * .. Local Arrays dimensioned for TYPET = 'R' .. DOUBLE PRECISION DWORK(LDWORK), RB(LDRB, NMAX*KMAX), $ T(LDT, NMAX*KMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02GD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, N, NL, TRIU TYPET = 'R' M = ( NL + 1 )*K IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE IF( NL.LE.0 .OR. NL.GT.NLMAX ) THEN WRITE ( NOUT, FMT = 99994 ) NL ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99993 ) K ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) * Compute the banded Cholesky factor. CALL MB02GD( TYPET, TRIU, K, N, NL, 0, N, T, LDT, RB, LDRB, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) IF ( LSAME( TRIU, 'T' ) ) THEN SIZR = NL*K + 1 ELSE SIZR = ( NL + 1 )*K END IF DO 10 I = 1, SIZR WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1, N*K ) 10 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB02GD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02GD = ',I2) 99997 FORMAT (/' The upper Cholesky factor in banded storage format ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' NL is out of range.',/' NL = ',I5) 99993 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples/TMB02HD.f000077500000000000000000000062711201767322700165440ustar00rootroot00000000000000* MB02HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, MLMAX, NMAX, NUMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, MLMAX = 10, $ NMAX = 20, NUMAX = 10 ) INTEGER LDRB, LDTC, LDTR, LDWORK PARAMETER ( LDRB = ( MLMAX + NUMAX + 1 )*LMAX, $ LDTC = ( MLMAX + 1 )*KMAX, LDTR = KMAX ) PARAMETER ( LDWORK = LDRB*LMAX + ( 2*NUMAX + 1 )*LMAX*KMAX $ + 2*LDRB*( KMAX + LMAX ) + LDRB $ + 6*LMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, LENR, M, ML, N, NU, S CHARACTER TRIU * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,NMAX*LMAX), $ TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02HD * .. Intrinsic Functions .. INTRINSIC MIN * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, ML, N, NU, TRIU IF( K.LT.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99990 ) K ELSE IF( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99991 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( ML.LT.0 .OR. ML.GT.MLMAX ) THEN WRITE ( NOUT, FMT = 99993 ) ML ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF( NU.LT.0 .OR. NU.GT.NUMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NU ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,(ML+1)*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,NU*L ), I = 1,K ) S = ( MIN( M*K, N*L ) + L - 1 ) / L * Compute the banded R factor. CALL MB02HD( TRIU, K, L, M, ML, N, NU, 0, S, TC, LDTC, TR, $ LDTR, RB, LDRB, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) LENR = ( ML + NU + 1 )*L IF ( LSAME( TRIU, 'T' ) ) LENR = ( ML + NU )*L + 1 LENR = MIN( LENR, N*L ) DO 10 I = 1, LENR WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1, $ MIN( N*L, M*K ) ) 10 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB02HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02HD = ',I2) 99997 FORMAT (/' The lower triangular factor R in banded storage ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' NU is out of range.',/' NU = ',I5) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' ML is out of range.',/' ML = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' L is out of range.',/' L = ',I5) 99990 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples/TMB02ID.f000077500000000000000000000073161201767322700165460ustar00rootroot00000000000000* MB02ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX, RBMAX, RCMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20, $ RBMAX = 20, RCMAX = 20 ) INTEGER LDB, LDC, LDTC, LDTR, LDWORK PARAMETER ( LDB = KMAX*MMAX, LDC = KMAX*MMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = 2*NMAX*LMAX*( LMAX + KMAX ) + $ ( 6 + NMAX )*LMAX + $ MMAX*KMAX*( LMAX + 1 ) + $ RBMAX + RCMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, M, N, RB, RC CHARACTER JOB DOUBLE PRECISION B(LDB,RBMAX), C(LDC,RCMAX), DWORK(LDWORK), $ TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02ID * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, RB, RC, JOB IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99994 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99993 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) $ .AND. ( ( RB.LE.0 ) .OR. ( RB.GT.RBMAX ) ) ) THEN WRITE ( NOUT, FMT = 99990 ) RB ELSE IF ( ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) $ .AND. ( ( RC.LE.0 ) .OR. ( RC.GT.RCMAX ) ) ) THEN WRITE ( NOUT, FMT = 99989 ) RC ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,(N-1)*L ), I = 1,K ) IF ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,RB ), I = 1,M*K ) END IF IF ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) THEN READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,RC ), I = 1,N*L ) END IF CALL MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B, $ LDB, C, LDC, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N*L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, RB ) 10 CONTINUE END IF IF ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, M*K WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, RC ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB02ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02ID = ',I2) 99997 FORMAT (' The least squares solution of T * X = B is ') 99996 FORMAT (' The minimum norm solution of T^T * X = C is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' K is out of range.',/' K = ',I5) 99993 FORMAT (/' L is out of range.',/' L = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' RB is out of range.',/' RB = ',I5) 99989 FORMAT (/' RC is out of range.',/' RC = ',I5) END slicot-5.0+20101122/examples/TMB02JD.f000077500000000000000000000060211201767322700165370ustar00rootroot00000000000000* MB02JD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX PARAMETER ( KMAX = 10, LMAX = 10, MMAX = 20, NMAX = 20 ) INTEGER LDR, LDQ, LDTC, LDTR, LDWORK PARAMETER ( LDR = NMAX*LMAX, LDQ = MMAX*KMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = ( MMAX*KMAX + NMAX*LMAX ) $ *( LMAX + 2*KMAX ) + 6*LMAX $ + MMAX*KMAX + NMAX*LMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, M, N, S CHARACTER JOB * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,NMAX*LMAX), $ R(LDR,NMAX*LMAX), TC(LDTC,LMAX), $ TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02JD * .. Intrinsic Functions .. INTRINSIC MIN * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, JOB IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99994 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99993 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,( N - 1 )*L ), $ I = 1,K ) S = ( MIN( M*K, N*L ) + L - 1 ) / L * Compute the required part of the QR factorization. CALL MB02JD( JOB, K, L, M, N, 0, S, TC, LDTC, TR, LDTR, Q, LDQ, $ R, LDR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( JOB, 'Q' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M*K WRITE ( NOUT, FMT = 99995 ) $ ( Q(I,J), J = 1, MIN( N*L, M*K ) ) 10 CONTINUE END IF WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N*L WRITE ( NOUT, FMT = 99995 ) $ ( R(I,J), J = 1, MIN( N*L, M*K ) ) 20 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MB02JD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02JD = ',I2) 99997 FORMAT (/' The factor Q is ') 99996 FORMAT (/' The factor R is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' K is out of range.',/' K = ',I5) 99993 FORMAT (/' L is out of range.',/' L = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB02JX.f000077500000000000000000000065071201767322700165740ustar00rootroot00000000000000* MB02JX EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20 ) INTEGER LDR, LDQ, LDTC, LDTR, LDWORK PARAMETER ( LDR = NMAX*LMAX, LDQ = MMAX*KMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = ( MMAX*KMAX + NMAX*LMAX ) $ *( LMAX + 2*KMAX ) + 5*LMAX $ + MMAX*KMAX + NMAX*LMAX ) * .. Local Scalars .. CHARACTER JOB INTEGER I, INFO, J, K, L, M, N, RNK DOUBLE PRECISION TOL1, TOL2 * .. Local Arrays .. INTEGER JPVT(NMAX*LMAX) DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,NMAX*LMAX), $ R(LDR,NMAX*LMAX), TC(LDTC,LMAX), $ TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02JX * .. Intrinsic Functions .. INTRINSIC MIN * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, TOL1, TOL2, JOB IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99991 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99990 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,( N - 1 )*L ), $ I = 1,K ) * Compute the required part of the QR factorization. CALL MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, LDQ, $ R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RNK IF ( LSAME( JOB, 'Q' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M*K WRITE ( NOUT, FMT = 99993 ) ( Q(I,J), J = 1, RNK ) 10 CONTINUE END IF WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N*L WRITE ( NOUT, FMT = 99993 ) ( R(I,J), J = 1, RNK ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) WRITE ( NOUT, FMT = 99992 ) ( JPVT(I), $ I = 1, MIN( M*K, N*L ) ) END IF END IF STOP * 99999 FORMAT (' MB02JX EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02JX = ',I2) 99997 FORMAT (/' The factor Q is ') 99996 FORMAT (/' The factor R is ') 99995 FORMAT (/' The column permutation is ') 99994 FORMAT (/' Numerical rank ',/' RNK = ',I5) 99993 FORMAT (20(1X,F8.4)) 99992 FORMAT (20(1X,I4)) 99991 FORMAT (/' K is out of range.',/' K = ',I5) 99990 FORMAT (/' L is out of range.',/' L = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB02KD.f000077500000000000000000000072711201767322700165500ustar00rootroot00000000000000* MB02KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX, RMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20, $ RMAX = 20 ) INTEGER LDB, LDC, LDTC, LDTR, LDWORK PARAMETER ( LDB = LMAX*NMAX, LDC = KMAX*MMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = 2*( KMAX*LMAX + KMAX*RMAX $ + LMAX*RMAX + 1 )*( MMAX + NMAX ) ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, M, N, R CHARACTER LDBLK, TRANS DOUBLE PRECISION ALPHA, BETA * .. Local Arrays .. (Dimensioned for TRANS = 'N'.) DOUBLE PRECISION B(LDB,RMAX), C(LDC,RMAX), DWORK(LDWORK), $ TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02KD * .. Intrinsic Functions .. INTRINSIC MAX * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, R, LDBLK, TRANS IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99994 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99993 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF( R.LE.0 .OR. R.GT.RMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( LSAME( LDBLK, 'R' ) ) THEN READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), $ I = 1,(M-1)*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,N*L ), I = 1,K ) ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,(N-1)*L ), $ I = 1,K ) END IF IF ( LSAME( TRANS, 'N' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,R ), I = 1,N*L ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,R ), I = 1,M*K ) END IF ALPHA = ONE BETA = ZERO CALL MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, TC, $ LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, LDWORK, $ INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( TRANS, 'N' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M*K WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,R ) 10 CONTINUE ELSE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N*L WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,R ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB02KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02KD = ',I2) 99997 FORMAT (' The product C = T * B is ') 99996 FORMAT (' The product C = T^T * B is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' K is out of range.',/' K = ',I5) 99993 FORMAT (/' L is out of range.',/' L = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' R is out of range.',/' R = ',I5) END slicot-5.0+20101122/examples/TMB02MD.f000077500000000000000000000072011201767322700165430ustar00rootroot00000000000000* MB02MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, LMAX PARAMETER ( MMAX = 20, NMAX = 20, LMAX = 20 ) INTEGER LDC, LDX PARAMETER ( LDC = MAX( MMAX,NMAX+LMAX ), LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MMAX*(NMAX+LMAX) + $ MAX( 3*MIN(MMAX,NMAX+LMAX) + $ MAX(MMAX,NMAX+LMAX), $ 5*MIN(MMAX,NMAX+LMAX), $ 3*LMAX ) ) INTEGER LIWORK PARAMETER ( LIWORK = LMAX ) INTEGER LENGS PARAMETER ( LENGS = MIN( MMAX, NMAX+LMAX ) ) * .. Local Scalars .. DOUBLE PRECISION SDEV, TOL INTEGER I, INFO, IWARN, J, L, M, N, RANK CHARACTER*1 JOB * .. Local Arrays .. DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK), S(LENGS), $ X(LDX,LMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02MD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, L, JOB * IF ( LSAME( JOB, 'R' ) ) THEN READ ( NIN, FMT = * ) TOL ELSE IF ( LSAME( JOB, 'T' ) ) THEN READ ( NIN, FMT = * ) RANK, SDEV TOL = SDEV ELSE IF ( LSAME( JOB, 'N' ) ) THEN READ ( NIN, FMT = * ) RANK, TOL ELSE READ ( NIN, FMT = * ) SDEV TOL = SDEV END IF * IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M ) * Compute the solution to the TLS problem Ax = b. CALL MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) RANK ELSE IF ( ( LSAME( JOB, 'R' ) ) .OR. ( LSAME( JOB, 'B' ) ) ) $ WRITE ( NOUT, FMT = 99996 ) RANK END IF WRITE ( NOUT, FMT = 99995 ) DO 40 J = 1, L DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) X(I,J) 20 CONTINUE IF ( J.LT.L ) WRITE ( NOUT, FMT = 99993 ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) ( S(J),J = 1, MIN( M, N+L ) ) END IF END IF STOP * 99999 FORMAT (' MB02MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02MD = ',I2) 99997 FORMAT (' IWARN on exit from MB02MD = ',I2,/) 99996 FORMAT (' The computed rank of the TLS approximation = ',I3,/) 99995 FORMAT (' The solution X to the TLS problem is ',/) 99994 FORMAT (1X,F8.4) 99993 FORMAT (' ') 99992 FORMAT (/' The singular values of C are ',//(1X,F8.4)) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' L is out of range.',/' L = ',I5) END slicot-5.0+20101122/examples/TMB02ND.f000077500000000000000000000122011201767322700165400ustar00rootroot00000000000000* MB02ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, LMAX PARAMETER ( MMAX = 20, NMAX = 20, LMAX = 20 ) INTEGER LDC, LDX PARAMETER ( LDC = MAX( MMAX, NMAX+LMAX ), LDX = NMAX ) INTEGER LENGQ PARAMETER ( LENGQ = 2*MIN(MMAX,NMAX+LMAX)-1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX+2*LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX(2, MAX( MMAX, NMAX+LMAX ) + $ 2*MIN( MMAX, NMAX+LMAX ), $ MIN( MMAX, NMAX+LMAX ) + $ MAX( ( NMAX+LMAX )*( NMAX+LMAX-1 )/2, $ MMAX*( NMAX+LMAX-( MMAX-1 )/2 ) ) + $ MAX( 6*(NMAX+LMAX)-5, LMAX*LMAX + $ MAX( NMAX+LMAX, 3*LMAX ) ) ) ) INTEGER LBWORK PARAMETER ( LBWORK = NMAX+LMAX ) * .. Local Scalars .. DOUBLE PRECISION RELTOL, THETA, THETA1, TOL INTEGER I, INFO, IWARN, J, K, L, LOOP, M, MINMNL, N, $ RANK, RANK1 * .. Local Arrays .. DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK), $ Q(LENGQ), X(LDX,LMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LBWORK), INUL(NMAX+LMAX) * .. External Subroutines .. EXTERNAL MB02ND * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, L, RANK, THETA, TOL, RELTOL IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99982 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99983 ) N ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99981 ) L ELSE IF ( RANK.GT.MIN( MMAX, NMAX ) ) THEN WRITE ( NOUT, FMT = 99980 ) RANK ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99979 ) THETA ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M ) RANK1 = RANK THETA1 = THETA * Compute the solution to the TLS problem Ax = b. CALL MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL, $ TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, IWARN, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) RANK ELSE IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK END IF IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA WRITE ( NOUT, FMT = 99994 ) MINMNL = MIN( M, N+L ) LOOP = MINMNL - 1 DO 20 I = 1, LOOP K = I + MINMNL WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K) 20 CONTINUE WRITE ( NOUT, FMT = 99992 ) MINMNL, MINMNL, Q(MINMNL) WRITE ( NOUT, FMT = 99991 ) DO 60 J = 1, L DO 40 I = 1, N WRITE ( NOUT, FMT = 99990 ) X(I,J) 40 CONTINUE IF ( J.LT.L ) WRITE ( NOUT, FMT = 99989 ) 60 CONTINUE WRITE ( NOUT, FMT = 99987 ) N + L, N + L WRITE ( NOUT, FMT = 99985 ) DO 80 I = 1, MAX( M, N + L ) WRITE ( NOUT, FMT = 99984 ) ( C(I,J), J = 1,N+L ) 80 CONTINUE WRITE ( NOUT, FMT = 99986 ) DO 100 J = 1, N + L WRITE ( NOUT, FMT = 99988 ) J, INUL(J) 100 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB02ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02ND = ',I2) 99997 FORMAT (' IWARN on exit from MB02ND = ',I2,/) 99996 FORMAT (' The computed rank of the TLS approximation = ',I3,/) 99995 FORMAT (' The computed value of THETA = ',F7.4,/) 99994 FORMAT (' The elements of the partially diagonalized bidiagonal ', $ 'matrix are',/) 99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/) 99991 FORMAT (' The solution X to the TLS problem is ',/) 99990 FORMAT (1X,F8.4) 99989 FORMAT (' ') 99988 FORMAT (I3,L8) 99987 FORMAT (/' Right singular subspace corresponds to the first ',I2, $ ' components of the j-th ',/' column of C for which INUL(', $ 'j) = .TRUE., j = 1,...,',I2,/) 99986 FORMAT (/' j INUL(j)',/) 99985 FORMAT (' Matrix C',/) 99984 FORMAT (20(1X,F8.4)) 99983 FORMAT (/' N is out of range.',/' N = ',I5) 99982 FORMAT (/' M is out of range.',/' M = ',I5) 99981 FORMAT (/' L is out of range.',/' L = ',I5) 99980 FORMAT (/' RANK is out of range.',/' RANK = ',I5) 99979 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4) END slicot-5.0+20101122/examples/TMB02QD.f000077500000000000000000000060271201767322700165540ustar00rootroot00000000000000* MB02QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, NRHSMX PARAMETER ( NMAX = 20, MMAX = 20, NRHSMX = 20 ) INTEGER LDA, LDB PARAMETER ( LDA = MMAX, LDB = MAX( MMAX, NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( MIN( MMAX, NMAX) + 3*NMAX + 1, $ 2*MIN( MMAX, NMAX) + NRHSMX ) ) * .. Local Scalars .. DOUBLE PRECISION RCOND, SVLMAX INTEGER I, INFO, J, M, N, NRHS, RANK CHARACTER*1 INIPER, JOB * .. Local Arrays .. INTEGER JPVT(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,NRHSMX), DWORK(LDWORK), $ SVAL(3), Y(NMAX*NRHSMX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02QD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, NRHS, RCOND, SVLMAX, JOB, INIPER IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF ( NRHS.LT.0 .OR. NRHS.GT.NRHSMX ) THEN WRITE ( NOUT, FMT = 99992 ) NRHS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,M ) IF ( LSAME( JOB, 'F' ) ) $ READ ( NIN, FMT = * ) ( Y(I), I = 1,N*NRHS ) IF ( LSAME( INIPER, 'P' ) ) $ READ ( NIN, FMT = * ) ( JPVT(I), I = 1,N ) * Find the least squares solution. CALL MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, $ LDA, B, LDB, Y, JPVT, RANK, SVAL, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RANK, SVAL WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,NRHS ) 10 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' MB02QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02QD =',I2) 99997 FORMAT (' The effective rank of A =',I2,/ $ ' Estimates of the singular values SVAL = '/3(1X,F8.4)) 99996 FORMAT (' The least squares solution is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5) END slicot-5.0+20101122/examples/TMB02SD.f000077500000000000000000000055261201767322700165610ustar00rootroot00000000000000* MB02SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NRHMAX PARAMETER ( NMAX = 20, NRHMAX = 20 ) INTEGER LDB, LDH PARAMETER ( LDB = NMAX, LDH = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) * .. Local Scalars .. DOUBLE PRECISION HNORM, RCOND INTEGER I, INFO, INFO1, J, N, NRHS CHARACTER*1 NORM, TRANS * .. Local Arrays .. DOUBLE PRECISION H(LDH,NMAX), B(LDB,NRHMAX), DWORK(LDWORK) INTEGER IPIV(NMAX), IWORK(LIWORK) * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS * .. External Subroutines .. EXTERNAL DLASET, MB02RD, MB02SD, MB02TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NRHS, NORM, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( H(I,J), J = 1,N ), I = 1,N ) IF ( NRHS.LT.0 .OR. NRHS.GT.NRHMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NRHS ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,N ) IF ( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, H(3,1), LDH ) * Compute the LU factorization of the upper Hessenberg matrix. CALL MB02SD( N, H, LDH, IPIV, INFO ) * Estimate the reciprocal condition number of the matrix. HNORM = DLANHS( NORM, N, H, LDH, DWORK ) CALL MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, $ DWORK, INFO1 ) IF ( INFO.EQ.0 .AND. RCOND.GT.DLAMCH( 'Epsilon' ) ) THEN * Solve the linear system. CALL MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) * WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF DO 10 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,NRHS ) 10 CONTINUE WRITE ( NOUT, FMT = 99995 ) RCOND END IF END IF STOP * 99999 FORMAT (' MB02SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02SD = ',I2) 99997 FORMAT (' The solution matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' Reciprocal condition number = ',D12.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5) END slicot-5.0+20101122/examples/TMB02VD.f000077500000000000000000000034661201767322700165650ustar00rootroot00000000000000* MB02VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDB PARAMETER ( LDA = NMAX, LDB = MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N CHARACTER*1 TRANS * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,NMAX) INTEGER IPIV(NMAX) * .. External Subroutines .. EXTERNAL MB02VD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M ) * Solve the linear system using the LU factorization. CALL MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N ) 10 CONTINUE ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF END IF STOP * 99999 FORMAT (' MB02VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02VD = ',I2) 99997 FORMAT (' The solution matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TMB03BD.f000077500000000000000000000115401201767322700165320ustar00rootroot00000000000000* MB03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 6, NMAX = 50 ) INTEGER LDA1, LDA2, LDQ1, LDQ2, LDWORK, LIWORK PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX, $ LDQ2 = NMAX, $ LDWORK = KMAX + MAX( 2*NMAX, 8*KMAX ), $ LIWORK = 2*KMAX ) * * .. Local Scalars .. CHARACTER COMPQ, DEFL, JOB INTEGER H, I, IHI, ILO, INFO, IWARN, J, K, L, N * * .. Local Arrays .. INTEGER IWORK( LIWORK ), QIND( KMAX ), S( KMAX ), $ SCAL( NMAX ) DOUBLE PRECISION A( LDA1, LDA2, KMAX ), ALPHAI( NMAX ), $ ALPHAR( NMAX ), BETA( NMAX ), DWORK( LDWORK), $ Q( LDQ1, LDQ2, KMAX ) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL MB03BD * * .. Intrinsic Functions .. INTRINSIC MAX * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, DEFL, COMPQ, K, N, H, ILO, IHI IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE READ( NIN, FMT = * ) ( S( I ), I = 1, K ) READ( NIN, FMT = * ) ( ( ( A( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'U' ) ) $ READ( NIN, FMT = * ) ( ( ( Q( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'P' ) ) THEN READ( NIN, FMT = * ) ( QIND( I ), I = 1, K ) DO 10 L = 1, K IF( QIND( L ).GT.0 ) $ READ( NIN, FMT = * ) ( ( Q( I, J, QIND( L ) ), $ J = 1, N ), I = 1, N ) 10 CONTINUE END IF * Compute the eigenvalues and the transformed matrices, if * required. CALL MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, A, $ LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, BETA, $ SCAL, IWORK, LIWORK, DWORK, LDWORK, IWARN, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE IF( IWARN.EQ.0 ) THEN IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'T' ) ) THEN WRITE( NOUT, FMT = 99996 ) DO 30 L = 1, K WRITE( NOUT, FMT = 99988 ) L DO 20 I = 1, N WRITE( NOUT, FMT = 99995 ) ( A( I, J, L ), J = 1, N $ ) 20 CONTINUE 30 CONTINUE END IF IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN WRITE( NOUT, FMT = 99994 ) DO 50 L = 1, K WRITE( NOUT, FMT = 99988 ) L DO 40 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q( I, J, L ), J = 1, N $ ) 40 CONTINUE 50 CONTINUE ELSE IF( LSAME( COMPQ, 'P' ) ) THEN WRITE( NOUT, FMT = 99994 ) DO 70 L = 1, K IF( QIND( L ).GT.0 ) THEN WRITE( NOUT, FMT = 99988 ) QIND( L ) DO 60 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( Q( I, J, QIND( L ) ), J = 1, N ) 60 CONTINUE END IF 70 CONTINUE END IF WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, N ) WRITE( NOUT, FMT = 99992 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, N ) WRITE( NOUT, FMT = 99991 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, N ) WRITE( NOUT, FMT = 99990 ) WRITE( NOUT, FMT = 99989 ) ( SCAL( I ), I = 1, N ) ELSE WRITE( NOUT, FMT = 99987 ) IWARN END IF END IF STOP * 99999 FORMAT( 'MB03BD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB03BD = ', I2 ) 99996 FORMAT( 'The matrix A on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix Q on exit is ' ) 99993 FORMAT( 'The vector ALPHAR is ' ) 99992 FORMAT( 'The vector ALPHAI is ' ) 99991 FORMAT( 'The vector BETA is ' ) 99990 FORMAT( 'The vector SCAL is ' ) 99989 FORMAT( 50( 1X, I8 ) ) 99988 FORMAT( 'The factor ', I2, ' is ' ) 99987 FORMAT( 'IWARN on exit from MB03BD = ', I2 ) END slicot-5.0+20101122/examples/TMB03KD.f000077500000000000000000000174311201767322700165500ustar00rootroot00000000000000* MB03KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 6, NMAX = 50 ) INTEGER LDA1, LDA2, LDQ1, LDQ2, LDWORK, LIWORK PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX, $ LDQ2 = NMAX, $ LDWORK = MAX( KMAX + MAX( 2*NMAX, 8*KMAX ), $ 42*KMAX + NMAX, 80*KMAX - 48 ), $ LIWORK = 4*KMAX ) DOUBLE PRECISION HUND, ZERO PARAMETER ( HUND = 1.0D2, ZERO = 0.0D0 ) * * .. Local Scalars .. CHARACTER COMPQ, DEFL, JOB, STRONG INTEGER H, I, IHI, ILO, INFO, IWARN, J, K, L, M, N, P DOUBLE PRECISION TOL * * .. Local Arrays .. LOGICAL SELECT( NMAX ) INTEGER IWORK( LIWORK ), IXQ( KMAX ), IXT( KMAX ), $ LDQ( KMAX ), LDT( KMAX ), ND( KMAX ), $ NI( KMAX ), QIND( KMAX ), S( KMAX ), $ SCAL( NMAX ) DOUBLE PRECISION A( LDA1, LDA2, KMAX ), ALPHAI( NMAX ), $ ALPHAR( NMAX ), BETA( NMAX ), DWORK( LDWORK), $ Q( LDQ1, LDQ2, KMAX ), QK( NMAX*NMAX*KMAX ), $ T( NMAX*NMAX*KMAX ) * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL DLACPY, MB03BD, MB03KD * * .. Intrinsic Functions .. INTRINSIC INT, MAX * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, DEFL, COMPQ, STRONG, K, N, H, ILO, IHI IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE TOL = HUND READ( NIN, FMT = * ) ( S( I ), I = 1, K ) READ( NIN, FMT = * ) ( ( ( A( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'U' ) ) $ READ( NIN, FMT = * ) ( ( ( Q( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'P' ) ) THEN READ( NIN, FMT = * ) ( QIND( I ), I = 1, K ) DO 10 L = 1, K IF( QIND( L ).GT.0 ) $ READ( NIN, FMT = * ) ( ( Q( I, J, QIND( L ) ), $ J = 1, N ), I = 1, N ) 10 CONTINUE END IF IF( LSAME( JOB, 'E' ) ) $ JOB = 'S' * Compute the eigenvalues and the transformed matrices. CALL MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, A, $ LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, BETA, $ SCAL, IWORK, LIWORK, DWORK, LDWORK, IWARN, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE IF( IWARN.EQ.0 ) THEN * Prepare the data for calling MB03KD, which uses different * data structures and reverse ordering of the factors. DO 20 L = 1, K ND( L ) = MAX( 1, N ) NI( L ) = 0 LDT( L ) = MAX( 1, N ) IXT( L ) = ( L - 1 )*LDT( L )*N + 1 LDQ( L ) = MAX( 1, N ) IXQ( L ) = IXT( L ) IF( L.LE.INT( K/2 ) ) THEN I = S( K - L + 1 ) S( K - L + 1 ) = S( L ) S( L ) = I END IF 20 CONTINUE DO 30 L = 1, K CALL DLACPY( 'Full', N, N, A( 1, 1, K-L+1 ), LDA1, $ T( IXT( L ) ), LDT( L ) ) 30 CONTINUE IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN COMPQ = 'U' DO 40 L = 1, K CALL DLACPY( 'Full', N, N, Q( 1, 1, K-L+1 ), LDQ1, $ QK( IXQ( L ) ), LDQ( L ) ) 40 CONTINUE ELSE IF( LSAME( COMPQ, 'P' ) ) THEN COMPQ = 'W' DO 50 L = 1, K IF( QIND( L ).LT.0 ) $ QIND( L ) = 2 P = QIND( L ) IF( P.NE.0 ) $ CALL DLACPY( 'Full', N, N, Q( 1, 1, K-P+1 ), LDQ1, $ QK( IXQ( P ) ), LDQ( P ) ) 50 CONTINUE END IF * Select eigenvalues with negative real part. DO 60 I = 1, N SELECT( I ) = ALPHAR( I ).LT.ZERO 60 CONTINUE WRITE( NOUT, FMT = 99996 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, N ) WRITE( NOUT, FMT = 99994 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, N ) WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, N ) WRITE( NOUT, FMT = 99992 ) WRITE( NOUT, FMT = 99991 ) ( SCAL( I ), I = 1, N ) * Compute the transformed matrices, after reordering the * eigenvalues. CALL MB03KD( COMPQ, QIND, STRONG, K, N, H, ND, NI, S, $ SELECT, T, LDT, IXT, QK, LDQ, IXQ, M, TOL, $ IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99990 ) INFO ELSE WRITE( NOUT, FMT = 99989 ) DO 80 L = 1, K P = K - L + 1 WRITE( NOUT, FMT = 99988 ) L DO 70 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( T( IXT( P ) + I - 1 + ( J - 1 )*LDT( P ) ), $ J = 1, N ) 70 CONTINUE 80 CONTINUE IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN WRITE( NOUT, FMT = 99987 ) DO 100 L = 1, K P = K - L + 1 WRITE( NOUT, FMT = 99988 ) L DO 90 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( QK( IXQ( P ) + I - 1 + $ ( J - 1 )*LDQ( P ) ), J = 1, N ) 90 CONTINUE 100 CONTINUE ELSE IF( LSAME( COMPQ, 'W' ) ) THEN WRITE( NOUT, FMT = 99987 ) DO 120 L = 1, K IF( QIND( L ).GT.0 ) THEN P = K - QIND( L ) + 1 WRITE( NOUT, FMT = 99988 ) QIND( L ) DO 110 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( QK( IXQ( P ) + I - 1 + $ ( J - 1 )*LDQ( P ) ), J = 1, N ) 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE WRITE( NOUT, FMT = 99979 ) IWARN END IF END IF STOP * 99999 FORMAT( 'MB03KD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB03BD = ', I2 ) 99996 FORMAT( 'The vector ALPHAR is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The vector ALPHAI is ' ) 99993 FORMAT( 'The vector BETA is ' ) 99992 FORMAT( 'The vector SCAL is ' ) 99991 FORMAT( 50( 1X, I5 ) ) 99990 FORMAT( 'INFO on exit from MB03KD = ', I2 ) 99989 FORMAT( 'The matrix A on exit is ' ) 99988 FORMAT( 'The factor ', I2, ' is ' ) 99987 FORMAT( 'The matrix Q on exit is ' ) 99986 FORMAT( 'LDT', 3I5 ) 99985 FORMAT( 'IXT', 3I5 ) 99984 FORMAT( 'LDQ', 3I5 ) 99983 FORMAT( 'IXQ', 3I5 ) 99982 FORMAT( 'ND' , 3I5 ) 99981 FORMAT( 'NI' , 3I5) 99980 FORMAT( 'SELECT', 3L5 ) 99979 FORMAT( 'IWARN on exit from MB03BD = ', I2 ) END slicot-5.0+20101122/examples/TMB03LD.f000077500000000000000000000077701201767322700165560ustar00rootroot00000000000000* MB03LD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 50 ) INTEGER LDA, LDB, LDDE, LDFG, LDQ, LDWORK, LIWORK PARAMETER ( LDA = NMAX/2, LDB = NMAX/2, LDDE = NMAX/2, $ LDFG = NMAX/2, LDQ = 2*NMAX, $ LDWORK = 8*NMAX*NMAX + $ MAX( 8*NMAX + 32, NMAX/2 + 168, $ 272 ), $ LIWORK = MAX( NMAX/2 + 32, 2*NMAX + 1 ) ) * * .. Local Scalars .. CHARACTER COMPQ, ORTH INTEGER I, INFO, J, M, N, NEIG * * .. Local Arrays .. LOGICAL BWORK( NMAX/2 ) INTEGER IWORK( LIWORK ) DOUBLE PRECISION A( LDA, NMAX/2 ), ALPHAI( NMAX/2 ), $ ALPHAR( NMAX/2 ), B( LDB, NMAX/2 ), $ BETA( NMAX/2 ), DE( LDDE, NMAX/2+1 ), $ DWORK( LDWORK ), FG( LDFG, NMAX/2+1 ), $ Q( LDQ, 2*NMAX ) * * .. External Subroutines .. EXTERNAL MB03LD * * .. Intrinsic Functions .. INTRINSIC MAX * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) COMPQ, ORTH, N IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE M = N/2 READ( NIN, FMT = * ) ( ( A( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( DE( I, J ), J = 1, M+1 ), I = 1, M ) READ( NIN, FMT = * ) ( ( B( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( FG( I, J ), J = 1, M+1 ), I = 1, M ) * Compute the eigenvalues and an orthogonal basis of the right * deflating subspace of a real skew-Hamiltonian/Hamiltonian * pencil, corresponding to the eigenvalues with strictly negative * real part. CALL MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, BWORK, $ IWORK, LIWORK, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE WRITE( NOUT, FMT = 99996 ) DO 10 I = 1, M WRITE( NOUT, FMT = 99995 ) ( A( I, J ), J = 1, M ) 10 CONTINUE WRITE( NOUT, FMT = 99994 ) DO 20 I = 1, M WRITE( NOUT, FMT = 99995 ) ( DE( I, J ), J = 1, M+1 ) 20 CONTINUE WRITE( NOUT, FMT = 99993 ) DO 30 I = 1, M WRITE( NOUT, FMT = 99995 ) ( B( I, J ), J = 1, M ) 30 CONTINUE WRITE( NOUT, FMT = 99992 ) DO 40 I = 1, M WRITE( NOUT, FMT = 99995 ) ( FG( I, J ), J = 2, M+1 ) 40 CONTINUE WRITE( NOUT, FMT = 99991 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M ) WRITE( NOUT, FMT = 99990 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M ) WRITE( NOUT, FMT = 99989 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, M ) WRITE( NOUT, FMT = 99988 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q( I, J ), J = 1, NEIG ) 50 CONTINUE END IF END IF STOP * 99999 FORMAT( 'MB03LD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB03LD = ', I2 ) 99996 FORMAT( 'The matrix A on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix DE on exit is ' ) 99993 FORMAT( 'The matrix C1 on exit is ' ) 99992 FORMAT( 'The matrix V on exit is ' ) 99991 FORMAT( 'The vector ALPHAR is ' ) 99990 FORMAT( 'The vector ALPHAI is ' ) 99989 FORMAT( 'The vector BETA is ' ) 99988 FORMAT( 'The matrix Q is ' ) END slicot-5.0+20101122/examples/TMB03MD.f000077500000000000000000000055521201767322700165530ustar00rootroot00000000000000* MB03MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION PIVMIN, RELTOL, SAFMIN, THETA, TOL INTEGER I, INFO, IWARN, L, N * .. Local Arrays .. DOUBLE PRECISION E(NMAX-1), E2(NMAX-1), Q(NMAX), Q2(NMAX) * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. External Subroutines .. EXTERNAL MB03MD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, THETA, L, TOL, RELTOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( L.LT.0 .OR. L.GT.N ) THEN WRITE ( NOUT, FMT = 99990 ) L ELSE READ ( NIN, FMT = * ) ( Q(I), I = 1,N ) READ ( NIN, FMT = * ) ( E(I), I = 1,N-1 ) * Print out the bidiagonal matrix J. WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N - 1 WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) N, N, Q(N) * Compute Q**2, E**2, and PIVMIN. Q2(N) = Q(N)**2 PIVMIN = Q2(N) DO 40 I = 1, N - 1 Q2(I) = Q(I)**2 E2(I) = E(I)**2 PIVMIN = MAX( PIVMIN, Q2(I), E2(I) ) 40 CONTINUE SAFMIN = DLAMCH( 'Safe minimum' ) PIVMIN = MAX( PIVMIN*SAFMIN, SAFMIN ) TOL = MAX( TOL, ZERO ) IF ( RELTOL.LE.ZERO ) $ RELTOL = DLAMCH( 'Base' )*DLAMCH( 'Epsilon' ) * Compute an upper bound THETA such that J has 3 singular values * < = THETA. CALL MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL, $ IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99994 ) IWARN WRITE ( NOUT, FMT = 99993 ) THETA WRITE ( NOUT, FMT = 99992 ) L END IF END IF STOP * 99999 FORMAT (' MB03MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03MD = ',I2) 99997 FORMAT (' The Bidiagonal Matrix J is',/) 99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99995 FORMAT (' (',I1,',',I1,') = ',F7.4) 99994 FORMAT (' IWARN on exit from MB03MD = ',I2,/) 99993 FORMAT (/' The computed value of THETA is ',F7.4) 99992 FORMAT (/' J has ',I2,' singular values < = THETA') 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' L is out of range.',/' L = ',I5) END slicot-5.0+20101122/examples/TMB03ND.f000077500000000000000000000044121201767322700165460ustar00rootroot00000000000000* MB03ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION PIVMIN, SAFMIN, THETA INTEGER I, INFO, N, NUMSV * .. Local Arrays .. DOUBLE PRECISION E(NMAX-1), E2(NMAX-1), Q(NMAX), Q2(NMAX) * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. External Functions .. INTEGER MB03ND EXTERNAL MB03ND * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, THETA IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( Q(I), I = 1,N ) READ ( NIN, FMT = * ) ( E(I), I = 1,N-1 ) * Print out the bidiagonal matrix J. WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N - 1 WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) N, N, Q(N) * Compute Q**2, E**2, and PIVMIN. Q2(N) = Q(N)**2 PIVMIN = Q2(N) DO 40 I = 1, N - 1 Q2(I) = Q(I)**2 E2(I) = E(I)**2 PIVMIN = MAX( PIVMIN, Q2(I), E2(I) ) 40 CONTINUE SAFMIN = DLAMCH( 'Safe minimum' ) PIVMIN = MAX( PIVMIN*SAFMIN, SAFMIN ) * Compute the number of singular values of J < = THETA. NUMSV = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NUMSV, THETA END IF END IF STOP * 99999 FORMAT (' MB03ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03ND = ',I2) 99997 FORMAT (' The Bidiagonal Matrix J is',/) 99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99995 FORMAT (' (',I1,',',I1,') = ',F7.4) 99994 FORMAT (/' J has ',I2,' singular values < = ',F7.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB03OD.f000077500000000000000000000045061201767322700165530ustar00rootroot00000000000000* MB03OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDTAU PARAMETER ( LDTAU = MIN(MMAX,NMAX) ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX + 1 ) * .. Local Scalars .. CHARACTER*1 JOBQR INTEGER I, INFO, J, M, N, RANK DOUBLE PRECISION RCOND, SVAL(3), SVLMAX * .. * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU) INTEGER JPVT(NMAX) * .. External Subroutines .. EXTERNAL MB03OD * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, JOBQR, RCOND, SVLMAX IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) * QR with column pivoting. DO 10 I = 1, N JPVT(I) = 0 10 CONTINUE CALL MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, $ RANK, SVAL, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99995 ) RANK WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,N ) WRITE ( NOUT, FMT = 99993 ) ( SVAL(I), I = 1,3 ) END IF END IF END IF * STOP * 99999 FORMAT (' MB03OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03OD = ',I2) 99995 FORMAT (' The rank is ',I5) 99994 FORMAT (' Column permutations are ',/(20(I3,2X))) 99993 FORMAT (' SVAL vector is ',/(20(1X,F10.4))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TMB03PD.f000077500000000000000000000044641201767322700165570ustar00rootroot00000000000000* MB03PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDTAU PARAMETER ( LDTAU = MIN(MMAX,NMAX) ) INTEGER LDWORK PARAMETER ( LDWORK = 3*MMAX ) * .. Local Scalars .. CHARACTER*1 JOBRQ INTEGER I, INFO, J, M, N, RANK DOUBLE PRECISION RCOND, SVAL(3), SVLMAX * .. * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU) INTEGER JPVT(MMAX) * .. External Subroutines .. EXTERNAL MB03PD * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, JOBRQ, RCOND, SVLMAX IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) * RQ with row pivoting. DO 10 I = 1, M JPVT(I) = 0 10 CONTINUE CALL MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, $ RANK, SVAL, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99995 ) RANK WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,M ) WRITE ( NOUT, FMT = 99993 ) ( SVAL(I), I = 1,3 ) END IF END IF END IF * STOP * 99999 FORMAT (' MB03PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03PD = ',I2) 99995 FORMAT (' The rank is ',I5) 99994 FORMAT (' Row permutations are ',/(20(I3,2X))) 99993 FORMAT (' SVAL vector is ',/(20(1X,F10.4))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TMB03QD.f000077500000000000000000000050721201767322700165540ustar00rootroot00000000000000* MB03QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 10 ) INTEGER LDA, LDU PARAMETER ( LDA = NMAX, LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 DICO, JOBU, STDOM INTEGER I, INFO, J, N, NDIM, NLOW, NSUP DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), U(LDU,NMAX), $ WI(NMAX), WR(NMAX) LOGICAL BWORK(NMAX) * .. External Functions .. LOGICAL SELECT * .. External Subroutines .. EXTERNAL DGEES, MB03QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NLOW, NSUP, ALPHA, DICO, STDOM, JOBU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Compute Schur form, eigenvalues and Schur vectors. CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, NDIM, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE * Block reordering. CALL MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, $ A, LDA, U, LDU, NDIM, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) NDIM WRITE ( NOUT, FMT = 99994 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB03QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DGEES = ',I2) 99997 FORMAT (' INFO on exit from MB03QD = ',I2) 99996 FORMAT (' The number of eigenvalues in the domain is ',I5) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' The ordered Schur form matrix is ') 99993 FORMAT (/' The transformation matrix is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB03RD.f000077500000000000000000000052711201767322700165560ustar00rootroot00000000000000* MB03RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 10 ) INTEGER LDA, LDX PARAMETER ( LDA = NMAX, LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 JOBX, SORT INTEGER I, INFO, J, N, NBLCKS, SDIM DOUBLE PRECISION PMAX, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), WI(NMAX), WR(NMAX), $ X(LDX,NMAX) INTEGER BLSIZE(NMAX) LOGICAL BWORK(NMAX) * .. External Functions .. LOGICAL SELECT * .. External Subroutines .. EXTERNAL DGEES, MB03RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, PMAX, TOL, JOBX, SORT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Compute Schur form, eigenvalues and Schur vectors. CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, SDIM, $ WR, WI, X, LDX, DWORK, LDWORK, BWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE * Block-diagonalization. CALL MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, $ BLSIZE, WR, WI, TOL, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99995 ) NBLCKS WRITE ( NOUT, FMT = 99994 ) ( BLSIZE(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99993 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB03RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DGEES = ',I2) 99997 FORMAT (' INFO on exit from MB03RD = ',I2) 99995 FORMAT (' The number of blocks is ',I5) 99994 FORMAT (' The orders of blocks are ',/(20(I3,2X))) 99993 FORMAT (' The block-diagonal matrix is ') 99992 FORMAT (8X,20(1X,F8.4)) 99991 FORMAT (' The transformation matrix is ') 99972 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB03SD.f000077500000000000000000000040531201767322700165540ustar00rootroot00000000000000* MB03SD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX+1 ) ) * .. Local Scalars .. INTEGER I, INFO, J, N CHARACTER*1 JOBSCL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), QG(LDQG,NMAX+1), $ WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL MB03SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * NOTE: input must define a square-reduced Hamiltonian matrix. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOBSCL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99998 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), I = J,N ), J = 1,N ) * Compute the eigenvalues. CALL MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE * Show the computed eigenvalues. WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) WR(I), ' + (', WI(I), ')i' 10 CONTINUE DO 20 I = N, 1, -1 WRITE ( NOUT, FMT = 99995 ) -WR(I), ' + (', -WI(I), ')i' 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB03SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' N is out of range.',/' N = ',I5) 99997 FORMAT (' INFO on exit from MB03SD = ',I2) 99996 FORMAT (/' The eigenvalues are ') 99995 FORMAT (1X,F8.4,A,F8.4,A) END slicot-5.0+20101122/examples/TMB03TD.f000077500000000000000000000070601201767322700165560ustar00rootroot00000000000000* MB03TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDG, LDRES, LDU1, LDU2, LDWORK PARAMETER ( LDA = NMAX, LDG = NMAX, LDRES = NMAX, $ LDU1 = NMAX, LDU2 = NMAX, LDWORK = 8*NMAX ) * .. Local Scalars .. CHARACTER*1 COMPU, TYP INTEGER I, INFO, J, N, M * .. Local Arrays .. LOGICAL LOWER(NMAX), SELECT(NMAX) DOUBLE PRECISION A(LDA, NMAX), DWORK(LDWORK), G(LDG, NMAX), $ RES(LDRES,NMAX), U1(LDU1,NMAX), U2(LDU2,NMAX), $ WR(NMAX), WI(NMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION MA02JD EXTERNAL LSAME, MA02JD * .. External Subroutines .. EXTERNAL MB03TD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TYP, COMPU IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( SELECT(J), J = 1,N ) READ ( NIN, FMT = * ) ( LOWER(J), J = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( COMPU, 'U' ) ) THEN READ ( NIN, FMT = * ) ( ( U1(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( U2(I,J), J = 1,N ), I = 1,N ) END IF CALL MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( COMPU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99992 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) END IF * WRITE ( NOUT, FMT = 99996 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N ) 30 CONTINUE * WRITE ( NOUT, FMT = 99995 ) IF ( LSAME( TYP, 'S' ) ) THEN DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( -G(J,I), J = 1,I-1 ), ZERO, ( G(I,J), J = I+1,N ) 40 CONTINUE ELSE DO 50 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( G(J,I), J = 1,I-1 ), ( G(I,J), J = I,N ) 50 CONTINUE END IF END IF END IF * 99999 FORMAT (' MB03TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03TD = ',I2) 99997 FORMAT (' The orthogonal symplectic factor U is ') 99996 FORMAT (/' The matrix A in reordered Schur canonical form is ') 99995 FORMAT (/' The matrix G is ') 99994 FORMAT (20(1X,F9.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB03UD.f000077500000000000000000000045121201767322700165560ustar00rootroot00000000000000* MB03UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 10 ) INTEGER LDA, LDQ PARAMETER ( LDA = NMAX, LDQ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 5*NMAX ) ) * .. Local Scalars .. CHARACTER*1 JOBQ, JOBP INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), Q(LDQ,NMAX), $ SV(NMAX) * .. External Functions .. LOGICAL LSAME * .. External Subroutines .. EXTERNAL MB03UD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOBQ, JOBP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Compute the singular values and vectors. CALL MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99995 ) ( SV(I), I = 1,N ) IF ( LSAME( JOBP, 'V' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE END IF IF ( LSAME( JOBQ, 'V' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB03UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03UD = ',I2) 99997 FORMAT (' Singular values are ',I5) 99996 FORMAT (/' The transpose of the right singular vectors matrix is ' $ ) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' The left singular vectors matrix is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB03VD.f000077500000000000000000000113321201767322700165550ustar00rootroot00000000000000* MB03VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA1, LDA2, LDQ1, LDQ2, LDTAU PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX, $ LDQ2 = NMAX, LDTAU = NMAX-1 ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION SSQ INTEGER I, IHI, ILO, INFO, J, K, KP1, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA1,LDA2,PMAX), AS(LDA1,LDA2,PMAX), $ DWORK(LDWORK), Q(LDQ1,LDQ2,PMAX), $ QTA(LDQ1,NMAX), TAU(LDTAU,PMAX) * .. External Functions .. DOUBLE PRECISION DLANGE, DLAPY2 EXTERNAL DLANGE, DLAPY2 * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, MB03VD, MB03VY * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. WRITE (NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, ILO, IHI IF ( N.LT.0 .OR. N.GT.MIN( LDA1, LDA2 ) ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE * Read matrices A_1, ..., A_p from the input file. DO 10 K = 1, P READ ( NIN, FMT = * ) $ ( ( A(I,J,K), J = 1, N ), I = 1, N ) CALL DLACPY( 'F', N, N, A(1,1,K), LDA1, AS(1,1,K), LDA1 ) 10 CONTINUE * Reduce to the periodic Hessenberg form. CALL MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, $ DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 30 K = 1, P CALL DLACPY( 'L', N, N, A(1,1,K), LDA1, Q(1,1,K), $ LDQ1 ) IF ( N.GT.1 ) THEN IF ( N.GT.2 .AND. K.EQ.1 ) THEN CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, $ A(3,1,K), LDA1 ) ELSE IF ( K.GT.1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ A(2,1,K), LDA1 ) END IF END IF WRITE ( NOUT, FMT = 99995 ) K DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( A(I,J,K), J = 1, N ) 20 CONTINUE 30 CONTINUE * Accumulate the transformations. CALL MB03VY( N, P, ILO, IHI, Q, LDQ1, LDQ2, TAU, LDTAU, $ DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99993 ) DO 50 K = 1, P WRITE ( NOUT, FMT = 99995 ) K DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( Q(I,J,K), J = 1, N ) 40 CONTINUE 50 CONTINUE * Compute error. SSQ = ZERO DO 60 K = 1, P KP1 = K+1 IF( KP1.GT.P ) KP1 = 1 * Compute NORM (Z' * A * Z - Aout) CALL DGEMM( 'T', 'N', N, N, N, ONE, Q(1,1,K), LDQ1, $ AS(1,1,K), LDA1, ZERO, QTA, LDQ1 ) CALL DGEMM( 'N', 'N', N, N, N, ONE, QTA, LDQ1, $ Q(1,1,KP1), LDQ1, -ONE, A(1,1,K), $ LDA1 ) SSQ = DLAPY2( SSQ, $ DLANGE( 'Frobenius', N, N, A(1,1,K), $ LDA1, DWORK ) ) 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) SSQ END IF END IF END IF END IF STOP 99999 FORMAT (' MB03VD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from MB03VD = ', I2) 99997 FORMAT (' INFO on exit from MB03VY = ', I2) 99996 FORMAT (' Reduced matrices') 99995 FORMAT (/' K = ', I5) 99994 FORMAT (8F8.4) 99993 FORMAT (/' Transformation matrices') 99992 FORMAT (/,' NORM (Q''*A*Q - Aout) = ', 1PD12.5) 99991 FORMAT (/, ' N is out of range.',/' N = ', I5) 99990 FORMAT (/, ' P is out of range.',/' P = ', I5) END slicot-5.0+20101122/examples/TMB03WD.f000077500000000000000000000147261201767322700165700ustar00rootroot00000000000000* MB03WD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA1, LDA2, LDTAU, LDZ1, LDZ2, LDZTA PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDTAU = NMAX-1, $ LDZ1 = NMAX, LDZ2 = NMAX, LDZTA = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX, NMAX + PMAX - 2 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION SSQ INTEGER I, IHI, IHIZ, ILO, ILOZ, INFO, J, K, KP1, N, P CHARACTER COMPZ, JOB * .. Local Arrays .. DOUBLE PRECISION A(LDA1,LDA2,PMAX), AS(LDA1,LDA2,PMAX), $ DWORK(LDWORK), TAU(LDTAU,PMAX), WI(NMAX), $ WR(NMAX), Z(LDZ1,LDZ2,PMAX), ZTA(LDZTA,NMAX) * .. External Functions .. DOUBLE PRECISION DLANGE, DLAPY2 LOGICAL LSAME EXTERNAL DLANGE, DLAPY2, LSAME * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, MB03VD, MB03VY, MB03WD, MB03WX * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. WRITE (NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, ILO, IHI, ILOZ, IHIZ, JOB, COMPZ IF ( N.LT.0 .OR. N.GT.MIN( LDA1, LDA2 ) ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99987 ) P ELSE * Read matrices A_1, ..., A_p from the input file. DO 10 K = 1, P READ ( NIN, FMT = * ) $ ( ( A(I,J,K), J = 1, N ), I = 1, N ) CALL DLACPY( 'F', N, N, A(1,1,K), LDA1, AS(1,1,K), LDA1 ) 10 CONTINUE * Reduce to the periodic Hessenberg form. CALL MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, $ DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE IF ( LSAME( COMPZ, 'V' ) ) THEN DO 20 K = 1, P CALL DLACPY( 'L', N, N, A(1,1,K), LDA1, Z(1,1,K), $ LDZ1 ) 20 CONTINUE * Accumulate the transformations. CALL MB03VY( N, P, ILO, IHI, Z, LDZ1, LDZ2, TAU, $ LDTAU, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) INFO STOP ELSE * Reduce to the periodic Schur form. CALL MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, $ IHIZ, A, LDA1, LDA2, Z, LDZ1, LDZ2, $ WR, WI, DWORK, LDWORK, INFO ) IF ( INFO.GT.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO WRITE ( NOUT, FMT = 99991 ) DO 30 I = MAX( ILO, INFO + 1 ), IHI WRITE ( NOUT, FMT = 99990 ) WR(I), WI(I) 30 CONTINUE STOP END IF IF ( INFO.LT.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE * Store the isolated eigenvalues. CALL MB03WX( ILO-1, P, A, LDA1, LDA2, WR, WI, $ INFO ) IF ( IHI.LT.N ) $ CALL MB03WX( N-IHI, P, A(IHI+1,IHI+1,1), $ LDA1, LDA2, WR(IHI+1), $ WI(IHI+1), INFO ) WRITE ( NOUT, FMT = 99991 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99990 ) WR(I), WI(I) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 K = 1, P WRITE ( NOUT, FMT = 99994 ) K DO 50 I = 1, N WRITE ( NOUT, FMT = 99993 ) $ ( A(I,J,K), J = 1, N ) 50 CONTINUE 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 80 K = 1, P WRITE ( NOUT, FMT = 99994 ) K DO 70 I = 1, N WRITE ( NOUT, FMT = 99993 ) $ ( Z(I,J,K), J = 1, N ) 70 CONTINUE 80 CONTINUE * Compute error. SSQ = ZERO DO 90 K = 1, P KP1 = K+1 IF( KP1.GT.P ) KP1 = 1 * Compute NORM (Z' * A * Z - Aout) CALL DGEMM( 'T', 'N', N, N, N, ONE, Z(1,1,K), $ LDZ1, AS(1,1,K), LDA1, ZERO, ZTA, $ LDZTA ) CALL DGEMM( 'N', 'N', N, N, N, ONE, ZTA, $ LDZTA, Z(1,1,KP1), LDZ1, -ONE, $ A(1,1,K), LDA1 ) SSQ = DLAPY2( SSQ, $ DLANGE( 'Frobenius', N, N, $ A(1,1,K), LDA1, $ DWORK ) ) 90 CONTINUE WRITE ( NOUT, FMT = 99989 ) SSQ END IF END IF END IF END IF END IF END IF STOP 99999 FORMAT (' MB03WD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from MB03WD = ', I2) 99997 FORMAT (' INFO on exit from MB03VD = ', I2) 99996 FORMAT (' INFO on exit from MB03VY = ', I2) 99995 FORMAT (/' Reduced matrices') 99994 FORMAT (/' K = ', I5) 99993 FORMAT (8F8.4) 99992 FORMAT (/' Transformation matrices') 99991 FORMAT ( ' Computed eigenvalues'/) 99990 FORMAT (4X,'( ', F17.6,' ,', F17.6,' )') 99989 FORMAT (/,' NORM (Z''*A*Z - Aout) = ', 1PD12.5) 99988 FORMAT (/, ' N is out of range.',/' N = ', I5) 99987 FORMAT (/, ' P is out of range.',/' P = ', I5) END slicot-5.0+20101122/examples/TMB03XD.f000077500000000000000000000177031201767322700165670ustar00rootroot00000000000000* MB03XD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG, LDRES, LDT, LDU1, LDU2, LDV1, LDV2, $ LDWORK PARAMETER ( LDA = NMAX, LDQG = NMAX, LDRES = NMAX, $ LDT = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDV1 = NMAX, LDV2 = NMAX, $ LDWORK = 3*NMAX*NMAX + 7*NMAX ) * .. Local Scalars .. CHARACTER*1 BALANC, JOB, JOBU, JOBV INTEGER I, ILO, INFO, J, N DOUBLE PRECISION TEMP * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), DWORK(LDWORK), QG(LDQG, NMAX+1), $ RES(LDRES,3*NMAX+1), SCALE(NMAX), T(LDT,NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX), V1(LDV1,NMAX), $ V2(LDV2, NMAX), WI(NMAX), WR(NMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLAPY2, MA02JD EXTERNAL DLANGE, DLAPY2, LSAME, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, MB03XD, MB04DD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, BALANC, JOB, JOBU, JOBV IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES ) INFO = 0 CALL 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 ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, WR(I), WI(I) 20 CONTINUE IF ( LSAME( JOB, 'S' ).OR.LSAME( JOB, 'G' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99990 ) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99990 ) ( T(I,J), J = 1,N ) 40 CONTINUE END IF IF ( LSAME( JOB, 'G' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99990 ) ( QG(I,J+1), J = 1,N ) 50 CONTINUE END IF C IF ( LSAME( JOB, 'G' ).AND.LSAME( JOBU, 'U' ).AND. $ LSAME( JOBV, 'V' ) ) THEN CALL MB04DD( BALANC, N, RES(1,N+1), LDRES, RES(1,2*N+1), $ LDRES, I, DWORK, INFO ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, V1, LDV1, ZERO, RES, $ LDRES ) CALL DSYMM ( 'Left', 'Upper', N, N, -ONE, RES(1,2*N+2), $ LDRES, V2, LDV2, ONE, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ -ONE, U1, LDU1, T, LDT, ONE, RES, LDRES ) TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DWORK ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, V2, LDV2, ZERO, RES, $ LDRES ) CALL DSYMM( 'Left', 'Upper', N, N, ONE, RES(1,2*N+2), $ LDRES, V1, LDV1, ONE, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ -ONE, U1, LDU1, QG(1,2), LDQG, ONE, RES, $ LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, U2, LDU2, A, LDA, ONE, RES, LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) ) CALL DSYMM( 'Left', 'Lower', N, N, ONE, RES(1,2*N+1), $ LDRES, V1, LDV1, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, V2, LDV2, ONE, RES, $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, T, LDT, ONE, RES, LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) ) CALL DSYMM( 'Left', 'Lower', N, N, ONE, RES(1,2*N+1), $ LDRES, V2, LDV2, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, -ONE, $ RES(1,N+1), LDRES, V1, LDV1, ONE, RES, $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, QG(1,2), LDQG, ONE, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, U1, LDU1, A, LDA, ONE, RES, LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) ) WRITE ( NOUT, FMT = 99987 ) TEMP END IF C IF ( LSAME( JOBU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 60 CONTINUE DO 70 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 70 CONTINUE WRITE ( NOUT, FMT = 99986 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) END IF IF ( LSAME( JOBV, 'V' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( V1(I,J), J = 1,N ), ( V2(I,J), J = 1,N ) 80 CONTINUE DO 90 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( -V2(I,J), J = 1,N ), ( V1(I,J), J = 1,N ) 90 CONTINUE WRITE ( NOUT, FMT = 99985 ) MA02JD( .FALSE., .FALSE., N, $ V1, LDV1, V2, LDV2, RES, LDRES ) END IF IF ( LSAME( BALANC, 'S' ).OR.LSAME( BALANC, 'B' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, SCALE(I) 100 CONTINUE END IF END IF END IF * 99999 FORMAT (' MB03XD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03XD = ',I2) 99997 FORMAT (' The stable eigenvalues are',//' i',6X, $ 'WR(i)',6X,'WI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' The matrix S of the reduced matrix is') 99994 FORMAT (/' The matrix T of the reduced matrix is') 99993 FORMAT (/' The matrix G of the reduced matrix is') 99992 FORMAT (/' The orthogonal symplectic factor U is') 99991 FORMAT (/' The orthogonal symplectic factor V is') 99990 FORMAT (20(1X,F19.16)) 99989 FORMAT (/' The diagonal scaling factors are ',//' i',6X, $ 'SCALE(i)',/) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2) 99986 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2) 99985 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB03XP.f000077500000000000000000000112461201767322700165770ustar00rootroot00000000000000* MB03XP EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 200 ) INTEGER LDA, LDB, LDQ, LDRES, LDZ, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDQ = NMAX, $ LDRES = NMAX, LDWORK = NMAX, LDZ = NMAX ) * .. Local Scalars .. INTEGER I, IHI, ILO, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX), $ B(LDA,NMAX), BETA(NMAX), DWORK(LDWORK), $ Q(LDQ,NMAX), RES(LDRES,3*NMAX), Z(LDZ,NMAX) * .. External Functions .. DOUBLE PRECISION DLANGE EXTERNAL DLANGE * .. External Subroutines .. EXTERNAL DGEMM, MB03XP * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, ILO, IHI IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, B, LDB, RES(1,2*N+1), LDRES ) CALL MB03XP( 'S', 'I', 'I', N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, LDWORK, $ INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE (NOUT, FMT = 99991) ( A(I,J), J = 1,N ) 10 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, Z, LDZ, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ Q, LDQ, A, LDA, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99989 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99995 ) DO 20 I = 1, N WRITE (NOUT, FMT = 99991) ( B(I,J), J = 1,N ) 20 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,2*N+1), LDRES, Q, LDQ, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ Z, LDZ, B, LDB, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99988 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99991) ( Q(I,J), J = 1,N ) 30 CONTINUE CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q, $ LDQ, Q, LDQ, ONE, RES, LDRES ) DO 40 I = 1, N RES(I,I) = RES(I,I) - ONE 40 CONTINUE WRITE ( NOUT, FMT = 99987 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99993 ) DO 50 I = 1, N WRITE (NOUT, FMT = 99991) ( Z(I,J), J = 1,N ) 50 CONTINUE CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Z, $ LDZ, Z, LDZ, ONE, RES, LDRES ) DO 60 I = 1, N RES(I,I) = RES(I,I) - ONE 60 CONTINUE WRITE ( NOUT, FMT = 99986 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99992 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99991 ) $ ALPHAR(I), ALPHAI(I), BETA(I) 70 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MB03XP EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03XP = ',I2) 99996 FORMAT (' The reduced matrix A is ') 99995 FORMAT (/' The reduced matrix B is ') 99994 FORMAT (/' The orthogonal factor Q is ') 99993 FORMAT (/' The orthogonal factor Z is ') 99992 FORMAT (/4X,'ALPHAR',4X,'ALPHAI',4X,'BETA') 99991 FORMAT (1000(1X,F9.4)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' Residual: || A*Z - Q*S ||_F = ',G7.2) 99988 FORMAT (/' Residual: || B*Q - Z*T ||_F = ',G7.2) 99987 FORMAT (/' Orthogonality of Q: || Q''*Q - I ||_F = ',G7.2) 99986 FORMAT (/' Orthogonality of Z: || Z''*Z - I ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB03ZD.f000077500000000000000000000140621201767322700165640ustar00rootroot00000000000000* MB03ZD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 200 ) INTEGER LDG, LDRES, LDS, LDT, LDU1, LDU2, LDUS, LDUU, $ LDV1, LDV2, LDWORK PARAMETER ( LDG = NMAX, LDRES = 2*NMAX, LDS = NMAX, $ LDT = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDUS = 2*NMAX, LDUU = 2*NMAX, LDV1 = NMAX, $ LDV2 = NMAX, LDWORK = 3*NMAX*NMAX + 7*NMAX ) * .. Local Scalars .. CHARACTER*1 BALANC, METH, ORTBAL, STAB, WHICH INTEGER I, ILO, INFO, J, M, N * .. Local Arrays .. LOGICAL LWORK(2*NMAX), SELECT(NMAX) INTEGER IWORK(2*NMAX) DOUBLE PRECISION DWORK(LDWORK), G(LDG, NMAX), RES(LDRES,NMAX), $ S(LDS, NMAX), SCALE(NMAX), T(LDT,NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX), US(LDUS,2*NMAX), $ UU(LDUU,2*NMAX), V1(LDV1,NMAX), V2(LDV2, NMAX), $ WI(NMAX), WR(NMAX) * .. External Functions .. EXTERNAL DLANGE, LSAME LOGICAL LSAME DOUBLE PRECISION DLANGE * .. External Subroutines .. EXTERNAL MB03ZD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, ILO, WHICH, METH, STAB, BALANC, ORTBAL IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE * IF ( LSAME( WHICH, 'S' ) ) $ READ ( NIN, FMT = * ) ( SELECT(I), I = 1,N ) READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( WHICH, 'A' ).AND.LSAME( METH, 'L' ) ) $ READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( BALANC, 'P' ).OR.LSAME( BALANC, 'S' ).OR. $ LSAME( BALANC, 'B' ) ) $ READ ( NIN, FMT = * ) ( SCALE(I), I = 1,N ) READ ( NIN, FMT = * ) ( ( U1(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( U2(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( V1(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( V2(I,J), J = 1,N ), I = 1,N ) * CALL MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, 2*N, $ 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, WR(I), WI(I) 20 CONTINUE * IF ( LSAME( STAB, 'S' ).OR.LSAME( STAB, 'B' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, 2*N WRITE ( NOUT, FMT = 99993 ) ( US(I,J), J = 1,M ) 30 CONTINUE IF ( LSAME( ORTBAL, 'B' ).OR.LSAME( BALANC, 'N' ).OR. $ LSAME( BALANC, 'P' ) ) THEN CALL DGEMM( 'Transpose', 'No Transpose', M, M, 2*N, $ ONE, US, LDUS, US, LDUS, ZERO, RES, $ LDRES ) DO 40 I = 1, M RES(I,I) = RES(I,I) - ONE 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, ONE, $ US, LDUS, US(N+1,1), LDUS, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, -ONE, $ US(N+1,1), LDUS, US, LDUS, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99990 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF * IF ( LSAME( STAB, 'U' ).OR.LSAME( STAB, 'B' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 50 I = 1, 2*N WRITE ( NOUT, FMT = 99993 ) ( UU(I,J), J = 1,M ) 50 CONTINUE IF ( LSAME( ORTBAL, 'B' ).OR.LSAME( BALANC, 'N' ).OR. $ LSAME( BALANC, 'P' ) ) THEN CALL DGEMM( 'Transpose', 'No Transpose', M, M, 2*N, $ ONE, UU, LDUU, UU, LDUU, ZERO, RES, $ LDRES ) DO 60 I = 1, M RES(I,I) = RES(I,I) - ONE 60 CONTINUE WRITE ( NOUT, FMT = 99989 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, ONE, $ UU, LDUU, UU(N+1,1), LDUU, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, -ONE, $ UU(N+1,1), LDUU, UU, LDUU, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99988 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF END IF END IF * 99999 FORMAT (' MB03ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03ZD = ',I2) 99997 FORMAT (' The stable eigenvalues are',//' i',6X, $ 'WR(i)',6X,'WI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' A basis for the stable invariant subspace is') 99994 FORMAT (/' A basis for the unstable invariant subspace is') 99993 FORMAT (20(1X,F9.3)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of US: || US''*US - I ||_F = ',G7.2) 99990 FORMAT (/' Symplecticity of US: || US''*J*US ||_F = ',G7.2) 99989 FORMAT (/' Orthogonality of UU: || UU''*UU - I ||_F = ',G7.2) 99988 FORMAT (/' Symplecticity of UU: || UU''*J*UU ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB04AD.f000077500000000000000000000125131201767322700165330ustar00rootroot00000000000000* MB04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 50 ) INTEGER LDH, LDQ1, LDQ2, LDT, LDU11, LDU12, LDU21, $ LDU22, LDWORK, LDZ, LIWORK PARAMETER ( LDH = NMAX, LDQ1 = NMAX, LDQ2 = NMAX, $ LDT = NMAX, LDU11 = NMAX/2, LDU12 = NMAX/2, $ LDU21 = NMAX/2, LDU22 = NMAX/2, $ LDWORK = 3*NMAX*NMAX + MAX( NMAX, 48 ), $ LDZ = NMAX, LIWORK = NMAX/2 + 18 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * * .. Local Scalars .. CHARACTER COMPQ1, COMPQ2, COMPU1, COMPU2, JOB INTEGER I, INFO, J, M, N * * .. Local Arrays .. INTEGER IWORK( LIWORK ) DOUBLE PRECISION ALPHAI( NMAX/2 ), ALPHAR( NMAX/2 ), $ BETA( NMAX/2 ), DWORK( LDWORK ), $ H( LDH, NMAX ), Q1( LDQ1, NMAX ), $ Q2( LDQ2, NMAX ), T( LDT, NMAX ), $ U11( LDU11, NMAX/2 ), U12( LDU12, NMAX/2 ), $ U21( LDU21, NMAX/2 ), U22( LDU22, NMAX/2 ), $ Z( LDZ, NMAX ) * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL DLASET, MB04AD * * .. Intrinsic Functions .. INTRINSIC MAX * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE READ( NIN, FMT = * ) ( ( Z( I, J ), J = 1, N ), I = 1, N ) READ( NIN, FMT = * ) ( ( H( I, J ), J = 1, N ), I = 1, N ) * Compute the eigenvalues of a real skew-Hamiltonian/Hamiltonian * pencil (factored version). CALL MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ, H, $ LDH, T, LDT, Q1, LDQ1, Q2, LDQ2, U11, LDU11, U12, $ LDU12, U21, LDU21, U22, LDU22, ALPHAR, ALPHAI, $ BETA, IWORK, LIWORK, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE M = N/2 CALL DLASET( 'Full', M, M, ZERO, ZERO, Z( M+1, 1 ), LDZ ) WRITE( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE( NOUT, FMT = 99995 ) ( T( I, J ), J = 1, N ) 10 CONTINUE WRITE( NOUT, FMT = 99994 ) DO 20 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Z( I, J ), J = 1, N ) 20 CONTINUE WRITE( NOUT, FMT = 99993 ) DO 30 I = 1, N WRITE( NOUT, FMT = 99995 ) ( H( I, J ), J = 1, N ) 30 CONTINUE IF( LSAME( COMPQ1, 'C' ) ) THEN WRITE( NOUT, FMT = 99992 ) DO 40 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q1( I, J ), J = 1, N ) 40 CONTINUE END IF IF( LSAME( COMPQ2, 'C' ) ) THEN WRITE( NOUT, FMT = 99991 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q2( I, J ), J = 1, N ) 50 CONTINUE END IF IF( LSAME( COMPU1, 'C' ) ) THEN WRITE( NOUT, FMT = 99990 ) DO 60 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U11( I, J ), J = 1, M ) 60 CONTINUE WRITE( NOUT, FMT = 99989 ) DO 70 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U12( I, J ), J = 1, M ) 70 CONTINUE END IF IF( LSAME( COMPU2, 'C' ) ) THEN WRITE( NOUT, FMT = 99988 ) DO 80 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U21( I, J ), J = 1, M ) 80 CONTINUE WRITE( NOUT, FMT = 99987 ) DO 90 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U22( I, J ), J = 1, M ) 90 CONTINUE END IF WRITE( NOUT, FMT = 99986 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M ) WRITE( NOUT, FMT = 99985 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M ) WRITE( NOUT, FMT = 99984 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, M ) END IF END IF STOP * 99999 FORMAT( 'MB04AD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB04AD = ', I2 ) 99996 FORMAT( 'The matrix T on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix Z on exit is ' ) 99993 FORMAT( 'The matrix H is ' ) 99992 FORMAT( 'The matrix Q1 is ' ) 99991 FORMAT( 'The matrix Q2 is ' ) 99990 FORMAT( 'The upper left block of the matrix U1 is ' ) 99989 FORMAT( 'The upper right block of the matrix U1 is ' ) 99988 FORMAT( 'The upper left block of the matrix U2 is ' ) 99987 FORMAT( 'The upper right block of the matrix U2 is ' ) 99986 FORMAT( 'The vector ALPHAR is ' ) 99985 FORMAT( 'The vector ALPHAI is ' ) 99984 FORMAT( 'The vector BETA is ' ) END slicot-5.0+20101122/examples/TMB04BD.f000077500000000000000000000120301201767322700165260ustar00rootroot00000000000000* MB04BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 50 ) INTEGER LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1, LDQ2, $ LDVW, LDWORK, LIWORK PARAMETER ( LDA = NMAX/2, LDB = NMAX/2, LDC1 = NMAX/2, $ LDC2 = NMAX/2, LDDE = NMAX/2, LDF = NMAX/2, $ LDQ1 = NMAX, LDQ2 = NMAX, LDVW = NMAX/2, $ LDWORK = 2*NMAX*NMAX + MAX( NMAX, 32 ), $ LIWORK = NMAX/2 + 12 ) * * .. Local Scalars .. CHARACTER COMPQ1, COMPQ2, JOB INTEGER I, INFO, J, M, N * * .. Local Arrays .. INTEGER IWORK( LIWORK ) DOUBLE PRECISION A( LDA, NMAX/2 ), ALPHAI( NMAX/2 ), $ ALPHAR( NMAX/2 ), B( LDB, NMAX/2 ), $ BETA( NMAX/2 ), C1( LDC1, NMAX/2 ), $ C2( LDC2, NMAX/2 ), DE( LDDE, NMAX/2+1 ), $ DWORK( LDWORK ), F( LDF, NMAX/2 ), $ Q1( LDQ1, NMAX ), Q2( LDQ2, NMAX ), $ VW( LDVW, NMAX/2+1 ) * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL MB04BD * * .. Intrinsic Functions .. INTRINSIC MAX * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, COMPQ1, COMPQ2, N IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE M = N/2 READ( NIN, FMT = * ) ( ( A( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( DE( I, J ), J = 1, M+1 ), I = 1, M ) READ( NIN, FMT = * ) ( ( C1( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( VW( I, J ), J = 1, M+1 ), I = 1, M ) * Compute the eigenvalues of a real skew-Hamiltonian/Hamiltonian * pencil. CALL MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1, $ LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F, $ LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK, $ LIWORK, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE WRITE( NOUT, FMT = 99996 ) DO 10 I = 1, M WRITE( NOUT, FMT = 99995 ) ( A( I, J ), J = 1, M ) 10 CONTINUE WRITE( NOUT, FMT = 99994 ) DO 20 I = 1, M WRITE( NOUT, FMT = 99995 ) ( DE( I, J ), J = 2, M+1 ) 20 CONTINUE WRITE( NOUT, FMT = 99993 ) DO 30 I = 1, M WRITE( NOUT, FMT = 99995 ) ( B( I, J ), J = 1, M ) 30 CONTINUE WRITE( NOUT, FMT = 99992 ) DO 40 I = 1, M WRITE( NOUT, FMT = 99995 ) ( F( I, J ), J = 1, M ) 40 CONTINUE WRITE( NOUT, FMT = 99991 ) DO 50 I = 1, M WRITE( NOUT, FMT = 99995 ) ( C1( I, J ), J = 1, M ) 50 CONTINUE WRITE( NOUT, FMT = 99990 ) DO 60 I = 1, M WRITE( NOUT, FMT = 99995 ) ( C2( I, J ), J = 1, M ) 60 CONTINUE WRITE( NOUT, FMT = 99989 ) DO 70 I = 1, M WRITE( NOUT, FMT = 99995 ) ( VW( I, J ), J = 2, M+1 ) 70 CONTINUE WRITE( NOUT, FMT = 99988 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M ) WRITE( NOUT, FMT = 99987 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M ) WRITE( NOUT, FMT = 99986 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, M ) WRITE( NOUT, FMT = 99985 ) IF( .NOT.LSAME( COMPQ1, 'N' ) ) THEN DO 80 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q1( I, J ), J = 1, N ) 80 CONTINUE END IF IF( .NOT.LSAME( COMPQ2, 'N' ) ) THEN WRITE( NOUT, FMT = 99984 ) DO 90 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q2( I, J ), J = 1, N ) 90 CONTINUE END IF END IF END IF STOP * 99999 FORMAT( 'MB04BD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB04BD = ', I2 ) 99996 FORMAT( 'The matrix A on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix D on exit is ' ) 99993 FORMAT( 'The matrix B on exit is ' ) 99992 FORMAT( 'The matrix F on exit is ' ) 99991 FORMAT( 'The matrix C1 on exit is ' ) 99990 FORMAT( 'The matrix C2 on exit is ' ) 99989 FORMAT( 'The matrix V on exit is ' ) 99988 FORMAT( 'The vector ALPHAR is ' ) 99987 FORMAT( 'The vector ALPHAI is ' ) 99986 FORMAT( 'The vector BETA is ' ) 99985 FORMAT( 'The matrix Q1 is ' ) 99984 FORMAT( 'The matrix Q2 is ' ) END slicot-5.0+20101122/examples/TMB04DD.f000077500000000000000000000044601201767322700165400ustar00rootroot00000000000000* MB04DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, ILO, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), DUMMY(1), QG(LDQG, NMAX+1), $ SCALE(NMAX) * .. External Functions .. DOUBLE PRECISION DLANTR, DLAPY2 EXTERNAL DLANTR, DLAPY2 * .. External Subroutines .. EXTERNAL MB04DD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99995) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99995) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE WRITE (NOUT, FMT = 99993) ILO IF ( ILO.GT.1 ) THEN WRITE (NOUT, FMT = 99992) DLAPY2( DLANTR( 'Frobenius', $ 'Lower', 'No Unit', N-1, ILO-1, A(2,1), LDA, $ DUMMY ), DLANTR( 'Frobenius', 'Lower', 'No Unit', $ N, ILO-1, QG(1,1), LDQG, DUMMY ) ) END IF END IF END IF * 99999 FORMAT (' MB04DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04DD = ',I2) 99997 FORMAT (' The balanced matrix A is ') 99996 FORMAT (/' The balanced matrix QG is ') 99995 FORMAT (20(1X,F12.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' ILO = ',I4) 99992 FORMAT (/' Norm of subdiagonal blocks: ',G7.2) END slicot-5.0+20101122/examples/TMB04DS.f000077500000000000000000000044611201767322700165600ustar00rootroot00000000000000* MB04DS EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, ILO, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), DUMMY(1), QG(LDQG, NMAX+1), $ SCALE(NMAX) * .. External Functions .. DOUBLE PRECISION DLANTR, DLAPY2 EXTERNAL DLANTR, DLAPY2 * .. External Subroutines .. EXTERNAL MB04DS * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99995) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99995) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE WRITE (NOUT, FMT = 99993) ILO IF ( ILO.GT.1 ) THEN WRITE (NOUT, FMT = 99992) DLAPY2( DLANTR( 'Frobenius', $ 'Lower', 'No Unit', N-1, ILO-1, A(2,1), LDA, $ DUMMY ), DLANTR( 'Frobenius', 'Lower', 'No Unit', $ N-1, ILO-1, QG(2,1), LDQG, DUMMY ) ) END IF END IF END IF * 99999 FORMAT (' MB04DS EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04DS = ',I2) 99997 FORMAT (' The balanced matrix A is ') 99996 FORMAT (/' The balanced matrix QG is ') 99995 FORMAT (20(1X,F9.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' ILO = ',I4) 99992 FORMAT (/' Norm of subdiagonal blocks: ',G7.2) END slicot-5.0+20101122/examples/TMB04DY.f000077500000000000000000000051471201767322700165700ustar00rootroot00000000000000* MB04DY EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N CHARACTER*1 JOBSCL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), D(NMAX), DWORK(LDWORK), $ QG(LDQG,NMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04DY * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOBSCL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99998 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), I = J,N ), J = 1,N ) * Scale the Hamiltonian matrix. CALL MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE * Show the scaled Hamiltonian matrix. WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99993 ) ( A(I,J), J = 1,N ), $ ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N ) 10 CONTINUE DO 20 I = 1, N WRITE ( NOUT, FMT = 99993 ) ( QG(I,J), J = 1,I-1 ), $ ( QG(J,I), J = I,N ), ( -A(J,I), J = 1,N ) 20 CONTINUE * Show the scaling factors. IF ( LSAME( JOBSCL, 'S' ) ) THEN WRITE ( NOUT, FMT = 99995 ) WRITE ( NOUT, FMT = 99993 ) ( D(I), I = 1,N ) ELSE IF ( LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) ) $ THEN WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99993 ) D(1) END IF ENDIF END IF STOP * 99999 FORMAT (' MB04DY EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' N is out of range.',/' N = ',I5) 99997 FORMAT (' INFO on exit from MB04DY = ',I2) 99996 FORMAT (/' The scaled Hamiltonian is ') 99995 format (/' The scaling factors are ') 99994 format (/' The scaling factor tau is ') 99993 FORMAT (1X,8(F10.4)) END slicot-5.0+20101122/examples/TMB04GD.f000077500000000000000000000050351201767322700165420ustar00rootroot00000000000000* MB04GD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDA PARAMETER ( LDA = MMAX ) INTEGER LDTAU PARAMETER ( LDTAU = MIN(MMAX,NMAX) ) INTEGER LDWORK PARAMETER ( LDWORK = 3*MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU) INTEGER JPVT(MMAX) * .. External Subroutines .. EXTERNAL DLASET, MB04GD * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( JPVT(I), I = 1,M ) * RQ with row pivoting. CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,M ) WRITE ( NOUT, FMT = 99990 ) IF ( M.GE.N ) THEN IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, $ A(M-N+2,1), LDA ) ELSE CALL DLASET( 'Full', M, N-M-1, ZERO, ZERO, A, LDA ) CALL DLASET( 'Lower', M, M, ZERO, ZERO, A(1,N-M), $ LDA ) END IF DO 20 I = 1, M WRITE ( NOUT, FMT = 99989 ) ( A(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB04GD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04GD = ',I2) 99994 FORMAT (' Row permutations are ',/(20(I3,2X))) 99990 FORMAT (/' The matrix A is ') 99989 FORMAT (20(1X,F8.4)) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TMB04MD.f000077500000000000000000000030741201767322700165510ustar00rootroot00000000000000* MB04MD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N DOUBLE PRECISION MAXRED * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), SCALE(NMAX) * .. External Subroutines .. EXTERNAL MB04MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, MAXRED IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Balance matrix A. CALL MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) ( SCALE(I), I = 1,N ) END IF END IF STOP * 99999 FORMAT (' MB04MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04MD = ',I2) 99997 FORMAT (' The balanced matrix is ') 99996 FORMAT (20(1X,F10.4)) 99994 FORMAT (/' SCALE is ',/20(1X,F10.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB04OD.f000077500000000000000000000057571201767322700165650ustar00rootroot00000000000000* MB04OD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 20, NMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDR PARAMETER ( LDA = PMAX, LDB = NMAX, LDC = PMAX, $ LDR = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX-1,MMAX ) ) * .. Local Scalars .. CHARACTER*1 UPLO INTEGER I, J, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK), R(LDR,NMAX), TAU(NMAX) * .. External Subroutines .. EXTERNAL MB04OD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,P ) * Compute and apply QR factorization. CALL MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, $ LDC, TAU, DWORK ) * WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N DO 20 J = 1, I-1 R(I,J) = ZERO 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) ( R(I,J), J = 1,N ) 40 CONTINUE IF ( M.GT.0 ) THEN WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE IF ( P.GT.0 ) THEN WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' MB04OD EXAMPLE PROGRAM RESULTS',/1X) 99997 FORMAT (' The updated matrix R is ') 99996 FORMAT (20(1X,F10.4)) 99995 FORMAT (' The updated matrix B is ') 99994 FORMAT (' The updated matrix C is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TMB04PB.f000077500000000000000000000155631201767322700165600ustar00rootroot00000000000000* MB04PB/MB04WP EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NBMAX PARAMETER ( NMAX = 7, NBMAX = 3 ) INTEGER LDA, LDQG, LDRES, LDU1, LDU2, LDWORK PARAMETER ( LDA = NMAX, LDQG = NMAX, LDRES = NMAX, $ LDU1 = NMAX, LDU2 = NMAX, $ LDWORK = 8*NBMAX*NMAX + 3*NBMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), CS(2*NMAX), DWORK(LDWORK), $ QG(LDQG, NMAX+1), RES(LDRES,3*NMAX+1), TAU(NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX) * .. External Functions .. DOUBLE PRECISION MA02ID, MA02JD EXTERNAL MA02ID, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DSYMM, DSYR, $ DSYR2K, DTRMM, MB04PB, MB04WP * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES ) CALL MB04PB( N, 1, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, $ INFO ) INFO = 0 IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'Lower', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'Lower', N, N, QG, LDQG, U2, LDU2 ) CALL MB04WP( N, 1, U1, LDU1, U2, LDU2, CS, TAU, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE 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, QG(2,1), $ LDQG ) WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99993) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99993) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE C CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DSYMM ( 'Right', 'Upper', N, N, ONE, QG(1,2), LDQG, $ U1, LDU1, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DLACPY( 'All', N, N, U2, LDU2, RES, LDRES ) DO 50 I = 1, N CALL DSCAL( N, QG(I,I), RES(1,I), 1 ) 50 CONTINUE CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+1), LDRES ) CALL DSCAL( N, ONE/TWO, QG(1,2), LDQG+1 ) CALL DLACPY( 'Full', N, N, U2, LDU2, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+1), LDRES ) DO 60 I = 1, N CALL DSYR( 'Lower', N, -QG(I,I), U1(1,I), 1, $ RES(1,2*N+1), LDRES ) 60 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+2), LDRES ) CALL DLACPY( 'Full', N, N, U1, LDU1, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, -ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+2), LDRES ) DO 70 I = 1, N CALL DSYR( 'Upper', N, QG(I,I), U2(1,I), 1, $ RES(1,2*N+2), LDRES ) 70 CONTINUE C WRITE ( NOUT, FMT = 99990 ) MA02ID( 'Hamiltonian', $ 'Frobenius', N, RES(1,N+1), LDRES, RES(1,2*N+1), $ LDRES, DWORK ) END IF END IF END IF * 99999 FORMAT (' TMB04PB EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04PB = ',I2) 99997 FORMAT (' INFO on exit from MB04WP = ',I2) 99996 FORMAT (' The symplectic orthogonal factor U is ') 99995 FORMAT (/' The reduced matrix A is ') 99994 FORMAT (/' The reduced matrix QG is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H - U*R*U'' ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB04PU.f000077500000000000000000000154731201767322700166030ustar00rootroot00000000000000* MB04PU/MB04WP EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG, LDRES, LDU1, LDU2, LDWORK PARAMETER ( LDA = NMAX, LDQG = NMAX, LDRES = NMAX, $ LDU1 = NMAX, LDU2 = NMAX, LDWORK = 2*NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), CS(2*NMAX), DWORK(LDWORK), $ QG(LDQG, NMAX+1), RES(LDRES,3*NMAX+1), TAU(NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX) * .. External Functions .. DOUBLE PRECISION MA02ID, MA02JD EXTERNAL MA02ID, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DSYMM, DSYR, $ DSYR2K, DTRMM, MB04PU, MB04WP * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES ) CALL MB04PU( N, 1, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, $ INFO ) INFO = 0 IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'Lower', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'Lower', N, N, QG, LDQG, U2, LDU2 ) CALL MB04WP( N, 1, U1, LDU1, U2, LDU2, CS, TAU, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE 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, QG(2,1), $ LDQG ) WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99993) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99993) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE C CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DSYMM ( 'Right', 'Upper', N, N, ONE, QG(1,2), LDQG, $ U1, LDU1, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DLACPY( 'All', N, N, U2, LDU2, RES, LDRES ) DO 50 I = 1, N CALL DSCAL( N, QG(I,I), RES(1,I), 1 ) 50 CONTINUE CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+1), LDRES ) CALL DSCAL( N, ONE/TWO, QG(1,2), LDQG+1 ) CALL DLACPY( 'Full', N, N, U2, LDU2, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+1), LDRES ) DO 60 I = 1, N CALL DSYR( 'Lower', N, -QG(I,I), U1(1,I), 1, $ RES(1,2*N+1), LDRES ) 60 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+2), LDRES ) CALL DLACPY( 'Full', N, N, U1, LDU1, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, -ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+2), LDRES ) DO 70 I = 1, N CALL DSYR( 'Upper', N, QG(I,I), U2(1,I), 1, $ RES(1,2*N+2), LDRES ) 70 CONTINUE C WRITE ( NOUT, FMT = 99990 ) MA02ID( 'Hamiltonian', $ 'Frobenius', N, RES(1,N+1), LDRES, RES(1,2*N+1), $ LDRES, DWORK ) END IF END IF END IF * 99999 FORMAT (' TMB04PU EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04PU = ',I2) 99997 FORMAT (' INFO on exit from MB04WP = ',I2) 99996 FORMAT (' The symplectic orthogonal factor U is ') 99995 FORMAT (/' The reduced matrix A is ') 99994 FORMAT (/' The reduced matrix QG is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H - U*R*U'' ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB04TB.f000077500000000000000000000255721201767322700165650ustar00rootroot00000000000000* MB04TB/MB04WR EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NBMAX, NMAX PARAMETER ( NBMAX = 64, NMAX = 421 ) INTEGER LDA, LDB, LDG, LDQ, LDRES, LDU1, LDU2, LDV1, $ LDV2, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDG = NMAX, LDQ = NMAX, $ LDRES = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDV1 = NMAX, LDV2 = NMAX, $ LDWORK = NBMAX*( 16*NMAX + 1 ) ) * .. Local Scalars .. CHARACTER*1 TRANA, TRANB, TRANV1 INTEGER I, INFO, J, N DOUBLE PRECISION TEMP * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, NMAX), CSL(2*NMAX), $ CSR(2*NMAX), DWORK(LDWORK), G(LDG, NMAX), $ Q(LDQ, NMAX), RES(LDRES,5*NMAX), TAUL(NMAX), $ TAUR(NMAX), U1(LDU1, NMAX), U2(LDU2, NMAX), $ V1(LDV1, NMAX), V2(LDV2, NMAX) * .. External Functions .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLAPY2, MA02JD EXTERNAL DLANGE, DLAPY2, LSAME, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, MB04TB, MB04WR * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TRANA, TRANB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES, LDRES ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, B, LDB, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, G, LDG, RES(1,2*N+1), LDRES ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, Q, LDQ, RES(1,3*N+1), LDRES ) CALL MB04TB( TRANA, TRANB, N, 1, A, LDA, B, LDB, G, LDG, Q, $ LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'All', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'All', N, N, Q, LDQ, U2, LDU2 ) CALL MB04WR( 'U', TRANA, N, 1, U1, LDU1, U2, LDU2, CSL, $ TAUL, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE CALL DLACPY( 'All', N, N, Q, LDQ, V2, LDV2 ) CALL DLACPY( 'All', N, N, B, LDB, V1, LDV1 ) CALL MB04WR( 'V', TRANB, N, 1, V1, LDV1, V2, LDV2, $ CSR, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) IF ( LSAME( TRANA, 'N' ) ) THEN DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) ELSE DO 30 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(J,I), J = 1,N ), ( U2(I,J), J = 1,N ) 30 CONTINUE DO 40 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(J,I), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .TRUE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) END IF WRITE ( NOUT, FMT = 99995 ) CALL DLASET( 'All', N, N, ZERO, ZERO, Q, LDQ ) IF ( LSAME( TRANA, 'N' ) ) THEN CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, $ A(2,1), LDA ) DO 50 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(I,J), J = 1,N ), ( G(I,J), J = 1,N ) 50 CONTINUE ELSE CALL DLASET( 'Upper', N-1, N-1, ZERO, ZERO, $ A(1,2), LDA ) DO 60 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(J,I), J = 1,N ), ( G(I,J), J = 1,N ) 60 CONTINUE END IF IF ( LSAME( TRANB, 'N' ) ) THEN IF ( N.GT.1 ) THEN CALL DLASET( 'Upper', N-2, N-2, ZERO, ZERO, $ B(1,3), LDB ) END IF DO 70 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(I,J), J = 1,N ) 70 CONTINUE ELSE IF ( N.GT.1 ) THEN C CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, C $ B(3,1), LDB ) END IF DO 80 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(J,I), J = 1,N ) 80 CONTINUE END IF C IF ( LSAME( TRANB, 'N' ) ) THEN TRANV1 = 'T' ELSE TRANV1 = 'N' END IF CALL DGEMM( TRANA, TRANV1, N, N, N, ONE, RES, LDRES, $ V1, LDV1, ZERO, RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, RES(1,2*N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, TRANA, N, N, N, -ONE, U1, LDU1, $ A, LDA, ONE, RES(1,4*N+1), LDRES ) TEMP = DLANGE( 'Frobenius', N, N, RES(1,4*N+1), $ LDRES, DWORK ) CALL DGEMM( TRANA, 'Transpose', N, N, N, ONE, RES, $ LDRES, V2, LDV2, ZERO, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,2*N+1), LDRES, V1, LDV1, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, 'No Transpose', N, N, N, -ONE, $ U1, LDU1, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANB, N, N, N, -ONE, $ U2, LDU2, B, LDB, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,3*N+1), LDRES, V1, LDV1, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, 'Transpose', N, N, N, -ONE, $ RES(1,N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', TRANA, N, N, N, ONE, $ U2, LDU2, A, LDA, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES(1,3*N+1), LDRES, V2, LDV2, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, TRANV1, N, N, N, ONE, RES(1,N+1), $ LDRES, V1, LDV1, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ ONE, U2, LDU2, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( TRANA, TRANB, N, N, N, -ONE, U1, LDU1, $ B, LDB, ONE, RES(1,4*N+1), LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) WRITE ( NOUT, FMT = 99990 ) TEMP C WRITE ( NOUT, FMT = 99994 ) IF ( LSAME( TRANB, 'N' ) ) THEN DO 90 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(J,I), J = 1,N ), ( V2(J,I), J = 1,N ) 90 CONTINUE DO 100 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(J,I), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .TRUE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) ELSE DO 110 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(I,J), J = 1,N ), ( V2(J,I), J = 1,N ) 110 CONTINUE DO 120 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(I,J), J = 1,N ) 120 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .FALSE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) END IF END IF END IF END IF END IF * STOP * 99999 FORMAT (' MB04TB EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04TB = ',I2) 99997 FORMAT (' INFO on exit from MB04WR = ',I2) 99996 FORMAT (' The orthogonal symplectic factor U is ') 99995 FORMAT (/' The factor R is ') 99994 FORMAT (/' The orthogonal symplectic factor V is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2) 99989 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB04TS.f000077500000000000000000000254301201767322700165770ustar00rootroot00000000000000* MB04TS/MB04WR EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 200 ) INTEGER LDA, LDB, LDG, LDQ, LDRES, LDU1, LDU2, LDV1, $ LDV2, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDG = NMAX, LDQ = NMAX, $ LDRES = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDV1 = NMAX, LDV2 = NMAX, LDWORK = NMAX ) * .. Local Scalars .. CHARACTER*1 TRANA, TRANB, TRANV1 INTEGER I, INFO, J, N DOUBLE PRECISION TEMP * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, NMAX), CSL(2*NMAX), $ CSR(2*NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), RES(LDRES,5*NMAX), TAUL(NMAX), $ TAUR(NMAX), U1(LDU1,NMAX), U2(LDU2, NMAX), $ V1(LDV1, NMAX), V2(LDV2,NMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLAPY2, MA02JD EXTERNAL DLANGE, DLAPY2, LSAME, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, MB04TS, MB04WR * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TRANA, TRANB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES, LDRES ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, B, LDB, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, G, LDG, RES(1,2*N+1), LDRES ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, Q, LDQ, RES(1,3*N+1), LDRES ) CALL MB04TS( TRANA, TRANB, N, 1, A, LDA, B, LDB, G, LDG, Q, $ LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'All', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'All', N, N, Q, LDQ, U2, LDU2 ) CALL MB04WR( 'U', TRANA, N, 1, U1, LDU1, U2, LDU2, CSL, $ TAUL, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE CALL DLACPY( 'All', N, N, Q, LDQ, V2, LDV2 ) CALL DLACPY( 'All', N, N, B, LDB, V1, LDV1 ) CALL MB04WR( 'V', TRANB, N, 1, V1, LDV1, V2, LDV2, $ CSR, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) IF ( LSAME( TRANA, 'N' ) ) THEN DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) ELSE DO 30 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(J,I), J = 1,N ), ( U2(I,J), J = 1,N ) 30 CONTINUE DO 40 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(J,I), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .TRUE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) END IF WRITE ( NOUT, FMT = 99995 ) CALL DLASET( 'All', N, N, ZERO, ZERO, Q, LDQ ) IF ( LSAME( TRANA, 'N' ) ) THEN CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, $ A(2,1), LDA ) DO 50 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(I,J), J = 1,N ), ( G(I,J), J = 1,N ) 50 CONTINUE ELSE CALL DLASET( 'Upper', N-1, N-1, ZERO, ZERO, $ A(1,2), LDA ) DO 60 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(J,I), J = 1,N ), ( G(I,J), J = 1,N ) 60 CONTINUE END IF IF ( LSAME( TRANB, 'N' ) ) THEN IF ( N.GT.1 ) THEN CALL DLASET( 'Upper', N-2, N-2, ZERO, ZERO, $ B(1,3), LDB ) END IF DO 70 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(I,J), J = 1,N ) 70 CONTINUE ELSE IF ( N.GT.1 ) THEN CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, $ B(3,1), LDB ) END IF DO 80 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(J,I), J = 1,N ) 80 CONTINUE END IF C IF ( LSAME( TRANB, 'N' ) ) THEN TRANV1 = 'T' ELSE TRANV1 = 'N' END IF CALL DGEMM( TRANA, TRANV1, N, N, N, ONE, RES, LDRES, $ V1, LDV1, ZERO, RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, RES(1,2*N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, TRANA, N, N, N, -ONE, U1, LDU1, $ A, LDA, ONE, RES(1,4*N+1), LDRES ) TEMP = DLANGE( 'Frobenius', N, N, RES(1,4*N+1), $ LDRES, DWORK ) CALL DGEMM( TRANA, 'Transpose', N, N, N, ONE, RES, $ LDRES, V2, LDV2, ZERO, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,2*N+1), LDRES, V1, LDV1, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, 'No Transpose', N, N, N, -ONE, $ U1, LDU1, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANB, N, N, N, -ONE, $ U2, LDU2, B, LDB, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,3*N+1), LDRES, V1, LDV1, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, 'Transpose', N, N, N, -ONE, $ RES(1,N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', TRANA, N, N, N, ONE, $ U2, LDU2, A, LDA, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES(1,3*N+1), LDRES, V2, LDV2, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, TRANV1, N, N, N, ONE, RES(1,N+1), $ LDRES, V1, LDV1, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ ONE, U2, LDU2, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( TRANA, TRANB, N, N, N, -ONE, U1, LDU1, $ B, LDB, ONE, RES(1,4*N+1), LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) WRITE ( NOUT, FMT = 99990 ) TEMP C WRITE ( NOUT, FMT = 99994 ) IF ( LSAME( TRANB, 'N' ) ) THEN DO 90 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(J,I), J = 1,N ), ( V2(J,I), J = 1,N ) 90 CONTINUE DO 100 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(J,I), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .TRUE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) ELSE DO 110 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(I,J), J = 1,N ), ( V2(J,I), J = 1,N ) 110 CONTINUE DO 120 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(I,J), J = 1,N ) 120 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .FALSE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) END IF END IF END IF END IF END IF * STOP * 99999 FORMAT (' MB04TS EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04TS = ',I2) 99997 FORMAT (' INFO on exit from MB04WR = ',I2) 99996 FORMAT (' The orthogonal symplectic factor U is ') 99995 FORMAT (/' The factor R is ') 99994 FORMAT (/' The orthogonal symplectic factor V is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2) 99989 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2) END slicot-5.0+20101122/examples/TMB04UD.f000077500000000000000000000051421201767322700165570ustar00rootroot00000000000000* MB04UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDE, LDQ, LDZ PARAMETER ( LDA = MMAX, LDE = MMAX, LDQ = MMAX, $ LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX,MMAX ) ) * PARAMETER ( LDWORK = NMAX+MMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, RANKE CHARACTER*1 JOBQ, JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX), $ Q(LDQ,MMAX), Z(LDZ,NMAX) INTEGER ISTAIR(MMAX) * .. External Subroutines .. EXTERNAL MB04UD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, TOL IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M ) JOBQ = 'N' JOBZ = 'N' * Reduce E to column echelon form and compute Q'*A*Z. CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ, $ RANKE, ISTAIR, TOL, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99991 ) DO 10 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99997 ) DO 100 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( E(I,J), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99995 ) RANKE WRITE ( NOUT, FMT = 99994 ) ( ISTAIR(I), I = 1,M ) END IF END IF STOP * 99999 FORMAT (' MB04UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04UD = ',I2) 99997 FORMAT (' The transformed matrix E is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The computed rank of E = ',I2) 99994 FORMAT (/' ISTAIR is ',/20(1X,I5)) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (' The transformed matrix A is ') END slicot-5.0+20101122/examples/TMB04VD.f000077500000000000000000000125121201767322700165570ustar00rootroot00000000000000* MB04VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDE, LDQ, LDZ PARAMETER ( LDA = MMAX, LDE = MMAX, LDQ = MMAX, $ LDZ = NMAX ) INTEGER LINUK PARAMETER ( LINUK = MAX( NMAX,MMAX+1 ) ) * PARAMETER ( LINUK = NMAX+MMAX+1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX,MMAX ) ) * PARAMETER ( LDWORK = NMAX+MMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NBLCKI, NBLCKS, RANKE CHARACTER*1 JOBQ, JOBZ, MODE * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX), $ Q(LDQ,MMAX), Z(LDZ,NMAX) INTEGER IMUK(LINUK), IMUK0(NMAX), INUK(LINUK), $ ISTAIR(MMAX), IWORK(LIWORK), MNEI(3) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04UD, MB04VD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, TOL, MODE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99984 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99983 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M ) JOBQ = 'I' JOBZ = 'I' * Reduce E to column echelon form and compute Q'*A*Z. CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ, $ RANKE, ISTAIR, TOL, DWORK, INFO ) JOBQ = 'U' JOBZ = 'U' * IF ( INFO.EQ.0 ) THEN * Compute a unitary transformed pencil Q'*(s*E-A)*Z. CALL 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 ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) WRITE ( NOUT, FMT = 99995 ) DO 140 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( Q(I,J), J = 1,M ) 140 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 160 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( E(I,J), J = 1,N ) 160 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 180 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N ) 180 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 200 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N ) 200 CONTINUE WRITE ( NOUT, FMT = 99990 ) NBLCKS IF ( .NOT. LSAME( MODE, 'S' ) ) THEN WRITE ( NOUT, FMT = 99989 ) ( IMUK(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99988 ) ( INUK(I), I = 1,NBLCKS ) ELSE WRITE ( NOUT, FMT = 99987 ) ( IMUK(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99986 ) ( INUK(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99982 ) ( IMUK0(I), I = 1,NBLCKI ) WRITE ( NOUT, FMT = 99985 ) ( MNEI(I), I = 1,3 ) END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF ELSE WRITE ( NOUT, FMT = 99997 ) INFO END IF END IF STOP * 99999 FORMAT (' MB04VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04VD = ',I2) 99997 FORMAT (' INFO on exit from MB04UD = ',I2) 99996 FORMAT (' The unitary transformed pencil is Q''*(s*E-A)*Z, where', $ /) 99995 FORMAT (' Matrix Q',/) 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' Matrix E',/) 99992 FORMAT (/' Matrix A',/) 99991 FORMAT (/' Matrix Z',/) 99990 FORMAT (/' The number of submatrices having full row rank detect', $ 'ed in matrix A = ',I3) 99989 FORMAT (/' The column dimensions of the submatrices having full ', $ 'column rank in the pencil',/' sE(eps,inf) - A(eps,inf) a', $ 're',/20(1X,I5)) 99988 FORMAT (/' The row dimensions of the submatrices having full row', $ ' rank in the pencil',/' sE(eps,inf) - A(eps,inf) are', $ /20(1X,I5)) 99987 FORMAT (/' The column dimensions of the submatrices having full ', $ 'column rank in the pencil',/' sE(eps) - A(eps) are', $ /20(1X,I5)) 99986 FORMAT (/' The row dimensions of the submatrices having full row', $ ' rank in the pencil',/' sE(eps) - A(eps) are',/20(1X,I5)) 99985 FORMAT (/' MNEI is ',/20(1X,I5)) 99984 FORMAT (/' M is out of range.',/' M = ',I5) 99983 FORMAT (/' N is out of range.',/' N = ',I5) 99982 FORMAT (/' The orders of the diagonal submatrices in the pencil ', $ 'sE(inf) - A(inf) are',/20(1X,I5)) END slicot-5.0+20101122/examples/TMB04XD.f000077500000000000000000000127141201767322700165650ustar00rootroot00000000000000* MB04XD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDU, LDV PARAMETER ( LDA = MMAX, LDU = MMAX, LDV = NMAX ) INTEGER MAXMN, MNMIN PARAMETER ( MAXMN = MAX( MMAX, NMAX ), $ MNMIN = MIN( MMAX, NMAX ) ) INTEGER LENGQ PARAMETER ( LENGQ = 2*MNMIN-1 ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 2*NMAX, NMAX*( NMAX+1 )/2 ) $ + MAX( 2*MNMIN + MAXMN, 8*MNMIN - 5 ) ) * .. Local Scalars .. DOUBLE PRECISION RELTOL, THETA, THETA1, TOL INTEGER I, INFO, IWARN, J, K, LOOP, M, MINMN, N, NCOLU, $ NCOLV, RANK, RANK1 CHARACTER*1 JOBU, JOBV LOGICAL LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), Q(LENGQ), $ U(LDU,MMAX), V(LDV,NMAX) LOGICAL INUL(MAXMN) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04XD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, RANK, THETA, TOL, RELTOL, JOBU, JOBV IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99983 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99982 ) N ELSE IF ( RANK.GT.MNMIN ) THEN WRITE ( NOUT, FMT = 99981 ) RANK ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) THETA ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) RANK1 = RANK THETA1 = THETA * Compute a basis for the left and right singular subspace of A. CALL MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, V, $ LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) RANK ELSE IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK END IF IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA LJOBUA = LSAME( JOBU, 'A' ) LJOBUS = LSAME( JOBU, 'S' ) LJOBVA = LSAME( JOBV, 'A' ) LJOBVS = LSAME( JOBV, 'S' ) WANTU = LJOBUA.OR.LJOBUS WANTV = LJOBVA.OR.LJOBVS WRITE ( NOUT, FMT = 99994 ) MINMN = MIN( M, N ) LOOP = MINMN - 1 DO 20 I = 1, LOOP K = I + MINMN WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K) 20 CONTINUE WRITE ( NOUT, FMT = 99992 ) MINMN, MINMN, Q(MINMN) IF ( WANTU ) THEN NCOLU = M IF ( LJOBUS ) NCOLU = MINMN WRITE ( NOUT, FMT = 99986 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99985 ) ( U(I,J), J = 1,NCOLU ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) NCOLU WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, NCOLU WRITE ( NOUT, FMT = 99989 ) I, INUL(I) 60 CONTINUE END IF IF ( WANTV ) THEN NCOLV = N IF ( LJOBVS ) NCOLV = MINMN WRITE ( NOUT, FMT = 99984 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99985 ) ( V(I,J), J = 1,NCOLV ) 80 CONTINUE WRITE ( NOUT, FMT = 99988 ) NCOLV WRITE ( NOUT, FMT = 99987 ) DO 100 J = 1, NCOLV WRITE ( NOUT, FMT = 99989 ) J, INUL(J) 100 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB04XD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04XD = ',I2) 99997 FORMAT (' IWARN on exit from MB04XD = ',I2,/) 99996 FORMAT (' The computed rank of matrix A = ',I3,/) 99995 FORMAT (' The computed value of THETA = ',F7.4,/) 99994 FORMAT (' The elements of the partially diagonalized bidiagonal ', $ 'matrix are',/) 99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/) 99991 FORMAT (/' Left singular subspace corresponds to the i-th column', $ '(s) of U for which ',/' INUL(i) = .TRUE., i = 1,...,',I1, $ /) 99990 FORMAT (' i INUL(i)',/) 99989 FORMAT (I3,L8) 99988 FORMAT (/' Right singular subspace corresponds to the j-th colum', $ 'n(s) of V for which ',/' INUL(j) = .TRUE., j = 1,...,',I1, $ /) 99987 FORMAT (' j INUL(j)',/) 99986 FORMAT (' Matrix U',/) 99985 FORMAT (20(1X,F8.4)) 99984 FORMAT (/' Matrix V',/) 99983 FORMAT (/' M is out of range.',/' M = ',I5) 99982 FORMAT (/' N is out of range.',/' N = ',I5) 99981 FORMAT (/' RANK is out of range.',/' RANK = ',I5) 99980 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4) END slicot-5.0+20101122/examples/TMB04YD.f000077500000000000000000000112001201767322700165530ustar00rootroot00000000000000* MB04YD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER MNMIN PARAMETER ( MNMIN = MIN( MMAX, NMAX ) ) INTEGER LDU, LDV PARAMETER ( LDU = MMAX, LDV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 6*MNMIN - 5 ) * .. Local Scalars .. DOUBLE PRECISION RELTOL, THETA, TOL INTEGER I, INFO, IWARN, J, M, MINMN, N, RANK, RANK1 CHARACTER*1 JOBU, JOBV LOGICAL LJOBUU, LJOBVU * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), E(MNMIN-1), Q(MNMIN), $ U(LDU,MNMIN), V(LDV,MNMIN) LOGICAL INUL(MNMIN) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04YD * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, THETA, RANK, TOL, RELTOL, JOBU, JOBV MINMN = MIN( M, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99988 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99987 ) N ELSE IF ( RANK.GT.MINMN ) THEN WRITE ( NOUT, FMT = 99986 ) RANK ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99985 ) THETA ELSE READ ( NIN, FMT = * ) ( Q(I), I = 1,MINMN ) READ ( NIN, FMT = * ) ( E(I), I = 1,MINMN-1 ) RANK1 = RANK LJOBUU = LSAME( JOBU, 'U' ) LJOBVU = LSAME( JOBV, 'U' ) IF ( LJOBUU ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,MINMN ), I = 1,M ) IF ( LJOBVU ) READ ( NIN, FMT = * ) $ ( ( V(I,J), J = 1,MINMN ), I = 1,N ) * Initialise the array INUL. DO 20 I = 1, MINMN INUL(I) = .FALSE. 20 CONTINUE IF ( LJOBUU.OR.LJOBVU ) READ ( NIN, FMT = * ) $ ( INUL(I), I = 1,MINMN ) * Compute the number of singular values of J > THETA. CALL MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V, $ LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99993 ) IWARN WRITE ( NOUT, FMT = 99984 ) RANK END IF WRITE ( NOUT, FMT = 99997 ) DO 160 I = 1, MINMN - 1 WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I) 160 CONTINUE WRITE ( NOUT, FMT = 99995 ) MINMN, MINMN, Q(MINMN) IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99994 ) RANK, THETA IF ( .NOT.LSAME( JOBV, 'N' ) ) THEN WRITE ( NOUT, FMT = 99992 ) DO 180 I = 1, N WRITE ( NOUT, FMT = 99991 ) ( V(I,J), J = 1,MINMN ) 180 CONTINUE END IF IF ( ( .NOT.LSAME( JOBU, 'N' ) ) .AND. $ ( .NOT.LSAME( JOBV, 'N' ) ) ) $ WRITE ( NOUT, FMT = 99990 ) IF ( .NOT.LSAME( JOBU, 'N' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 200 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( U(I,J), J = 1,MINMN ) 200 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB04YD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04YD = ',I2) 99997 FORMAT (' The transformed bidiagonal matrix J is',/) 99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99995 FORMAT (' (',I1,',',I1,') = ',F7.4) 99994 FORMAT (/' J has ',I2,' singular values >',F7.4,/) 99993 FORMAT (' IWARN on exit from MB04YD = ',I2,/) 99992 FORMAT (' The product of the right-hand Givens rotation matrices', $ ' equals ') 99991 FORMAT (20(1X,F8.4)) 99990 FORMAT (' ') 99989 FORMAT (' The product of the left-hand Givens rotation matrices ', $ 'equals ') 99988 FORMAT (/' M is out of range.',/' M = ',I5) 99987 FORMAT (/' N is out of range.',/' N = ',I5) 99986 FORMAT (/' RANK is out of range.',/' RANK = ',I5) 99985 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4) 99984 FORMAT (/' The computed rank of matrix J = ',I3,/) END slicot-5.0+20101122/examples/TMB04ZD.f000077500000000000000000000077231201767322700165730ustar00rootroot00000000000000* MB04ZD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDQG, LDU PARAMETER ( LDA = NMAX, LDQG = NMAX, LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX+NMAX )*( NMAX+NMAX+1 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. INTEGER I, INFO, IJ, J, JI, N, POS, WPOS CHARACTER*1 COMPU * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), QG(LDQG,NMAX+1), $ U(LDU,NMAX) * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DSYMV, MB04ZD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, COMPU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99998 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), I = J,N ), J = 1,N ) * Square-reduce by symplectic orthogonal similarity. CALL MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE * Show the square-reduced Hamiltonian. WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N ), $ ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N ) 10 CONTINUE DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( QG(I,J), J = 1,I-1 ), $ ( QG(J,I), J = I,N ), ( -A(J,I), J = 1,N ) 20 CONTINUE * Show the square of H. WRITE ( NOUT, FMT = 99995 ) WPOS = ( NMAX+NMAX )*( NMAX+NMAX ) * T * Compute N11 = A*A + G*Q and set N22 = N11 . CALL DGEMM( 'N', 'N', N, N, N, ONE, A, LDA, A, LDA, ZERO, $ DWORK, N+N ) DO 30 I = 1, N CALL DCOPY( N-I+1, QG(I,I), 1, DWORK(WPOS+I), 1 ) CALL DCOPY( I-1, QG(I,1), LDQG, DWORK(WPOS+1), 1 ) CALL DSYMV( 'U', N, ONE, QG(1,2), LDQG, DWORK(WPOS+1), 1, $ ONE, DWORK((I-1)*(N+N)+1), 1 ) POS = N*( N+N ) + N + I CALL DCOPY( N, DWORK((I-1)*(N+N)+1), 1, DWORK(POS), N+N ) 30 CONTINUE DO 40 I = 1, N CALL DSYMV( 'U', N, -ONE, QG(1,2), LDQG, A(I,1), LDA, $ ZERO, DWORK((N+I-1)*(N+N)+1), 1 ) CALL DSYMV( 'L', N, ONE, QG, LDQG, A(1,I), 1, ZERO, $ DWORK((I-1)*(N+N)+N+1), 1 ) 40 CONTINUE DO 60 J = 1, N DO 50 I = J, N IJ = ( N+J-1 )*( N+N ) + I JI = ( N+I-1 )*( N+N ) + J DWORK(IJ) = DWORK(IJ) - DWORK(JI) DWORK(JI) = -DWORK(IJ) IJ = N + I + ( J-1 )*( N+N ) JI = N + J + ( I-1 )*( N+N ) DWORK(IJ) = DWORK(IJ) - DWORK(JI) DWORK(JI) = -DWORK(IJ) 50 CONTINUE 60 CONTINUE DO 70 I = 1, N+N WRITE ( NOUT, FMT = 99994 ) $ ( DWORK(I+(J-1)*(N+N) ), J = 1,N+N ) 70 CONTINUE ENDIF END IF STOP * 99999 FORMAT (' MB04ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' N is out of range.',/' N = ',I5) 99997 FORMAT (' INFO on exit from MB04ZD = ',I2) 99996 FORMAT (/' The square-reduced Hamiltonian is ') 99995 FORMAT (/' The square of the square-reduced Hamiltonian is ') 99994 FORMAT (1X,8(F10.4)) END slicot-5.0+20101122/examples/TMB05MD.f000077500000000000000000000046651201767322700165610ustar00rootroot00000000000000* MB05MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDV, LDY PARAMETER ( LDA = NMAX, LDV = NMAX, LDY = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX ) * .. Local Scalars .. DOUBLE PRECISION DELTA INTEGER I, INFO, J, N CHARACTER*1 BALANC * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), V(LDV,NMAX), $ VALI(NMAX), VALR(NMAX), Y(LDY,NMAX) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL MB05MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) BALANC = 'N' READ ( NIN, FMT = * ) N, DELTA IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Find the exponential of the real non-defective matrix A*DELTA. CALL MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR, $ VALI, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) ( VALR(I), VALI(I), I = 1,N ) WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( V(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( Y(I,J), J = 1,N ) 60 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB05MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB05MD = ',I2) 99997 FORMAT (' The solution matrix exp(A*DELTA) is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The eigenvalues of A are ',/20(2F5.1,'*j ')) 99994 FORMAT (/' The eigenvector matrix for A is ') 99993 FORMAT (/' The inverse eigenvector matrix for A (premultiplied by' $ ,' exp(Lambda*DELTA)) is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB05ND.f000077500000000000000000000037301201767322700165520ustar00rootroot00000000000000* MB05ND EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDEX, LDEXIN, LDWORK PARAMETER ( LDA = NMAX, LDEX = NMAX, LDEXIN = NMAX, $ LDWORK = NMAX*( NMAX+1 ) ) * .. Local Scalars .. DOUBLE PRECISION DELTA, TOL INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), EX(LDEX,NMAX), $ EXINT(LDEXIN,NMAX) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL MB05ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DELTA, TOL IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Find the matrix exponential of A*DELTA and its integral. CALL MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, TOL, $ IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( EX(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( EXINT(I,J), J = 1,N ) 40 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB05ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB05ND = ',I2) 99997 FORMAT (' The solution matrix exp(A*DELTA) is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' and its integral is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TMB05OD.f000077500000000000000000000043301201767322700165500ustar00rootroot00000000000000* MB05OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER NDIAG PARAMETER ( NDIAG = 9 ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX+NDIAG+1 )+NDIAG ) * .. Local Scalars .. DOUBLE PRECISION DELTA INTEGER I, IDIG, INFO, IWARN, J, MDIG, N CHARACTER*1 BALANC * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL MB05OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DELTA, BALANC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Find the exponential of the real defective matrix A*DELTA. CALL MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG, $ IWORK, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99993 ) IWARN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) MDIG, IDIG END IF END IF STOP * 99999 FORMAT (' MB05OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB05OD = ',I2) 99997 FORMAT (' The solution matrix E = exp(A*DELTA) is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' Minimal number of accurate digits in the norm of E =', $ I4,/' Number of accurate digits in the norm of E',/' ', $ ' at 95 per cent confidence interval =',I4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (' IWARN on exit from MB05OD = ',I2) END slicot-5.0+20101122/examples/TMC01MD.f000077500000000000000000000030321201767322700165410ustar00rootroot00000000000000* MC01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA INTEGER DP, I, INFO, K * .. Local Arrays .. DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1) * .. External Subroutines .. EXTERNAL MC01MD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP, ALPHA, K IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Compute the leading K coefficients of the shifted polynomial. CALL MC01MD( DP, ALPHA, K, P, Q, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) ALPHA DO 20 I = 1, K WRITE ( NOUT, FMT = 99996 ) I - 1, Q(I) 20 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MC01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01MD = ',I2) 99997 FORMAT (' ALPHA = ',F8.4,//' The coefficients of the shifted pol', $ 'ynomial are ',//' power of (x-ALPHA) coefficient ') 99996 FORMAT (5X,I5,15X,F9.4) 99995 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples/TMC01ND.f000077500000000000000000000027001201767322700165430ustar00rootroot00000000000000* MC01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION VI, VR, XI, XR INTEGER DP, I, INFO * .. Local Arrays .. DOUBLE PRECISION P(DPMAX+1) * .. External Subroutines .. EXTERNAL MC01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP, XR, XI IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Evaluate the polynomial at the given (complex) point. CALL MC01ND( DP, XR, XI, P, VR, VI, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) XR, XI, VR WRITE ( NOUT, FMT = 99996 ) XR, XI, VI END IF END IF * STOP * 99999 FORMAT (' MC01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01ND = ',I2) 99997 FORMAT (' Real part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4) 99996 FORMAT (/' Imaginary part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4) 99995 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples/TMC01OD.f000077500000000000000000000030241201767322700165440ustar00rootroot00000000000000* MC01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX PARAMETER ( KMAX = 10 ) * .. Local Scalars .. INTEGER I, INFO, K * .. Local Arrays .. DOUBLE PRECISION DWORK(2*KMAX+2), IMP(KMAX+1), IMZ(KMAX), $ REP(KMAX+1), REZ(KMAX) * .. External Subroutines .. EXTERNAL MC01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K IF ( K.LT.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99995 ) K ELSE READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K ) * Compute the coefficients of P(x) from the given zeros. CALL MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99996 ) $ ( I, REP(I+1), IMP(I+1), I = 0,K ) END IF END IF STOP * 99999 FORMAT (' MC01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01OD = ',I2) 99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe', $ 'r of x real part imag part ') 99996 FORMAT (2X,I5,8X,F9.4,5X,F9.4) 99995 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples/TMC01PD.f000077500000000000000000000026621201767322700165540ustar00rootroot00000000000000* MC01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX PARAMETER ( KMAX = 10 ) * .. Local Scalars .. INTEGER I, INFO, K * .. Local Arrays .. DOUBLE PRECISION DWORK(KMAX+1), IMZ(KMAX), P(KMAX+1), REZ(KMAX) * .. External Subroutines .. EXTERNAL MC01PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K IF ( K.LT.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99995 ) K ELSE READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K ) * Compute the coefficients of P(x) from the given zeros. CALL MC01PD( K, REZ, IMZ, P, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99996 ) ( I, P(I+1), I = 0,K ) END IF END IF STOP * 99999 FORMAT (' MC01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01PD = ',I2) 99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe', $ 'r of x coefficient ') 99996 FORMAT (2X,I5,9X,F9.4) 99995 FORMAT (' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples/TMC01QD.f000077500000000000000000000052721201767322700165550ustar00rootroot00000000000000* MC01QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DAMAX, DBMAX PARAMETER ( DAMAX = 10, DBMAX = 10 ) * .. Local Scalars .. INTEGER DA, DB, DBB, DQ, DR, I, IMAX, INFO, IWARN * .. Local Arrays .. DOUBLE PRECISION A(DAMAX+1), B(DBMAX+1), RQ(DAMAX+1) * .. External Subroutines .. EXTERNAL MC01QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DA IF ( DA.LE.-2 .OR. DA.GT.DAMAX ) THEN WRITE ( NOUT, FMT = 99991 ) DA ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 ) READ ( NIN, FMT = * ) DB DBB = DB IF ( DB.LE.-1 .OR. DB.GT.DBMAX ) THEN WRITE ( NOUT, FMT = 99990 ) DB ELSE READ ( NIN, FMT = * ) ( B(I), I = 1,DB+1 ) * Compute Q(x) and R(x) from the given A(x) and B(x). CALL MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) DBB, DB END IF WRITE ( NOUT, FMT = 99995 ) DQ = DA - DB DR = DB - 1 IMAX = DQ IF ( DR.GT.IMAX ) IMAX = DR DO 20 I = 0, IMAX IF ( I.LE.DQ .AND. I.LE.DR ) THEN WRITE ( NOUT, FMT = 99994 ) I, RQ(DB+I+1), RQ(I+1) ELSE IF ( I.LE.DQ ) THEN WRITE ( NOUT, FMT = 99993 ) I, RQ(DB+I+1) ELSE WRITE ( NOUT, FMT = 99992 ) I, RQ(I+1) END IF 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MC01QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01QD = ',I2) 99997 FORMAT (' IWARN on exit from MC01QD = ',I2,/) 99996 FORMAT (' The degree of the denominator polynomial B(x) has been', $ ' reduced from ',I2,' to ',I2,/) 99995 FORMAT (' The coefficients of the polynomials Q(x) and R(x) are ', $ //' Q(x) R(x) ',/' power of', $ ' x coefficient coefficient ') 99994 FORMAT (2X,I5,9X,F9.4,7X,F9.4) 99993 FORMAT (2X,I5,9X,F9.4) 99992 FORMAT (2X,I5,25X,F9.4) 99991 FORMAT (/' DA is out of range.',/' DA = ',I5) 99990 FORMAT (/' DB is out of range.',/' DB = ',I5) END slicot-5.0+20101122/examples/TMC01RD.f000077500000000000000000000050371201767322700165550ustar00rootroot00000000000000* MC01RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DP1MAX, DP2MAX, DP3MAX PARAMETER ( DP1MAX = 10, DP2MAX = 10, DP3MAX = 10 ) INTEGER LENP3 PARAMETER ( LENP3 = MAX(DP1MAX+DP2MAX,DP3MAX)+1 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA INTEGER DP1, DP2, DP3, I, INFO * .. Local Arrays .. DOUBLE PRECISION P1(DP1MAX+1), P2(DP2MAX+1), P3(LENP3) * $ P3(DP1MAX+DP2MAX+DP3MAX+1) * .. External Subroutines .. EXTERNAL MC01RD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP1 IF ( DP1.LE.-2 .OR. DP1.GT.DP1MAX ) THEN WRITE ( NOUT, FMT = 99994 ) DP1 ELSE READ ( NIN, FMT = * ) ( P1(I), I = 1,DP1+1 ) READ ( NIN, FMT = * ) DP2 IF ( DP2.LE.-2 .OR. DP2.GT.DP2MAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP2 ELSE READ ( NIN, FMT = * ) ( P2(I), I = 1,DP2+1 ) READ ( NIN, FMT = * ) DP3 IF ( DP3.LE.-2 .OR. DP3.GT.DP3MAX ) THEN WRITE ( NOUT, FMT = 99992 ) DP3 ELSE READ ( NIN, FMT = * ) ( P3(I), I = 1,DP3+1 ) END IF READ ( NIN, FMT = * ) ALPHA * Compute the coefficients of the polynomial P(x). CALL MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DP3 IF ( DP3.GE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 0, DP3 WRITE ( NOUT, FMT = 99995 ) I, P3(I+1) 20 CONTINUE END IF END IF END IF END IF * STOP * 99999 FORMAT (' MC01RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01RD = ',I2) 99997 FORMAT (' Degree of the resulting polynomial P(x) = ',I2) 99996 FORMAT (/' The coefficients of P(x) are ',//' power of x coe', $ 'fficient ') 99995 FORMAT (2X,I5,9X,F9.4) 99994 FORMAT (/' DP1 is out of range.',/' DP1 = ',I5) 99993 FORMAT (/' DP2 is out of range.',/' DP2 = ',I5) 99992 FORMAT (/' DP3 is out of range.',/' DP3 = ',I5) END slicot-5.0+20101122/examples/TMC01SD.f000077500000000000000000000035411201767322700165540ustar00rootroot00000000000000* MC01SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 10 ) * .. Local Scalars .. INTEGER BETA, DP, I, INFO, S, T * .. Local Arrays .. DOUBLE PRECISION MANT(DPMAX+1), P(DPMAX+1) INTEGER E(DPMAX+1), IWORK(DPMAX+1) C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. External Subroutines .. EXTERNAL MC01SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Compute the coefficients of the scaled polynomial Q(x). CALL MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE BETA = DLAMCH( 'Base' ) WRITE ( NOUT, FMT = 99995 ) BETA, S, T WRITE ( NOUT,FMT = 99997 ) DO 20 I = 0, DP WRITE ( NOUT, FMT = 99996 ) I, P(I+1) 20 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MC01SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01SD = ',I2) 99997 FORMAT (/' The coefficients of the scaled polynomial Q(x) = s*P(', $ 'tx) are ',//' power of x coefficient ') 99996 FORMAT (2X,I5,9X,F9.4) 99995 FORMAT (' The base of the machine (BETA) = ',I2,//' The scaling ', $ 'factors are s = BETA**(',I3,') and t = BETA**(',I3,')') 99994 FORMAT (/' DP is out of range.',/' DP =',I5) END slicot-5.0+20101122/examples/TMC01TD.f000077500000000000000000000044541201767322700165610ustar00rootroot00000000000000* MC01TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 10 ) * .. Local Scalars .. INTEGER DP, DPP, I, INFO, IWARN, NZ LOGICAL STABLE CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION DWORK(2*DPMAX+2), P(DPMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MC01TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = * ) READ ( NIN, FMT = * ) DP, DICO IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE DPP = DP READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Determine whether or not the given polynomial P(x) is stable. CALL MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) DPP, DP END IF IF ( STABLE ) THEN WRITE ( NOUT, FMT = 99995 ) ELSE WRITE ( NOUT, FMT = 99994 ) IF ( LSAME( DICO, 'D' ) ) THEN WRITE ( NOUT, FMT = 99992 ) NZ ELSE WRITE ( NOUT, FMT = 99991 ) NZ END IF END IF END IF END IF STOP * 99999 FORMAT (' MC01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01TD = ',I2) 99997 FORMAT (' IWARN on exit from MC01TD = ',I2,/) 99996 FORMAT (' The degree of the polynomial P(x) has been reduced fro', $ 'm ',I2,' to ',I2,/) 99995 FORMAT (' The polynomial P(x) is stable ') 99994 FORMAT (' The polynomial P(x) is unstable ') 99993 FORMAT (/' DP is out of range. ',/' DP = ',I5) 99992 FORMAT (/' The number of zeros of P(x) outside the unit ', $ 'circle = ',I2) 99991 FORMAT (/' The number of zeros of P(x) in the right ', $ 'half-plane = ',I2) END slicot-5.0+20101122/examples/TMC01VD.f000077500000000000000000000021571201767322700165610ustar00rootroot00000000000000* MC01VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) * .. Local Scalars .. DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE INTEGER INFO * .. External Subroutines .. EXTERNAL MC01VD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) A, B, C * Solve the quadratic equation A*x**2 + B*x + C = 0. CALL MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99996 ) Z1RE, Z1IM, Z2RE, Z2IM END IF * STOP * 99999 FORMAT (' MC01VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01VD = ',I2) 99997 FORMAT (' The roots of the quadratic equation are ') 99996 FORMAT (/' x = ',F8.4,2X,SP,F8.4,'*j',SS,/' x = ',F8.4,2X,SP,F8.4, $ '*j') END slicot-5.0+20101122/examples/TMC01WD.f000077500000000000000000000034171201767322700165620ustar00rootroot00000000000000* MC01WD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 10 ) * .. Local Scalars .. DOUBLE PRECISION U1, U2 INTEGER DP, I, INFO * .. Local Arrays .. DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1) * .. External Subroutines .. EXTERNAL MC01WD * .. Executable Statements .. * WRITE ( NOUT,FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) READ ( NIN, FMT = * ) U1, U2 * Compute Q(x) and R(x) from P(x) = (x**2+U2*x+U1) * Q(x) + R(x). CALL MC01WD( DP, P, U1, U2, Q, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 0, DP - 2 WRITE ( NOUT, FMT = 99996 ) I, Q(I+3) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) Q(1) + Q(2)*U2, Q(2) END IF END IF * STOP * 99999 FORMAT (' MC01WD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01WD = ',I2) 99997 FORMAT (' The coefficients of the quotient polynomial Q(x) are ', $ //' power of x coefficient ') 99996 FORMAT (2X,I5,9X,F9.4) 99995 FORMAT (/' The coefficients of the remainder polynomial R(x) are ' $ ,//' power of x coefficient ',/' 0 ',F9.4, $ /' 1 ',F9.4) 99994 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples/TMC03MD.f000077500000000000000000000077161201767322700165600ustar00rootroot00000000000000* MC03MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER CP1MAX, CP2MAX, DP1MAX, DP2MAX, DP3MAX, RP1MAX PARAMETER ( CP1MAX = 10, CP2MAX = 10, DP1MAX = 10, $ DP2MAX = 10, DP3MAX = 20, RP1MAX = 10 ) INTEGER LDP11, LDP12, LDP21, LDP22, LDP31, LDP32 PARAMETER ( LDP11 = RP1MAX, LDP12 = CP1MAX, $ LDP21 = CP1MAX, LDP22 = CP2MAX, $ LDP31 = RP1MAX, LDP32 = CP2MAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA INTEGER CP1, CP2, DP1, DP2, DP3, I, INFO, J, K, RP1 * .. Local Arrays .. DOUBLE PRECISION DWORK(CP1MAX), $ P1(LDP11,LDP12,DP1MAX+1), $ P2(LDP21,LDP22,DP2MAX+1), $ P3(LDP31,LDP32,DP3MAX+1) * .. External Subroutines .. EXTERNAL MC03MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) RP1, CP1, CP2 IF ( RP1.LT.0 .OR. RP1.GT.RP1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) RP1 ELSE IF ( CP1.LT.0 .OR. CP1.GT.CP1MAX ) THEN WRITE ( NOUT, FMT = 99994 ) CP1 ELSE IF ( CP2.LT.0 .OR. CP2.GT.CP2MAX ) THEN WRITE ( NOUT, FMT = 99993 ) CP2 ELSE READ ( NIN, FMT = * ) DP1 IF ( DP1.LE.-2 .OR. DP1.GT.DP1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) DP1 ELSE DO 40 K = 1, DP1 + 1 DO 20 J = 1, CP1 READ ( NIN, FMT = * ) ( P1(I,J,K), I = 1,RP1 ) 20 CONTINUE 40 CONTINUE READ ( NIN, FMT = * ) DP2 IF ( DP2.LE.-2 .OR. DP2.GT.DP2MAX ) THEN WRITE ( NOUT, FMT = 99991 ) DP2 ELSE DO 80 K = 1, DP2 + 1 DO 60 J = 1, CP2 READ ( NIN, FMT = * ) ( P2(I,J,K), I = 1,CP1 ) 60 CONTINUE 80 CONTINUE READ ( NIN, FMT = * ) DP3 IF ( DP3.LE.-2 .OR. DP3.GT.DP3MAX ) THEN WRITE ( NOUT, FMT = 99990 ) DP3 ELSE DO 120 K = 1, DP3 + 1 DO 100 J = 1, CP2 READ ( NIN, FMT = * ) ( P3(I,J,K), I = 1,RP1 ) 100 CONTINUE 120 CONTINUE READ ( NIN, FMT = * ) ALPHA * Compute the coefficients of the polynomial matrix P(x) CALL MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1, $ LDP11, LDP12, P2, LDP21, LDP22, P3, $ LDP31, LDP32, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DP3, $ ( I-1, I = 1,DP3+1 ) DO 160 I = 1, RP1 DO 140 J = 1, CP2 WRITE ( NOUT, FMT = 99996 ) I, J, $ ( P3(I,J,K), K = 1,DP3+1 ) 140 CONTINUE 160 CONTINUE END IF END IF END IF END IF END IF * STOP * 99999 FORMAT (' MC03MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC03MD = ',I2) 99997 FORMAT (' The polynomial matrix P(x) (of degree ',I2,') is ', $ //' power of x ',20I8) 99996 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F7.2)) 99995 FORMAT (/' RP1 is out of range.',/' RP1 = ',I5) 99994 FORMAT (/' CP1 is out of range.',/' CP1 = ',I5) 99993 FORMAT (/' CP2 is out of range.',/' CP2 = ',I5) 99992 FORMAT (/' DP1 is out of range.',/' DP1 = ',I5) 99991 FORMAT (/' DP2 is out of range.',/' DP2 = ',I5) 99990 FORMAT (/' DP3 is out of range.',/' DP3 = ',I5) END slicot-5.0+20101122/examples/TMC03ND.f000077500000000000000000000067641201767322700165630ustar00rootroot00000000000000* MC03ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX, MPMAX, NPMAX * PARAMETER ( DPMAX = 5, MPMAX = 5, NPMAX = 5 ) PARAMETER ( DPMAX = 2, MPMAX = 5, NPMAX = 4 ) INTEGER LDP1, LDP2, LDNULL, LDKER1, LDKER2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX, LDNULL = NPMAX, $ LDKER1 = NPMAX, LDKER2 = NPMAX ) INTEGER M, N PARAMETER ( M = DPMAX*MPMAX, N = ( DPMAX-1 )*MPMAX+NPMAX ) INTEGER LIWORK, LDWORK * PARAMETER ( LIWORK = 3*( N+M )+2, PARAMETER ( LIWORK = M+2*MAX( N,M+1 )+N, $ LDWORK = M*N**2+2*M*N+2*N**2 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DK, DP, I, INFO, J, K, M1, MP, NK, NP * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), KER(LDKER1,LDKER2,M+1), $ NULLSP(LDNULL,(M+1)*NPMAX), P(LDP1,LDP2,DPMAX+1) INTEGER GAM(M+1), IWORK(LIWORK) * .. External Subroutines .. EXTERNAL MC03ND * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP, TOL IF ( MP.LT.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99990 ) MP ELSE IF ( NP.LT.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NP ELSE IF ( DP.LE.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99992 ) DP ELSE DO 40 K = 1, DP + 1 DO 20 I = 1, MP READ ( NIN, FMT = * ) ( P(I,J,K), J = 1,NP ) 20 CONTINUE 40 CONTINUE * Compute a minimal polynomial basis K(s) of the given P(s). CALL MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP, $ LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( DK.LT.0 ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE NK = 0 M1 = 0 DO 60 I = 1, DK + 1 NK = NK + GAM(I) M1 = M1 + GAM(I)*I 60 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 80 I = 1, NP WRITE ( NOUT, FMT = 99995 ) ( NULLSP(I,J), J = 1,M1 ) 80 CONTINUE WRITE ( NOUT, FMT = 99994 ) DK, ( I-1, I = 1,DK+1 ) DO 120 I = 1, NP DO 100 J = 1, NK WRITE ( NOUT, FMT = 99993 ) $ I, J, ( KER(I,J,K), K = 1,DK+1 ) 100 CONTINUE 120 CONTINUE END IF END IF STOP * 99999 FORMAT (' MC03ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC03ND = ',I2) 99997 FORMAT (' The polynomial matrix P(s) has no right nullspace') 99996 FORMAT (' The right nullspace vectors of P(s) are ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The minimal polynomial basis K(s) (of degree ',I2,') ', $ 'for the right nullspace is ',//' power of s ', $ 20I8) 99993 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F7.2)) 99992 FORMAT (/' DP is out of range.',/' DP = ',I5) 99991 FORMAT (/' NP is out of range.',/' NP = ',I5) 99990 FORMAT (/' MP is out of range.',/' MP = ',I5) END slicot-5.0+20101122/examples/TMD03AD.f000077500000000000000000000152231201767322700165350ustar00rootroot00000000000000* MD03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDWORK PARAMETER ( LDWORK = MMAX + 2*NMAX + MMAX*NMAX + $ MAX( NMAX*NMAX, 3*NMAX + MMAX ) ) * .. The lengths of DPAR1, DPAR2, IPAR are set to 1, 1, and 5 .. INTEGER LDPAR1, LDPAR2, LIPAR PARAMETER ( LDPAR1 = 1, LDPAR2 = 1, LIPAR = 5 ) * .. Local Scalars .. CHARACTER*1 ALG, STOR, UPLO, XINIT INTEGER I, INFO, ITMAX, IWARN, M, N, NFEV, NJEV, NPRINT DOUBLE PRECISION CGTOL, TOL * .. Array Arguments .. INTEGER IPAR(LIPAR) DOUBLE PRECISION DPAR1(LDPAR1), DPAR2(LDPAR2), DWORK(LDWORK), $ X(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MD03AD, MD03AF, NF01BV, NF01BX * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, ITMAX, NPRINT, TOL, CGTOL, XINIT, $ ALG, STOR, UPLO IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE IF ( LSAME( XINIT, 'G' ) ) $ READ ( NIN, FMT = * ) ( X(I), I = 1,N ) * Solve a standard nonlinear least squares problem. IPAR(1) = M IF ( LSAME( ALG, 'D' ) ) THEN CALL MD03AD( XINIT, ALG, STOR, UPLO, MD03AF, NF01BV, M, $ N, ITMAX, NPRINT, IPAR, LIPAR, DPAR1, $ LDPAR1, DPAR2, LDPAR2, X, NFEV, NJEV, TOL, $ CGTOL, DWORK, LDWORK, IWARN, INFO ) ELSE CALL MD03AD( XINIT, ALG, STOR, UPLO, MD03AF, NF01BX, M, $ N, ITMAX, NPRINT, IPAR, LIPAR, DPAR1, $ LDPAR1, DPAR2, LDPAR2, X, NFEV, NJEV, TOL, $ CGTOL, DWORK, LDWORK, IWARN, INFO ) END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99991 ) IWARN WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) NFEV, NJEV WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, N ) END IF END IF END IF STOP * 99999 FORMAT (' MD03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MD03AD = ',I2) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' The number of function and Jacobian evaluations = ', $ 2I7) 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (' IWARN on exit from MD03AD = ',I2) END C SUBROUTINE MD03AF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEVL, E, J, LDJ, JTE, DWORK, $ LDWORK, INFO ) C C This is the FCN routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03AD. See the C argument FCN in the routine MD03AD 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 ZERO, ONE PARAMETER ( ZERO = 0.0D0, 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,*), $ JTE(*), X(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION ERR, TMP1, TMP2, TMP3, TMP4 C .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 C .. External Subroutines .. EXTERNAL DGEMV 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, e. 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 C Compute the product J'*e (the error e was computed in array E). C CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, E, 1, ZERO, JTE, $ 1 ) 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 MD03AF (IFLAG = 1 or 2), NF01BV and C NF01BX. C LDJ = M IPAR(1) = M*N IPAR(2) = 0 IPAR(3) = 0 IPAR(4) = M ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( M, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR C END IF C DWORK(1) = ZERO RETURN C C *** Last line of MD03AF *** END slicot-5.0+20101122/examples/TMD03BD.f000077500000000000000000000210161201767322700165330ustar00rootroot00000000000000* MD03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDWORK PARAMETER ( LDWORK = MMAX + $ MAX( MMAX*NMAX + 5*NMAX + 1, $ NMAX*NMAX + NMAX + $ MAX( MMAX, 5*NMAX ) ) ) * .. Local Scalars .. CHARACTER*1 COND, SCALE, XINIT INTEGER I, INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LIPAR, M, $ N, NFEV, NJEV, NPRINT DOUBLE PRECISION FACTOR, FTOL, GTOL, TOL, XTOL * .. Array Arguments .. INTEGER IPAR(5), IWORK(NMAX+1) DOUBLE PRECISION DIAG(NMAX), DPAR1(1), DPAR2(1), DWORK(LDWORK), $ X(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MD03BA, MD03BB, MD03BD, MD03BF * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, ITMAX, LIPAR, LDPAR1, LDPAR2, FACTOR, $ NPRINT, FTOL, XTOL, GTOL, TOL, XINIT, SCALE, $ COND IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE IF ( LSAME( SCALE, 'S' ) ) $ READ ( NIN, FMT = * ) ( DIAG(I), I = 1,N ) IF ( LSAME( XINIT, 'G' ) ) $ READ ( NIN, FMT = * ) ( X(I), I = 1,N ) * Solve a standard nonlinear least squares problem. IPAR(1) = M CALL MD03BD( XINIT, SCALE, COND, MD03BF, MD03BA, MD03BB, $ M, N, ITMAX, FACTOR, NPRINT, IPAR, LIPAR, $ DPAR1, LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV, $ NJEV, FTOL, XTOL, GTOL, TOL, IWORK, DWORK, $ LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99991 ) IWARN WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) NFEV, NJEV WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, N ) END IF END IF END IF STOP * 99999 FORMAT (' MD03BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MD03BD = ',I2) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' The number of function and Jacobian evaluations = ', $ 2I7) 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (' IWARN on exit from MD03BD = ',I2) END C SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK, $ INFO ) C C This is the FCN routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03BD. See the C argument 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 .. External Subroutines .. EXTERNAL MD03BA, MD03BB 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 MD03BF (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 ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( M, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR C END IF C RETURN C C *** Last line of MD03BF *** END C SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, $ GNORM, IPVT, DWORK, LDWORK, INFO ) C C This is the QRFACT routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03BD. See the C argument QRFACT in the routine MD03BD for the description of C parameters. C C For efficiency, the arguments are not checked. This is done in C the routine MD03BX (except for LIPAR). 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(LDJ,*), 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 C SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, $ INFO ) C C This is the LMPARM routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03BD. See the C argument LMPARM in the routine MD03BD for the description of C parameters. C C For efficiency, the arguments are not checked. This is done in C the routine MD03BY (except for LIPAR). 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 slicot-5.0+20101122/examples/TSB01BD.f000077500000000000000000000106701201767322700165410ustar00rootroot00000000000000* SB01BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDF, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDF = MMAX, $ LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 5*MMAX,5*NMAX,2*NMAX+4*MMAX ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, ANORM, NRM, TOL INTEGER I, INFO, IWARN, J, M, N, NAP, NFP, NP, NUP CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AIN(LDA,NMAX), B(LDB,MMAX), $ DWORK(LDWORK), F(LDF,NMAX), WI(NMAX), WR(NMAX), $ Z(LDZ,NMAX), ZTA(LDZ,NMAX) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, MB03QX, SB01BD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, ALPHA, TOL, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF( NP.LT.0 .OR. NP.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NP ELSE DO 10 I = 1, NP READ ( NIN, FMT = * ) WR(I), WI(I) 10 CONTINUE * Perform "eigenvalue assignment" to compute F. CALL DLACPY( 'G', N, N, A, LDA, AIN, LDA ) CALL SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, $ WR, WI, NFP, NAP, NUP, F, LDF, Z, LDZ, $ TOL, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 .AND. INFO.LT.3 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE IF ( INFO .NE. 0 ) WRITE ( NOUT, FMT = 99997 ) INFO IF ( IWARN .NE. 0 ) WRITE ( NOUT, FMT = 99991 ) IWARN WRITE ( NOUT, FMT = 99990 ) NAP WRITE ( NOUT, FMT = 99989 ) NFP WRITE ( NOUT, FMT = 99988 ) NUP WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,N ) 60 CONTINUE CALL MB03QX( N, A, LDA, WR, WI, INFO ) WRITE ( NOUT, FMT = 99998 ) ( WR(I), WI(I), I = 1,N ) * Compute NORM (Z*Aout*Z'-(A+B*F)) / (eps*NORM(A)) ANORM = DLANGE( 'F', N, N, AIN, LDA, DWORK ) CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, F, LDF, $ ONE, AIN, LDA ) CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, A, LDA, $ ZERO, ZTA, LDZ ) CALL DGEMM( 'N', 'T', N, N, N, ONE, ZTA, LDZ, Z, LDZ, $ -ONE, AIN, LDA ) NRM = DLANGE( 'F', N, N, AIN, LDA, DWORK ) / $ ( DLAMCH( 'E' )*ANORM ) WRITE ( NOUT, FMT = 99987 ) NRM END IF END IF END IF END IF STOP * 99999 FORMAT (' SB01BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/,' The eigenvalues of closed-loop matrix A+B*F',/ $ ( ' ( ',F8.4,',',F8.4,' )' ) ) 99997 FORMAT (' INFO on exit from SB01BD = ',I2) 99996 FORMAT (/,' The state feedback matrix F is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' NP is out of range.',/' NP = ',I5) 99991 FORMAT (/' IWARN on exit from SB01BD = ', I2) 99990 FORMAT ( ' Number of assigned eigenvalues: NAP = ', I2 ) 99989 FORMAT ( ' Number of fixed eigenvalues: NFP = ', I2) 99988 FORMAT ( ' Number of uncontrollable poles: NUP = ', I2) 99987 FORMAT (/,' NORM(A+B*F - Z*Aout*Z'') / (eps*NORM(A)) =',1PD12.5) END slicot-5.0+20101122/examples/TSB01DD.f000077500000000000000000000060201201767322700165350ustar00rootroot00000000000000* SB01DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDG, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDG = MMAX, $ LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 3*NMAX, MMAX*NMAX, $ MMAX*MMAX + 2*NMAX + 4*MMAX + 1 ) $ ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER COUNT, I, INDCON, INFO1, INFO2, J, M, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. INTEGER IWORK(MMAX), NBLK(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(NMAX,MMAX), DWORK(LDWORK), $ G(LDG,NMAX), WI(NMAX), WR(NMAX), Y(MMAX*NMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL AB01ND, SB01DD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, JOBZ IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( WR(I), I = 1,N ) READ ( NIN, FMT = * ) ( WI(I), I = 1,N ) READ ( NIN, FMT = * ) ( Y(I), I = 1,M*N ) * First reduce the given system to canonical form. CALL AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, $ NBLK, Z, LDZ, DWORK, TOL, IWORK, DWORK(N+1), $ LDWORK-N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN * Find the state feedback matrix G. CALL SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI, $ Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK, $ LDWORK, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,N ) 10 CONTINUE END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF END IF STOP * 99999 FORMAT (' SB01DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01ND =',I2) 99997 FORMAT (' INFO on exit from SB01DD =',I2) 99996 FORMAT (' The state feedback matrix G is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TSB01MD.f000077500000000000000000000042631201767322700165550ustar00rootroot00000000000000* SB01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDZ PARAMETER ( LDA = NMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO1, INFO2, J, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), G(NMAX), $ WI(NMAX), WR(NMAX), Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL AB01MD, SB01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TOL, JOBZ IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( B(I), I = 1,N ) READ ( NIN, FMT = * ) ( WR(I), I = 1,N ) READ ( NIN, FMT = * ) ( WI(I), I = 1,N ) * First reduce the given system to canonical form. CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, DWORK, TOL, $ DWORK(N+1), LDWORK-N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN * Find the one-dimensional state feedback matrix G. CALL SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK, $ INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99996 ) ( G(I), I = 1,NCONT ) END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01MD =',I2) 99997 FORMAT (' INFO on exit from SB01MD =',I2) 99996 FORMAT (' The one-dimensional state feedback matrix G is', $ /20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TSB02MD.f000077500000000000000000000044041201767322700165530ustar00rootroot00000000000000* SB02MD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDS, LDU PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, $ LDS = 2*NMAX, LDU = 2*NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 6*NMAX ) * .. Local Scalars .. DOUBLE PRECISION RCOND INTEGER I, INFO, J, N CHARACTER DICO, HINV, SCAL, SORT, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), S(LDS,2*NMAX), U(LDU,2*NMAX), $ WI(2*NMAX), WR(2*NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB02MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DICO, HINV, UPLO, SCAL, SORT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RCOND DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( Q(I,J), J = 1,N ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' SB02MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02MD = ',I2) 99997 FORMAT (' RCOND = ',F4.2,//' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TSB02ND.f000077500000000000000000000106771201767322700165650ustar00rootroot00000000000000* SB02ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER NMAX2 PARAMETER ( NMAX2 = 2*NMAX ) INTEGER LDA, LDB, LDC, LDL, LDR, LDS, LDT, LDU, LDX, LDF PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDL = NMAX, $ LDR = MAX(MMAX,PMAX), LDS = NMAX2+MMAX, $ LDT = NMAX2+MMAX, LDU = NMAX2, LDX = NMAX, $ LDF = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( NMAX2,MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX+3*MMAX+2, 14*NMAX+23, $ 16*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL, RCOND, RNORM INTEGER I, INFO1, INFO2, J, M, N, P CHARACTER*1 DICO, FACT, JOBB, JOBL, SORT, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFAI(2*NMAX), ALFAR(2*NMAX), $ B(LDB,MMAX), BETA(2*NMAX), C(LDC,NMAX), $ DWORK(LDWORK), F(LDF,NMAX), L(LDL,MMAX), $ R(LDR,MMAX), S(LDS,NMAX2+MMAX), T(LDT,NMAX2), $ U(LDU,NMAX2), X(LDX,NMAX) INTEGER IPIV(LIWORK), IWORK(LIWORK), OUFACT(2) LOGICAL BWORK(NMAX2) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02ND, SB02OD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, FACT, JOBL, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( FACT, 'D' ) ) THEN READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,P ) ELSE READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,M ) END IF * Find the solution matrix X. JOBB = 'B' SORT = 'S' CALL SB02OD( DICO, JOBB, 'Both', UPLO, JOBL, SORT, N, M, $ P, A, LDA, B, LDB, C, LDC, R, LDR, L, LDL, $ RCOND, X, LDX, ALFAR, ALFAI, BETA, S, LDS, $ T, LDT, U, LDU, TOL, IWORK, DWORK, LDWORK, $ BWORK, INFO1 ) * IF ( INFO1.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO1 ELSE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 20 CONTINUE * Compute the optimal feedback matrix F. CALL 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, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( F(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' SB02ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02OD = ',I2) 99997 FORMAT (' INFO on exit from SB02ND = ',I2) 99996 FORMAT (' The solution matrix X is ') 99995 FORMAT (/' The optimal feedback matrix F is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TSB02OD.f000077500000000000000000000107251201767322700165600ustar00rootroot00000000000000* SB02OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER NMAX2M, NMAX2 PARAMETER ( NMAX2M = 2*NMAX+MMAX, NMAX2 = 2*NMAX ) INTEGER LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDL = NMAX, $ LDQ = MAX(NMAX,PMAX), LDR = MAX(MMAX,PMAX), $ LDS = NMAX2M, LDT = NMAX2M, LDU = NMAX2, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX(MMAX,NMAX2) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX(14*NMAX+23,16*NMAX) ) INTEGER LBWORK PARAMETER ( LBWORK = NMAX2 ) * .. Local Scalars .. DOUBLE PRECISION RCOND, TOL INTEGER I, INFO, J, M, N, P CHARACTER*1 DICO, FACT, JOBB, JOBL, SORT, UPLO LOGICAL LJOBB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFAI(NMAX2), ALFAR(NMAX2), $ B(LDB,MMAX), BETA(NMAX2), DWORK(LDWORK), $ L(LDL,MMAX), Q(LDQ,NMAX), R(LDR,MMAX), $ S(LDS,NMAX2M), T(LDT,NMAX2), U(LDU,NMAX2), $ X(LDX,NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LBWORK) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02OD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBB, FACT, UPLO, JOBL, $ SORT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE LJOBB = LSAME( JOBB, 'B' ) IF ( LJOBB ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) END IF IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99993 ) P ELSE IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'D' ) ) THEN READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,N ) ELSE READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,P ) END IF IF ( LJOBB ) THEN IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'C' ) ) THEN READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,M ) ELSE READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,P ) END IF IF ( LSAME( JOBL, 'N' ) ) $ READ ( NIN, FMT = * ) $ ( ( L(I,J), J = 1,M ), I = 1,N ) END IF * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB02OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02OD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TSB02PD.f000077500000000000000000000053201201767322700165540ustar00rootroot00000000000000* SB02PD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*NMAX, NMAX*NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 4*NMAX*NMAX + 8*NMAX, $ 6*NMAX*NMAX ) + 1 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND INTEGER I, INFO, J, N CHARACTER JOB, TRANA, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), WI(NMAX), WR(NMAX), $ X(LDX,NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02PD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, TRANA, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X, $ LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO END IF IF ( INFO.EQ.0 .OR. INFO.EQ.2 .OR. INFO.EQ.4 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE IF ( LSAME( JOB, 'A' ) .AND. INFO.NE.4 ) THEN WRITE ( NOUT, FMT = 99994 ) RCOND WRITE ( NOUT, FMT = 99993 ) FERR END IF END IF END IF STOP * 99999 FORMAT (' SB02PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02PD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99993 FORMAT (/' Estimated error bound = ',F20.16) END slicot-5.0+20101122/examples/TSB02QD.f000077500000000000000000000123651201767322700165640ustar00rootroot00000000000000* SB02QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 8*NMAX*NMAX + 10*NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCND, RCOND, SEP INTEGER I, INFO1, INFO2, INFO3, IS, IU, IW, J, N, N2, $ SDIM CHARACTER*1 FACT, JOB, JOBS, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), T(LDT,NMAX), U(LDU,NMAX), $ X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT * .. External Subroutines .. EXTERNAL DGEES, DLACPY, DSYMM, MA02ED, MB01RU, SB02MD, $ SB02QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( UPLO, N, N, Q, LDQ, X, LDX ) N2 = 2*N IS = 2*N2 + 1 IU = IS + N2*N2 IW = IU + N2*N2 * Solve the continuous-time Riccati equation. CALL SB02MD( 'continuous', 'direct', UPLO, 'no scaling', $ 'stable', N, A, LDA, G, LDG, X, LDX, RCND, $ DWORK(1), DWORK(N2+1), DWORK(IS), N2, DWORK(IU), $ N2, IWORK, DWORK(IW), LDWORK-IW+1, BWORK, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99995 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( FACT, 'F' ) .OR. LSAME( LYAPUN, 'R' ) ) THEN CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) IF ( LSAME( TRANA, 'N' ) ) THEN * Compute Ac = A-G*X. CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, $ ONE, T, LDT ) ELSE * Compute Ac = A-X*G. CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, $ ONE, T, LDT ) END IF * Compute the Schur factorization of Ac. JOBS = 'V' CALL DGEES( JOBS, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK(1), DWORK(N+1), U, LDU, DWORK(2*N+1), $ LDWORK-2*N, BWORK, INFO3 ) IF( INFO3.NE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) INFO3 STOP END IF END IF * IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF * CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, $ U, LDU, G, LDG, DWORK, N*N, INFO2 ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, $ U, LDU, Q, LDQ, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL 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, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 END IF IF ( INFO2.EQ.0 .OR. INFO2.EQ.N+1 ) THEN WRITE ( NOUT, FMT = 99992 ) SEP WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB02QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02MD =',I2) 99997 FORMAT (' INFO on exit from SB02QD =',I2) 99996 FORMAT (' INFO on exit from DGEES =',I2) 99995 FORMAT (' The solution matrix X is') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB02RD.f000077500000000000000000000073261201767322700165660ustar00rootroot00000000000000* SB02RD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDS, LDT, LDV, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, $ LDS = 2*NMAX, LDT = NMAX, LDV = NMAX, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*NMAX, NMAX*NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 5 + 4*NMAX*NMAX + 8*NMAX ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SEP INTEGER I, INFO, J, N CHARACTER DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, TRANA, $ UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), S(LDS,2*NMAX), T(LDT,NMAX), $ V(LDV,NMAX), WI(2*NMAX), WR(2*NMAX), X(LDX,NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02RD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, $ FACT, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) .OR. $ LSAME( FACT, 'N' ) .OR. LSAME( LYAPUN, 'O' ) ) $ READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( .NOT.LSAME( JOB, 'X' ) .AND. LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N ) END IF READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO END IF IF ( INFO.EQ.0 .OR. INFO.EQ.7 ) THEN IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99994 ) SEP WRITE ( NOUT, FMT = 99993 ) RCOND END IF IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99992 ) FERR END IF END IF STOP * 99999 FORMAT (' SB02RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02RD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' Estimated separation = ',F8.4) 99993 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99992 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB02SD.f000077500000000000000000000131701201767322700165610ustar00rootroot00000000000000* SB02SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 8*NMAX*NMAX + 10*NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCND, RCOND, SEPD INTEGER I, INFO1, INFO2, INFO3, IS, IU, IW, J, N, N2, $ SDIM CHARACTER*1 FACT, JOB, JOBS, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AS(LDA,NMAX), DWORK(LDWORK), $ G(LDG,NMAX), Q(LDQ,NMAX), T(LDT,NMAX), $ U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT * .. External Subroutines .. EXTERNAL DGEES, DGESV, DLACPY, DLASET, DSWAP, DSYMM, $ MA02AD, MA02ED, MB01RU, SB02MD, SB02SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'Full', N, N, A, LDA, AS, LDA ) CALL DLACPY( UPLO, N, N, Q, LDQ, X, LDX ) N2 = 2*N IS = 2*N2 + 1 IU = IS + N2*N2 IW = IU + N2*N2 * Solve the discrete-time Riccati equation. CALL SB02MD( 'discrete', 'direct', UPLO, 'no scaling', $ 'stable', N, AS, LDA, G, LDG, X, LDX, RCND, $ DWORK(1), DWORK(N2+1), DWORK(IS), N2, DWORK(IU), $ N2, IWORK, DWORK(IW), LDWORK-IW+1, BWORK, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99995 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( FACT, 'F' ) .OR. LSAME( LYAPUN, 'R' ) ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK, N ) CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, $ ONE, DWORK, N ) IF ( LSAME( TRANA, 'N' ) ) THEN * Compute Ac = inv(I_n + G*X)*A. CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 ) ELSE * Compute Ac = A*inv(I_n + X*G) CALL MA02AD( 'Full', N, N, A, LDA, T, LDT ) CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 ) DO 20 J = 2, N CALL DSWAP( J-1, T(1,J), 1, T(J,1), LDT ) 20 CONTINUE END IF * Compute the Schur factorization of Ac. JOBS = 'V' CALL DGEES( JOBS, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK(1), DWORK(N+1), U, LDU, DWORK(2*N+1), $ LDWORK-2*N, BWORK, INFO3 ) IF( INFO3.NE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) INFO3 STOP END IF END IF * IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF * CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, $ U, LDU, G, LDG, DWORK, N*N, INFO2 ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, $ U, LDU, Q, LDQ, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL 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, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 END IF IF ( INFO2.EQ.0 .OR. INFO2.EQ.N+1 ) THEN WRITE ( NOUT, FMT = 99992 ) SEPD WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB02SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02MD =',I2) 99997 FORMAT (' INFO on exit from SB02SD =',I2) 99996 FORMAT (' INFO on exit from DGEES =',I2) 99995 FORMAT (' The solution matrix X is') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB03MD.f000077500000000000000000000050651201767322700165600ustar00rootroot00000000000000* SB03MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDU PARAMETER ( LDA = NMAX, LDC = NMAX, LDU = NMAX ) INTEGER LDWORK, LIWORK PARAMETER ( LDWORK = 2*NMAX*NMAX + 3*NMAX, $ LIWORK = NMAX*NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N CHARACTER*1 DICO, FACT, JOB, TRANA DOUBLE PRECISION FERR, SCALE, SEP * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DICO, FACT, JOB, TRANA IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, $ SCALE, SEP, FERR, WR, WI, IWORK, DWORK, LDWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) SCALE IF ( .NOT.LSAME( JOB, 'X' ) ) $ WRITE ( NOUT, FMT = 99993 ) SEP IF ( LSAME( JOB, 'B' ) ) $ WRITE ( NOUT, FMT = 99992 ) FERR END IF END IF STOP * 99999 FORMAT (' SB03MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03MD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' Scaling factor = ',F8.4) 99993 FORMAT (/' Estimated separation = ',F8.4) 99992 FORMAT (/' Estimated forward error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB03OD.f000077500000000000000000000074351201767322700165650ustar00rootroot00000000000000* SB03OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDQ, LDX, LDWORK PARAMETER ( LDA = NMAX, LDB = MAX( MMAX,NMAX ), $ LDQ = NMAX, LDX = NMAX ) PARAMETER ( LDWORK = 4*NMAX+MIN(MMAX,NMAX) ) * .. Local Scalars .. DOUBLE PRECISION SCALE, TEMP INTEGER I, INFO, J, K, M, N CHARACTER*1 DICO, FACT, TRANS * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,LDB), DWORK(LDWORK), $ Q(LDQ,NMAX), WR(NMAX), WI(NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03OD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF ( LSAME( TRANS, 'N' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) END IF * Find the Cholesky factor U. CALL SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 J = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), I = 1,J ) 20 CONTINUE * Form the solution matrix X = op(U)'*op(U). IF ( LSAME( TRANS, 'N' ) ) THEN DO 80 I = 1, N DO 60 J = I, N TEMP = ZERO DO 40 K = 1, I TEMP = TEMP + B(K,I)*B(K,J) 40 CONTINUE X(I,J) = TEMP X(J,I) = TEMP 60 CONTINUE 80 CONTINUE ELSE DO 140 I = 1, N DO 120 J = I, N TEMP = ZERO DO 100 K = J, N TEMP = TEMP + B(I,K)*B(J,K) 100 CONTINUE X(I,J) = TEMP X(J,I) = TEMP 120 CONTINUE 140 CONTINUE END IF WRITE ( NOUT, FMT = 99995 ) DO 160 J = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), I = 1,N ) 160 CONTINUE WRITE ( NOUT, FMT = 99992 ) SCALE END IF END IF END IF STOP * 99999 FORMAT (' SB03OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03OD = ',I2) 99997 FORMAT (' The transpose of the Cholesky factor U is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The solution matrix X = op(U)''*op(U) is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' Scaling factor = ',F8.4) END slicot-5.0+20101122/examples/TSB03QD.f000077500000000000000000000100731201767322700165570ustar00rootroot00000000000000* SB03QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 3*NMAX*NMAX + NMAX - 1, $ 5*NMAX ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEP INTEGER I, INFO1, INFO2, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLACPY, MA02ED, MB01RU, SB03MD, SB03QD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'C' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DLACPY( 'Full', N, N, C, LDC, X, LDX ) * Solve the continuous-time Lyapunov matrix equation. CALL SB03MD( DICO, 'X', FACT, TRANA, N, T, LDT, U, LDU, X, LDX, $ SCALE, SEP, FERR, DWORK(1), DWORK(N+1), IWORK, $ DWORK(2*N+1), LDWORK-2*N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, C, LDC, $ U, LDU, C, LDC, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL SB03QD( JOB, 'F', TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99993 ) SCALE WRITE ( NOUT, FMT = 99992 ) SEP WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB03QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03MD =',I2) 99997 FORMAT (' INFO on exit from SB03QD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB03SD.f000077500000000000000000000100741201767322700165620ustar00rootroot00000000000000* SB03SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 3, 2*NMAX*NMAX ) + $ NMAX*NMAX + 2*NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEPD INTEGER I, INFO1, INFO2, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLACPY, MA02ED, MB01RU, SB03MD, SB03SD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'D' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DLACPY( 'Full', N, N, C, LDC, X, LDX ) * Solve the discrete-time Lyapunov matrix equation. CALL SB03MD( DICO, 'X', FACT, TRANA, N, T, LDT, U, LDU, X, LDX, $ SCALE, SEPD, FERR, DWORK(1), DWORK(N+1), IWORK, $ DWORK(2*N+1), LDWORK-2*N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, C, LDC, $ U, LDU, C, LDC, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL SB03SD( JOB, 'F', TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99993 ) SCALE WRITE ( NOUT, FMT = 99992 ) SEPD WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB03SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03MD =',I2) 99997 FORMAT (' INFO on exit from SB03SD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB03TD.f000077500000000000000000000074541201767322700165730ustar00rootroot00000000000000* SB03TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 3*NMAX*NMAX + NMAX - 1 ) ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEP INTEGER I, INFO, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03TD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'C' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) SCALE IF ( LSAME( FACT, 'N' ) .OR. ( LSAME( LYAPUN, 'O' ) .AND. $ .NOT.LSAME( JOB, 'X') ) ) $ READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( LYAPUN, 'O' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) END IF IF ( .NOT.LSAME( JOB, 'S' ) ) $ READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Solve the continuous-time Lyapunov matrix equation and/or * estimate the condition and error bound on the solution. CALL SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, LDA, $ T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, FERR, $ DWORK(1), DWORK(N+1), IWORK, DWORK(2*N+1), $ LDWORK-2*N, INFO ) * IF ( INFO.EQ.0 ) THEN IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99993 ) SCALE END IF IF ( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'C' ) $ .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99992 ) SEP IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99991 ) RCOND IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99990 ) FERR ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB03TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03TD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB03UD.f000077500000000000000000000075361201767322700165750ustar00rootroot00000000000000* SB03UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 3, 2*NMAX*NMAX ) + $ NMAX*NMAX + 2*NMAX ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEPD INTEGER I, INFO, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03UD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'D' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) SCALE IF ( LSAME( FACT, 'N' ) .OR. ( LSAME( LYAPUN, 'O' ) .AND. $ .NOT.LSAME( JOB, 'X') ) ) $ READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( LYAPUN, 'O' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) END IF IF ( .NOT.LSAME( JOB, 'S' ) ) $ READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Solve the discrete-time Lyapunov matrix equation and/or * estimate the condition and error bound on the solution. CALL SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, LDA, $ T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, FERR, $ DWORK(1), DWORK(N+1), IWORK, DWORK(2*N+1), $ LDWORK-2*N, INFO ) * IF ( INFO.EQ.0 ) THEN IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99993 ) SCALE END IF IF ( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'C' ) $ .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99992 ) SEPD IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99991 ) RCOND IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99990 ) FERR ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB03UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03UD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples/TSB04MD.f000077500000000000000000000047441201767322700165640ustar00rootroot00000000000000* SB04MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC, LDZ PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX, $ LDZ = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 4*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 2*NMAX*NMAX+8*NMAX, 5*MMAX, $ NMAX+MMAX ) ) * .. Local Scalars .. INTEGER I, INFO, J, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK), Z(LDZ,MMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04MD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( Z(I,J), J = 1,M ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04MD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The orthogonal matrix Z is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TSB04ND.f000077500000000000000000000045321201767322700165600ustar00rootroot00000000000000* SB04ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*( MAX( NMAX,MMAX ) )* $ ( 4+2*( MAX( NMAX,MMAX ) ) ) ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAX( NMAX,MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N CHARACTER*1 ABSCHU, ULA, ULB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04ND * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, ULA, ULB, ABSCHU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04ND = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TSB04OD.f000077500000000000000000000110701201767322700165540ustar00rootroot00000000000000* SB04OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 10, NMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, LDU, LDV PARAMETER ( LDA = MMAX, LDB = NMAX, LDC = MMAX, LDD = MMAX, $ LDE = NMAX, LDF = MMAX, LDP = MMAX, LDQ = MMAX, $ LDU = NMAX, LDV = NMAX ) INTEGER LDWORK, LIWORK PARAMETER ( LDWORK = MAX(7*MAX(MMAX,NMAX),2*MMAX*NMAX), $ LIWORK = MMAX+NMAX+6 ) * .. Local Scalars .. DOUBLE PRECISION DIF, SCALE INTEGER I, INFO, J, M, N CHARACTER*1 JOBD, REDUCE, TRANS * .. Local Arrays .. DOUBLE PRECISION A(LDA,MMAX), B(LDB,NMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), E(LDE,NMAX), $ F(LDF,NMAX), P(LDP,MMAX), Q(LDQ,MMAX), $ U(LDU,NMAX), V(LDV,NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB04OD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, REDUCE, TRANS, JOBD IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,M ), I = 1,M ) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M ) * Find the solution matrices L and R. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( F(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( C(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( REDUCE, 'R' ).OR.LSAME( REDUCE, 'A' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( P(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( Q(I,J), J = 1,M ) 80 CONTINUE END IF IF ( LSAME( REDUCE, 'R' ).OR.LSAME( REDUCE, 'B' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99991 ) ( U(I,J), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 120 I = 1, N WRITE ( NOUT, FMT = 99991 ) ( V(I,J), J = 1,N ) 120 CONTINUE END IF IF ( SCALE.NE.ONE ) WRITE ( NOUT, FMT = 99987 ) SCALE IF ( .NOT.LSAME( JOBD, 'N' ) ) $ WRITE ( NOUT, FMT = 99990 ) DIF END IF END IF END IF * STOP * 99999 FORMAT (' SB04OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04OD = ',I2) 99997 FORMAT (' The solution matrix L is ') 99996 FORMAT (/' The solution matrix R is ') 99995 FORMAT (/' The left transformation matrix P is ') 99994 FORMAT (/' The right transformation matrix Q is ') 99993 FORMAT (/' The left transformation matrix U is ') 99992 FORMAT (/' The right transformation matrix V is ') 99991 FORMAT (20(1X,F8.4)) 99990 FORMAT (/' DIF = ',F8.4) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' SCALE = ',F8.4) END slicot-5.0+20101122/examples/TSB04PD.f000077500000000000000000000066321201767322700165650ustar00rootroot00000000000000* SB04PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDB, LDC, LDU, LDV PARAMETER ( LDA = MMAX, LDB = NMAX, LDC = MMAX, $ LDU = MMAX, LDV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 1 + 2*MMAX + MAX( 3*MMAX, 5*NMAX, $ 2*( NMAX + MMAX ) ) ) * .. Local Scalars .. CHARACTER DICO, FACTA, FACTB, TRANA, TRANB INTEGER I, INFO, ISGN, J, M, N DOUBLE PRECISION SCALE * .. Local Arrays .. DOUBLE PRECISION A(LDA,MMAX), B(LDB,NMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,MMAX), V(LDV,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB04PD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, ISGN, DICO, FACTA, FACTB, TRANA, TRANB IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,M ), I = 1,M ) IF ( LSAME( FACTA, 'F' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,M ) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACTB, 'F' ) ) $ READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M ) * Find the solution matrix X. CALL SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N, $ A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO IF ( INFO.EQ.0 .OR. INFO.EQ.M+N+1 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) SCALE IF ( LSAME( FACTA, 'N' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,M ) 40 CONTINUE END IF IF ( LSAME( FACTB, 'N' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( V(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB04PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04PD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' Scaling factor = ',F8.4) 99994 FORMAT (/' The orthogonal matrix U is ') 99993 FORMAT (/' The orthogonal matrix V is ') 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TSB04QD.f000077500000000000000000000047441201767322700165700ustar00rootroot00000000000000* SB04QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC, LDZ PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX, $ LDZ = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 4*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 2*NMAX*NMAX+9*NMAX, 5*MMAX, $ NMAX+MMAX ) ) * .. Local Scalars .. INTEGER I, INFO, J, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK), Z(LDZ,MMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04QD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( Z(I,J), J = 1,M ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04QD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The orthogonal matrix Z is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TSB04RD.f000077500000000000000000000045321201767322700165640ustar00rootroot00000000000000* SB04RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*( MAX( NMAX,MMAX ) )* $ ( 4+2*( MAX( NMAX,MMAX ) ) ) ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAX( NMAX,MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N CHARACTER*1 ABSCHU, ULA, ULB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04RD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, ULA, ULB, ABSCHU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04RD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TSB06ND.f000077500000000000000000000063151201767322700165630ustar00rootroot00000000000000* SB06ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDU, LDV, LDF PARAMETER ( LDA = NMAX, LDB = NMAX, LDU = NMAX, $ LDV = MMAX, LDF = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX + MAX(NMAX,3*MMAX) ) * PARAMETER ( LDWORK = 4*NMAX) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, KMAX, M, N, NCONT CHARACTER*1 JOBU, JOBV * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK), $ F(LDF,NMAX), U(LDU,NMAX), V(LDV,MMAX) INTEGER IWORK(LIWORK), KSTAIR(NMAX) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB01OD, DLASET, SB06ND * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, JOBU, JOBV IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) * First put (A,B) into staircase form with triangular pivots * and determine the stairsizes. CALL AB01OD( 'A', JOBU, JOBV, N, M, A, LDA, B, LDB, U, $ LDU, V, LDV, NCONT, KMAX, KSTAIR, TOL, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.EQ.0 ) THEN IF( LSAME( JOBU, 'N' ) ) THEN * Initialize U as the identity matrix. CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) END IF * Perform "deadbeat control" to give F. CALL SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, $ F, LDF, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,N ) 60 CONTINUE END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF END IF STOP * 99999 FORMAT (' SB06ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01OD = ',I2) 99997 FORMAT (' INFO on exit from SB06ND = ',I2) 99996 FORMAT (' The deadbeat feedback matrix F is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TSB08CD.f000077500000000000000000000111541201767322700165470ustar00rootroot00000000000000* SB08CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MPMAX PARAMETER ( MPMAX = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDBR, LDC, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDBR = NMAX, $ LDC = MPMAX, LDD = MPMAX, LDDR = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*PMAX + MAX( NMAX*( NMAX + 5 ), $ PMAX*( PMAX + 2 ), 4*PMAX, 4*MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MPMAX), BR(LDBR,PMAX), $ C(LDC,NMAX), D(LDD,MPMAX), DR(LDDR,PMAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08CD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a RCFID for (A,B,C,D). CALL SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, $ D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = 1, NR WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = 1, NR ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( BR(I,J), J = 1, P ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99995 ) $ ( C(I,J), J = 1, NR ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, P ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08CD = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples/TSB08DD.f000077500000000000000000000111161201767322700165460ustar00rootroot00000000000000* SB08DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDCR, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDCR = MMAX, LDD = PMAX, LDDR = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*( NMAX + 5 ), $ MMAX*( MMAX + 2 ), $ 4*NMAX, 4*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ CR(LDCR,NMAX), D(LDD,MMAX), DR(LDDR,MMAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08DD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a RCFID for (A,B,C,D). CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, $ D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = NQ-NR+1, NQ ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, M WRITE ( NOUT, FMT = 99995 ) $ ( CR(I,J), J = NQ-NR+1, NQ ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, M ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08DD = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples/TSB08ED.f000077500000000000000000000112351201767322700165510ustar00rootroot00000000000000* SB08ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MPMAX PARAMETER ( MPMAX = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDBR, LDC, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MPMAX, $ LDD = MPMAX, LDBR = NMAX, LDDR = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*PMAX + MAX( NMAX*( NMAX + 5 ), $ 5*PMAX, 4*MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHA(2), B(LDB,MPMAX), $ BR(LDBR,PMAX), C(LDC,NMAX), D(LDD,MPMAX), $ DR(LDDR,PMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08ED * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA(1), TOL, DICO ALPHA(2) = ALPHA(1) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a LCF for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = 1, NR WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = 1, NR ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( BR(I,J), J = 1, P ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99995 ) $ ( C(I,J), J = 1, NR ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, P ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08ED = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples/TSB08FD.f000077500000000000000000000111071201767322700165500ustar00rootroot00000000000000* SB08FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDCR, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDCR = MMAX, LDD = PMAX, LDDR = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX*( NMAX + 5 ), 5*MMAX, $ 4*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHA(2), B(LDB,MMAX), C(LDC,NMAX), $ CR(LDCR,NMAX), D(LDD,MMAX), DR(LDDR,MMAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08FD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA(1), TOL, DICO ALPHA(2) = ALPHA(1) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a RCF for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = NQ-NR+1, NQ ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, M WRITE ( NOUT, FMT = 99995 ) $ ( CR(I,J), J = NQ-NR+1, NQ ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, M ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08FD = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples/TSB08MD.f000077500000000000000000000042211201767322700165560ustar00rootroot00000000000000* SB08MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DAMAX PARAMETER ( DAMAX = 10 ) INTEGER LDWORK PARAMETER ( LDWORK = 5*DAMAX+5 ) * .. Local Scalars .. DOUBLE PRECISION RES INTEGER DA, I, INFO CHARACTER*1 ACONA * .. Local Arrays .. DOUBLE PRECISION A(DAMAX+1), DWORK(LDWORK), E(DAMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB08MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) READ ( NIN, FMT = '()' ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = * ) DA, ACONA IF ( DA.LE.-1 .OR. DA.GT.DAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DA ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 ) * Compute the spectral factorization of the given polynomial. CALL SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( ACONA, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 0, DA WRITE ( NOUT, FMT = 99995 ) 2*I, A(I+1) 20 CONTINUE WRITE ( NOUT, FMT = * ) END IF WRITE ( NOUT, FMT = 99996 ) DO 40 I = 0, DA WRITE ( NOUT, FMT = 99995 ) I, E(I+1) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) RES END IF END IF * STOP * 99999 FORMAT (' SB08MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08MD = ',I2) 99997 FORMAT (' The coefficients of the polynomial B(s) are ',//' powe', $ 'r of s coefficient ') 99996 FORMAT (' The coefficients of the spectral factor E(s) are ', $ //' power of s coefficient ') 99995 FORMAT (2X,I5,9X,F9.4) 99994 FORMAT (/' RES = ',1P,E8.1) 99993 FORMAT (/' DA is out of range.',/' DA = ',I5) END slicot-5.0+20101122/examples/TSB08ND.f000077500000000000000000000042171201767322700165640ustar00rootroot00000000000000* SB08ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DAMAX PARAMETER ( DAMAX = 10 ) INTEGER LDWORK PARAMETER ( LDWORK = 5*DAMAX+5 ) * .. Local Scalars .. DOUBLE PRECISION RES INTEGER DA, I, INFO CHARACTER*1 ACONA * .. Local Arrays .. DOUBLE PRECISION A(DAMAX+1), DWORK(LDWORK), E(DAMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB08ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) READ ( NIN, FMT = '()' ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = * ) DA, ACONA IF ( DA.LE.-1 .OR. DA.GT.DAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DA ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 ) * Compute the spectral factorization of the given polynomial. CALL SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( ACONA, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 0, DA WRITE ( NOUT, FMT = 99995 ) I, A(I+1) 20 CONTINUE WRITE ( NOUT, FMT = * ) END IF WRITE ( NOUT, FMT = 99996 ) DO 40 I = 0, DA WRITE ( NOUT, FMT = 99995 ) I, E(I+1) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) RES END IF END IF * STOP * 99999 FORMAT (' SB08ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08ND = ',I2) 99997 FORMAT (' The coefficients of the polynomial B(z) are ',//' powe', $ 'r of z coefficient ') 99996 FORMAT (' The coefficients of the spectral factor E(z) are ', $ //' power of z coefficient ') 99995 FORMAT (2X,I5,9X,F9.4) 99994 FORMAT (/' RES = ',1P,E8.1) 99993 FORMAT (/' DA is out of range.',/' DA = ',I5) END slicot-5.0+20101122/examples/TSB09MD.f000077500000000000000000000051101201767322700165550ustar00rootroot00000000000000* SB09MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NCMAX, NBMAX PARAMETER ( NMAX = 20, NCMAX = 20, NBMAX = 20 ) INTEGER LDH1, LDH2, LDSS, LDSE, LDPRE PARAMETER ( LDH1 = NCMAX, LDH2 = NCMAX, LDSS = NCMAX, $ LDSE = NCMAX, LDPRE = NCMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, N, NB, NC * .. Local Arrays .. DOUBLE PRECISION H1(LDH1,NMAX*NBMAX), H2(LDH2,NMAX*NBMAX), $ PRE(LDPRE,NBMAX), SE(LDSE,NBMAX), SS(LDSS,NBMAX) * .. External Subroutines .. EXTERNAL SB09MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NC, NB, TOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF ( NB.LT.0 .OR. NB.GT.NBMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NB ELSE IF ( NC.LT.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NC ELSE READ ( NIN, FMT = * ) ( ( H1(I,J), I = 1,NC ), J = 1,N*NB ) READ ( NIN, FMT = * ) ( ( H2(I,J), I = 1,NC ), J = 1,N*NB ) * Compare the given sequences and evaluate their closeness. CALL SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, LDSE, $ PRE, LDPRE, TOL, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, NC WRITE ( NOUT, FMT = 99996 ) ( SS(I,J), J = 1,NB ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, NC WRITE ( NOUT, FMT = 99996 ) ( SE(I,J), J = 1,NB ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, NC WRITE ( NOUT, FMT = 99996 ) ( PRE(I,J), J = 1,NB ) 60 CONTINUE END IF END IF STOP * 99999 FORMAT (' SB09MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB09MD = ',I2) 99997 FORMAT (' The sum-of-squares matrix SS is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The quadratic error matrix SE is ') 99994 FORMAT (/' The percentage relative error matrix PRE is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' NB is out of range.',/' NB = ',I5) 99991 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples/TSB10DD.f000077500000000000000000000113071201767322700165410ustar00rootroot00000000000000* SB10DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK, LDX, $ LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = PMAX, $ LDDK = PMAX, LDX = NMAX, LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*MAX( MMAX, NMAX ), $ MMAX + PMAX, NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = MAX( MMAX, PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = $ MAX( ( NMAX + MPMX )*( NMAX + MPMX + 6 ), $ 13*NMAX*NMAX + MMAX*MMAX + 2*MPMX*MPMX + $ NMAX*( MMAX + MPMX ) + $ MAX( MMAX*( MMAX + 7*NMAX ), $ 2*MPMX*( 8*NMAX + MMAX + 2*MPMX ) ) $ + 6*NMAX + $ MAX( 14*NMAX + 23, 16*NMAX, $ 2*NMAX + MAX( MMAX, 2*MPMX ), $ 3*MAX( MMAX, 2*MPMX ) ) ) ) * .. Local Scalars .. DOUBLE PRECISION GAMMA, TOL INTEGER I, INFO, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,PMAX), X(LDX,NMAX), $ Z(LDZ,NMAX), DWORK(LDWORK), RCOND( 8 ) * .. External Subroutines .. EXTERNAL SB10DD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) GAMMA, TOL CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 8 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10DD =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) 99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples/TSB10ED.f000077500000000000000000000105531201767322700165440ustar00rootroot00000000000000* SB10ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = PMAX, $ LDDK = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*MMAX, PMAX, 2*NMAX, $ NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = MAX( MMAX, PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MPMX*( 3*MPMX + 2*NMAX ) + $ MAX( ( NMAX + MPMX )*( NMAX + MPMX + 6 ), $ MPMX*( MPMX + MAX( NMAX, MPMX, 5 ) + 1 ), $ 2*NMAX*NMAX + MAX( 14*NMAX*NMAX + 6*NMAX + $ MAX( 14*NMAX + 23, 16*NMAX ), $ MPMX*( NMAX + MPMX + MAX( MPMX, 3 ) ) ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,MMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,MMAX), DWORK(LDWORK), $ RCOND( 8 ) * .. External Subroutines .. EXTERNAL SB10ED * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) TOL CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 7 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10ED =',I2) 99997 FORMAT (' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples/TSB10FD.f000077500000000000000000000141361201767322700165460ustar00rootroot00000000000000* SB10FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, N2MAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10, N2MAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK, $ LDAC, LDBC, LDCC, LDDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = MMAX, $ LDDK = MMAX, LDAC = 2*NMAX, LDBC = 2*NMAX, $ LDCC = PMAX, LDDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*MAX( NMAX, MMAX, PMAX ), $ NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = MAX( MMAX, PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MPMX*( 3*MPMX + 2*NMAX ) + $ MAX( ( NMAX + MPMX )*( NMAX + MPMX + 6 ), $ MPMX*( MPMX + MAX( NMAX, MPMX, 5 ) + 1 ), $ 2*NMAX*( NMAX + 2*MPMX ) + $ MAX( 4*MPMX*MPMX + MAX( 2*MPMX, 3*NMAX*NMAX + $ MAX( 2*NMAX*MPMX, 10*NMAX*NMAX+12*NMAX+5 ) ), $ MPMX*( 3*NMAX + 3*MPMX + $ MAX( 2*NMAX, 4*MPMX + $ MAX( NMAX, MPMX ) ) ) ) ) ) * .. Local Scalars .. INTEGER SDIM LOGICAL SELECT DOUBLE PRECISION GAMMA, TOL INTEGER I, INFO1, INFO2, INFO3, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(N2MAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDAK,NMAX), AC(LDAC,N2MAX), $ B(LDB,MMAX), BK(LDBK,PMAX), BC(LDBC,MMAX), $ C(LDC,NMAX), CK(LDCK,NMAX), CC(LDCC,N2MAX), $ D(LDD,MMAX), DK(LDDK,PMAX), DC(LDDC,MMAX), $ DWORK(LDWORK), RCOND( 4 ) * .. External Subroutines .. EXTERNAL SB10FD, SB10LD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99987 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99986 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99985 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99984 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99983 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) GAMMA, TOL * Compute the suboptimal controller CALL 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, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99989 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99989 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99989 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99989 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99992 ) WRITE( NOUT, FMT = 99988 ) ( RCOND(I), I = 1, 4 ) * Compute the closed-loop matrices 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 ) * IF ( INFO2.EQ.0 ) THEN * Compute the closed-loop poles CALL DGEES( 'N','N', SELECT, 2*N, AC, LDAC, SDIM, $ DWORK(1), DWORK(2*N+1), DWORK, 2*N, $ DWORK(4*N+1), LDWORK-4*N, BWORK, INFO3) * IF( INFO3.EQ.0 ) THEN WRITE( NOUT, FMT = 99991 ) WRITE( NOUT, FMT = 99988 ) (DWORK(I), I =1, 2*N) WRITE( NOUT, FMT = 99990 ) WRITE( NOUT, FMT = 99988 ) (DWORK(2*N+I), I =1, 2*N) ELSE WRITE( NOUT, FMT = 99996 ) INFO3 END IF ELSE WRITE( NOUT, FMT = 99997 ) INFO2 END IF ELSE WRITE( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB10FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10FD =',I2) 99997 FORMAT (/' INFO on exit from SB10LD =',I2) 99996 FORMAT (' The controller state matrix AK is'/) 99995 FORMAT (/' The controller input matrix BK is'/) 99994 FORMAT (/' The controller output matrix CK is'/) 99993 FORMAT (/' The controller matrix DK is'/) 99992 FORMAT (/' The estimated condition numbers are'/) 99991 FORMAT (/' The real parts of the closed-loop system poles are'/) 99990 FORMAT (/' The imaginary parts of the closed-loop system', $ ' poles are'/) 99989 FORMAT (10(1X,F8.4)) 99988 FORMAT ( 5(1X,D12.5)) 99987 FORMAT (/' N is out of range.',/' N = ',I5) 99986 FORMAT (/' M is out of range.',/' M = ',I5) 99985 FORMAT (/' N is out of range.',/' N = ',I5) 99984 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99983 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples/TSB10HD.f000077500000000000000000000102361201767322700165450ustar00rootroot00000000000000* SB10HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = PMAX, $ LDDK = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*NMAX, NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = MAX( MMAX, PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MPMX*( 2*NMAX + 3*MPMX ) + $ MAX( MPMX*( MPMX + MAX( NMAX, 5 ) + 1 ), $ NMAX*( 14*NMAX + 12 + 2*MPMX ) + 5 ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,MMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,MMAX), DWORK(LDWORK), $ RCOND( 4 ) * .. External Subroutines .. EXTERNAL SB10HD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) TOL * Compute the optimal H2 controller CALL 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 ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 4 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10HD =',I2) 99997 FORMAT (' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (6(1X,F10.4)) 99991 FORMAT (5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples/TSB10ID.f000077500000000000000000000074671201767322700165620ustar00rootroot00000000000000* SB10ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK PARAMETER ( LDA = NMAX, LDAK = NMAX, LDB = NMAX, $ LDBK = NMAX, LDC = PMAX, LDCK = MMAX, $ LDD = PMAX, LDDK = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX( 2*NMAX, NMAX*NMAX, MMAX, PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX*NMAX + MMAX*MMAX + PMAX*PMAX + $ 2*MMAX*NMAX + NMAX*PMAX + 4*NMAX + $ MAX( 10*NMAX*NMAX + 8*NMAX + 5, $ NMAX*PMAX + 2*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION FACTOR INTEGER I, INFO, J, M, N, NK, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,PMAX), DWORK(LDWORK), $ RCOND( 2 ) * .. External Subroutines .. EXTERNAL SB10ID * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) FACTOR CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, NK WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,NK ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NK WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,NK ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 2 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10ID =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F9.4)) 99991 FORMAT ( 2(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples/TSB10KD.f000077500000000000000000000075331201767322700165560ustar00rootroot00000000000000* SB10KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK PARAMETER ( LDA = NMAX, LDAK = NMAX, LDB = NMAX, $ LDBK = NMAX, LDC = PMAX, LDCK = MMAX, $ LDDK = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAX( NMAX, MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 15*NMAX*NMAX + 6*NMAX + $ MAX( 14*NMAX + 23, 16*NMAX, $ 2*NMAX+PMAX+MMAX, $ 3*(PMAX+MMAX) ) + $ MAX( NMAX*NMAX, $ 11*NMAX*PMAX + 2*MMAX*MMAX + $ 8*PMAX*PMAX + 8*MMAX*NMAX + $ 4*MMAX*PMAX + PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION FACTOR INTEGER I, INFO, J, M, N, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ DK(LDDK,PMAX), DWORK(LDWORK), RCOND(4) * .. External Subroutines .. EXTERNAL SB10KD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) FACTOR CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 4 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10KD =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples/TSB10ZD.f000077500000000000000000000076131201767322700165740ustar00rootroot00000000000000* SB10ZD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 10, NMAX = 10, PMAX = 10 ) INTEGER LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK PARAMETER ( LDA = NMAX, LDAK = NMAX, LDB = NMAX, $ LDBK = NMAX, LDC = PMAX, LDCK = MMAX, $ LDD = PMAX, LDDK = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAX( NMAX, MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 16*NMAX*NMAX + 5*MMAX*MMAX + $ 7*PMAX*PMAX + 6*MMAX*NMAX + $ 7*MMAX*PMAX + 7*NMAX*PMAX + 6*NMAX + $ 2*( MMAX + PMAX ) + $ MAX( 14*NMAX + 23, 16*NMAX, $ 2*MMAX - 1, 2*PMAX - 1 ) ) * .. Local Scalars .. DOUBLE PRECISION FACTOR, TOL INTEGER I, INFO, J, M, N, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDAK,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,PMAX), DWORK(LDWORK), $ RCOND( 6 ) * .. External Subroutines .. EXTERNAL SB10ZD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) FACTOR, TOL CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1,6 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10ZD =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples/TSB16AD.f000077500000000000000000000130451201767322700165450ustar00rootroot00000000000000* SB16AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NCMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, $ NCMAX = 20 ) INTEGER MPMAX, NNCMAX PARAMETER ( MPMAX = MMAX + PMAX, NNCMAX = NMAX + NCMAX ) INTEGER LDA, LDB, LDC, LDD, LDAC, LDBC, LDCC, LDDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDAC = NCMAX, LDBC = NCMAX, $ LDCC = PMAX, LDDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAX( NCMAX, MPMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NCMAX*NCMAX + $ NNCMAX*( NNCMAX + 2*MPMAX ) + $ MAX( NNCMAX*( NNCMAX + $ MAX( NNCMAX, MMAX, PMAX ) + 7 ), $ MPMAX*( MPMAX + 4 ) ) ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NCR, NCS, NC, P CHARACTER*1 DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSVC(NMAX), $ AC(LDAC,NCMAX), BC(LDBC,PMAX), CC(LDCC,NMAX), $ DC(LDDC,PMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB16AD * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NC, NCR, ALPHA, TOL1, TOL2, DICO, $ JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF( P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( NC.LT.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NC ELSE IF( NC.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AC(I,J), J = 1,NC ), I = 1,NC ) READ ( NIN, FMT = * ) $ ( ( BC(I,J), J = 1,P ), I = 1, NC ) READ ( NIN, FMT = * ) $ ( ( CC(I,J), J = 1,NC ), I = 1,M ) END IF READ ( NIN, FMT = * ) $ ( ( DC(I,J), J = 1,P ), I = 1,M ) END IF * Find a reduced ssr for (AC,BC,CC,DC). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99984 ) IWARN WRITE ( NOUT, FMT = 99997 ) NCR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSVC(J), J = 1, NCS ) IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( AC(I,J), J = 1,NCR ) 20 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( BC(I,J), J = 1,P ) 40 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( CC(I,J), J = 1,NCR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( DC(I,J), J = 1,P ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB16AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB16AD = ',I2) 99997 FORMAT (/' The order of reduced controller = ',I2) 99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced controller input/state matrix Bc is ') 99992 FORMAT (/' The reduced controller state/output matrix Cc is ') 99991 FORMAT (/' The reduced controller input/output matrix Dc is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NC is out of range.',/' NC = ',I5) 99984 FORMAT (' IWARN on exit from SB16AD = ',I2) END slicot-5.0+20101122/examples/TSB16BD.f000077500000000000000000000110121201767322700165360ustar00rootroot00000000000000* SB16BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDDC, LDF, LDG PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDDC = MMAX, LDF = MMAX, LDG = NMAX $ ) INTEGER LDWORK, LIWORK, MAXMP, MPMAX PARAMETER ( LIWORK = 2*NMAX, MAXMP = MAX( MMAX, PMAX ), $ MPMAX = MMAX + PMAX ) PARAMETER ( LDWORK = ( NMAX + MAXMP )*MPMAX + $ MAX ( NMAX*( 2*NMAX + $ MAX( NMAX, MPMAX ) + 5 ) $ + ( NMAX*( NMAX + 1 ) )/2, $ 4*MAXMP ) ) CHARACTER DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL INTEGER I, INFO, IWARN, J, M, N, NCR, P DOUBLE PRECISION TOL1, TOL2 * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DC(LDDC,PMAX), DWORK(LDWORK), $ F(LDF,NMAX), G(LDG,PMAX), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB16BD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NCR, TOL1, TOL2, $ DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,P ), I = 1,N ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCR ) 20 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,P ) 40 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,NCR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( DC(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB16BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB16BD = ',I2) 99997 FORMAT (' The order of reduced controller = ',I2) 99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced controller input/state matrix Bc is ') 99992 FORMAT (/' The reduced controller state/output matrix Cc is ') 99991 FORMAT (/' The reduced controller input/output matrix Dc is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of extended system are:') END slicot-5.0+20101122/examples/TSB16CD.f000077500000000000000000000101501201767322700165410ustar00rootroot00000000000000* SB16CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDDC, LDF, LDG PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDDC = MMAX, LDF = MMAX, LDG = NMAX ) INTEGER LDWORK, LIWORK, MPMAX PARAMETER ( LIWORK = 2*NMAX, MPMAX = MAX( MMAX, PMAX ) ) PARAMETER ( LDWORK = 2*NMAX*NMAX + $ MAX( 2*NMAX*NMAX + 5*NMAX, $ NMAX*( NMAX + MAX( NMAX, MPMAX ) $ + MIN( NMAX, MPMAX ) + 6 ) ) $ ) CHARACTER DICO, JOBCF, JOBD, JOBMR, ORDSEL INTEGER I, INFO, IWARN, J, M, N, NCR, P DOUBLE PRECISION TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), $ F(LDF,NMAX), G(LDG,PMAX), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB16CD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NCR, TOL, $ DICO, JOBD, JOBMR, JOBCF, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,P ), I = 1,N ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCR ) 20 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,P ) 40 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,NCR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB16CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB16CD = ',I2) 99997 FORMAT (' The order of reduced controller = ',I2) 99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced controller input/state matrix Bc is ') 99992 FORMAT (/' The reduced controller state/output matrix Cc is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The frequency-weighted Hankel singular values are:') END slicot-5.0+20101122/examples/TSG02AD.f000077500000000000000000000113461201767322700165470ustar00rootroot00000000000000* SG02AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER NMAX2M, NMAX2, NMMAX PARAMETER ( NMAX2M = 2*NMAX+MMAX, NMAX2 = 2*NMAX, $ NMMAX = MAX(NMAX,MMAX) ) INTEGER LDA, LDB, LDE, LDL, LDQ, LDR, LDS, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDE = NMAX, LDL = NMAX, $ LDQ = MAX(NMAX,PMAX), LDR = MAX(MMAX,PMAX), $ LDS = NMAX2M, LDT = NMAX2M, LDU = NMAX2, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MAX(MMAX,NMAX2) ) INTEGER LDWORK PARAMETER ( LDWORK = MAX(14*NMAX+23,16*NMAX,2*NMAX+MMAX, $ 3*MMAX) ) INTEGER LBWORK PARAMETER ( LBWORK = NMAX2 ) * .. Local Scalars .. DOUBLE PRECISION RCONDU, TOL INTEGER I, INFO, IWARN, J, M, N, P CHARACTER*1 ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO LOGICAL LJOBB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFAI(NMAX2), ALFAR(NMAX2), $ B(LDB,NMMAX), BETA(NMAX2), DWORK(LDWORK), $ E(LDE,NMAX), L(LDL,MMAX), Q(LDQ,NMAX), $ R(LDR,MMAX), S(LDS,NMAX2M), T(LDT,NMAX2), $ U(LDU,NMAX2), X(LDX,NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LBWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SG02AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBB, FACT, UPLO, JOBL, $ SCAL, SORT, ACC IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE LJOBB = LSAME( JOBB, 'B' ) IF ( LJOBB ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) END IF IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99993 ) P ELSE IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'D' ) ) THEN READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,N ) ELSE READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,P ) END IF IF ( LJOBB ) THEN IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'C' ) ) THEN READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,M ) ELSE READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,P ) END IF IF ( LSAME( JOBL, 'N' ) ) $ READ ( NIN, FMT = * ) $ ( ( L(I,J), J = 1,M ), I = 1,N ) END IF * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SG02AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SG02AD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TSG03AD.f000077500000000000000000000057721201767322700165560ustar00rootroot00000000000000* SG03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDE, LDQ, LDX, LDZ PARAMETER ( LDA = NMAX, LDE = NMAX, LDQ = NMAX, $ LDX = NMAX, LDZ = NMAX ) INTEGER LIWORK, LDWORK PARAMETER ( LIWORK = NMAX**2, $ LDWORK = MAX( 2*NMAX**2, 4*NMAX ) ) * .. Local Scalars .. CHARACTER*1 DICO, FACT, JOB, TRANS, UPLO DOUBLE PRECISION FERR, SCALE, SEP INTEGER I, INFO, J, N * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX), $ BETA(NMAX), DWORK(LDWORK), E(LDE,NMAX), $ Q(LDQ,NMAX), X(LDX,NMAX), Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SG03AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, DICO, FACT, TRANS, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( LSAME ( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N ) END IF IF ( .NOT.LSAME ( JOB, 'S' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X and the scalar SEP. CALL 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 ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME ( JOB, 'B' ) .OR. LSAME ( JOB, 'S' ) ) THEN WRITE ( NOUT, FMT = 99997 ) SEP WRITE ( NOUT, FMT = 99996 ) FERR END IF IF ( LSAME ( JOB, 'B' ) .OR. LSAME ( JOB, 'X' ) ) THEN WRITE ( NOUT, FMT = 99995 ) SCALE DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SG03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SG03AD = ',I2) 99997 FORMAT (' SEP = ',D8.2) 99996 FORMAT (' FERR = ',D8.2) 99995 FORMAT (' SCALE = ',D8.2,//' The solution matrix X is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples/TSG03BD.f000077500000000000000000000054371201767322700165550ustar00rootroot00000000000000* SG03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDB, LDE, LDQ, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDE = NMAX, $ LDQ = NMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 4*NMAX, 6*NMAX-6 ) ) * .. Local Scalars .. CHARACTER*1 DICO, FACT, TRANS DOUBLE PRECISION SCALE INTEGER I, INFO, J, N, M * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX), $ B(LDB,NMAX), BETA(NMAX), DWORK(LDWORK), $ E(LDE,NMAX), Q(LDQ,NMAX), Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SG03BD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE IF ( M.LT.0 .OR. M.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N ) END IF IF ( LSAME( FACT, 'T' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M ) END IF * Find the Cholesky factor U of the solution matrix. CALL SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, LDQ, $ Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, BETA, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) SCALE DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' SG03BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SG03BD = ',I2) 99997 FORMAT (' SCALE = ',F8.4,//' The Cholesky factor U of the solution $ matrix is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TTB01ID.f000077500000000000000000000051341201767322700165500ustar00rootroot00000000000000* TB01ID EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, INFO, J, M, N, P DOUBLE PRECISION MAXRED * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ SCALE(NMAX) * .. External Subroutines .. EXTERNAL TB01ID, UD01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOB, MAXRED IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Balance system matrix S. CALL TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL UD01MD( N, N, 5, NOUT, A, LDA, $ 'The balanced matrix A', INFO ) IF ( M.GT.0 ) $ CALL UD01MD( N, M, 5, NOUT, B, LDB, $ 'The balanced matrix B', INFO ) IF ( P.GT.0 ) $ CALL UD01MD( P, N, 5, NOUT, C, LDC, $ 'The balanced matrix C', INFO ) CALL UD01MD( 1, N, 5, NOUT, SCALE, 1, $ 'The scaling vector SCALE', INFO ) WRITE ( NOUT, FMT = 99994 ) MAXRED END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01ID = ',I2) 99994 FORMAT (/' MAXRED is ',E13.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB01IZ.f000077500000000000000000000051431201767322700165760ustar00rootroot00000000000000* TB01IZ EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, INFO, J, M, N, P DOUBLE PRECISION MAXRED * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX) DOUBLE PRECISION SCALE(NMAX) * .. External Subroutines .. EXTERNAL TB01IZ, UD01MD, UD01MZ * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOB, MAXRED IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Balance system matrix S. CALL TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL UD01MZ( N, N, 3, NOUT, A, LDA, $ 'The balanced matrix A', INFO ) IF ( M.GT.0 ) $ CALL UD01MZ( N, M, 3, NOUT, B, LDB, $ 'The balanced matrix B', INFO ) IF ( P.GT.0 ) $ CALL UD01MZ( P, N, 3, NOUT, C, LDC, $ 'The balanced matrix C', INFO ) CALL UD01MD( 1, N, 5, NOUT, SCALE, 1, $ 'The scaling vector SCALE', INFO ) WRITE ( NOUT, FMT = 99994 ) MAXRED END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01IZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01IZ = ',I2) 99994 FORMAT (/' MAXRED is ',E13.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB01KD.f000077500000000000000000000071431201767322700165540ustar00rootroot00000000000000* TB01KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDU PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 DICO, JOBA, STDOM INTEGER I, INFO, J, M, N, NDIM, P DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL TB01KD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, STDOM, JOBA IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed ssr for (A,B,C). CALL TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, $ B, LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99987 ) NDIM WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01KD = ',I2) 99997 FORMAT (/' The eigenvalues of state dynamics matrix A are ') 99996 FORMAT (/' The transformed state dynamics matrix inv(U)*A*U is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT ( ' (',F8.4,', ',F8.4,' )') 99993 FORMAT (/' The transformed input/state matrix inv(U)*B is ') 99992 FORMAT (/' The transformed state/output matrix C*U is ') 99991 FORMAT (/' The similarity transformation matrix U is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (' The number of eigenvalues in the domain of interest =', $ I5 ) END slicot-5.0+20101122/examples/TTB01LD.f000077500000000000000000000071361201767322700165570ustar00rootroot00000000000000* TB01LD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDU PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 DICO, JOBA, STDOM INTEGER I, INFO, J, M, N, NDIM, P DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL TB01LD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, STDOM, JOBA IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed ssr for (A,B,C). CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, $ A, LDA, B, LDB, C, LDC, NDIM, U, LDU, $ WR, WI, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99987 ) NDIM WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01LD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01LD = ',I2) 99997 FORMAT (/' The eigenvalues of state dynamics matrix A are ') 99996 FORMAT (/' The transformed state dynamics matrix U''*A*U is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT ( ' (',F8.4,', ',F8.4,' )') 99993 FORMAT (/' The transformed input/state matrix U''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*U is ') 99991 FORMAT (/' The similarity transformation matrix U is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The number of eigenvalues in the domain of interest =', $ I5 ) END slicot-5.0+20101122/examples/TTB01MD.f000077500000000000000000000053731201767322700165610ustar00rootroot00000000000000* TB01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDU, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDU = NMAX, $ LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N CHARACTER*1 JOBU, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), U(LDU,NMAX), $ DWORK(LDWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, JOBU, UPLO IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( LSAME( JOBU, 'U' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) * Reduce the pair (B,A) to controller Hessenberg form. CALL TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU, $ DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 80 CONTINUE IF ( LSAME( JOBU, 'I' ).OR.LSAME( JOBU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,N ) 100 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01MD = ',I2) 99997 FORMAT (' The transformed state transition matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed input matrix is ') 99994 FORMAT (/' The transformation matrix that reduces (B,A) to contr', $ 'oller Hessenberg form is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TTB01ND.f000077500000000000000000000053701201767322700165570ustar00rootroot00000000000000* TB01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA, LDC, LDU, LDWORK PARAMETER ( LDA = NMAX, LDC = PMAX, LDU = NMAX, $ LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N, P CHARACTER*1 JOBU, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), U(LDU,NMAX), $ DWORK(LDWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, JOBU, UPLO IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( JOBU, 'U' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) * Reduce the pair (A,C) to observer Hessenberg form. CALL TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU, $ DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 80 CONTINUE IF ( LSAME( JOBU, 'I' ).OR.LSAME( JOBU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,N ) 100 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01ND = ',I2) 99997 FORMAT (' The transformed state transition matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed output matrix is ') 99994 FORMAT (/' The transformation matrix that reduces (A,C) to obser', $ 'ver Hessenberg form is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB01PD.f000077500000000000000000000064521201767322700165630ustar00rootroot00000000000000* TB01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX+MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX+MAX( NMAX, 3*MAXMP ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NR, P CHARACTER JOB, EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL TB01PD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOB, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a minimal ssr for (A,B,C). CALL TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, $ NR, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01PD = ',I2) 99997 FORMAT (' The order of the minimal realization = ',I2) 99996 FORMAT (/' The transformed state dynamics matrix of a minimal re', $ 'alization is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The transformed input/state matrix of a minimal reali', $ 'zation is ') 99992 FORMAT (/' The transformed state/output matrix of a minimal real', $ 'ization is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB01TD.f000077500000000000000000000062621201767322700165660ustar00rootroot00000000000000* TB01TD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) * .. Local Scalars .. INTEGER I, INFO, IGH, J, LOW, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(NMAX), SCIN(MMAX), $ SCOUT(PMAX), SCSTAT(NMAX) * .. External Subroutines .. EXTERNAL TB01TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99989 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Balance the state-space representation (A,B,C,D). CALL TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ LOW, IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) LOW, IGH WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01TD = ',I2) 99997 FORMAT (' LOW = ',I2,' IGH = ',I2,/) 99996 FORMAT (' The balanced state dynamics matrix A is ') 99995 FORMAT (20(1X,F9.4)) 99994 FORMAT (/' The balanced input/state matrix B is ') 99993 FORMAT (/' The balanced state/output matrix C is ') 99992 FORMAT (/' The scaled direct transmission matrix D is ') 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB01UD.f000077500000000000000000000105011201767322700165560ustar00rootroot00000000000000* TB01UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX, 3*MMAX, PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, INDCON, J, M, N, NCONT, P CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), TAU(NMAX), Z(LDZ,NMAX) INTEGER IWORK(LIWORK), NBLK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01UD, DORGQR * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a controllable ssr for the given system. CALL TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, $ NCONT, INDCON, NBLK, Z, LDZ, TAU, TOL, $ IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) ( NBLK(I), I = 1,INDCON ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NCONT ) 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) INDCON IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, $ INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01UD = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2) 99996 FORMAT (/' The transformed state dynamics matrix of a controllab', $ 'le realization is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' and the dimensions of its diagonal blocks are ', $ /20(1X,I2)) 99993 FORMAT (/' The transformed input/state matrix B of a controllabl', $ 'e realization is ') 99992 FORMAT (/' The controllability index of the transformed system r', $ 'epresentation = ',I2) 99991 FORMAT (/' The similarity transformation matrix Z is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The transformed output/state matrix C of a controlla', $ 'ble realization is ') END slicot-5.0+20101122/examples/TTB01WD.f000077500000000000000000000064541201767322700165740ustar00rootroot00000000000000* TB01WD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDU PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL TB01WD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed ssr for (A,B,C). CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, $ WR, WI, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01WD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01WD = ',I2) 99997 FORMAT (' The eigenvalues of state dynamics matrix A are ') 99996 FORMAT (/' The transformed state dynamics matrix U''*A*U is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT ( ' (',F8.4,', ',F8.4,' )') 99993 FORMAT (/' The transformed input/state matrix U''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*U is ') 99991 FORMAT (/' The similarity transformation matrix U is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB01ZD.f000077500000000000000000000064561201767322700166010ustar00rootroot00000000000000* TB01ZD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA, LDC, LDZ PARAMETER ( LDA = NMAX, LDC = PMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX, PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, N, NCONT, P CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(NMAX), C(LDC,NMAX), DWORK(LDWORK), $ TAU(NMAX), Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01ZD, DORGQR * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( B(I), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a controllable realization for the given system. CALL TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ, $ TAU, TOL, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT ) WRITE ( NOUT, FMT = 99991 ) DO 30 I = 1, P WRITE ( NOUT, FMT = 99994 ) ( C(I,J), J = 1,NCONT ) 30 CONTINUE IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, $ INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01ZD = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2,//' The state dynamics matrix A of a controlla', $ 'ble realization is ') 99996 FORMAT (/' The input/state vector B of a controllable realizatio', $ 'n is ',/(1X,F8.4)) 99995 FORMAT (/' The similarity transformation matrix Z is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' The output/state matrix C of a controllable realizati', $ 'on is ') END slicot-5.0+20101122/examples/TTB03AD.f000077500000000000000000000146751201767322700165540ustar00rootroot00000000000000* TB03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, LDQCO1, $ LDQCO2, LDVCO1, LDVCO2, NMAXP1 PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP, LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP, LDVCO1 = MAXMP, $ LDVCO2 = NMAX, NMAXP1 = NMAX+1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX + MAX( NMAX, 3*MAXMP ), $ MAXMP*( MAXMP + 2 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INDBLK, INFO, J, K, KPCOEF, M, N, NR, P, PORM, $ PORP CHARACTER*1 EQUIL, LERI LOGICAL LLERI * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DWORK(LDWORK), $ PCOEFF(LDPCO1,LDPCO2,NMAXP1), $ QCOEFF(LDQCO1,LDQCO2,NMAXP1), $ VCOEFF(LDVCO1,LDVCO2,NMAXP1) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB03AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, LERI, EQUIL LLERI = LSAME( LERI, 'L' ) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99987 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99986 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99985 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the right pmr which is equivalent to the ssr * C*inv(sI-A)*B+D. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 20 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 20 CONTINUE INDBLK = 0 DO 40 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) ( IWORK(I), I = 1,INDBLK ) WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE IF ( LLERI ) THEN PORM = P PORP = M WRITE ( NOUT, FMT = 99992 ) INDBLK ELSE PORM = M PORP = P WRITE ( NOUT, FMT = 99991 ) INDBLK END IF WRITE ( NOUT, FMT = 99990 ) ( INDEX(I), I = 1,PORM ) KPCOEF = 0 DO 100 I = 1, PORM KPCOEF = MAX( KPCOEF, INDEX(I) ) 100 CONTINUE KPCOEF = KPCOEF + 1 WRITE ( NOUT, FMT = 99989 ) DO 140 I = 1, PORM DO 120 J = 1, PORM WRITE ( NOUT, FMT = 99996 ) $ ( PCOEFF(I,J,K), K = 1,KPCOEF ) 120 CONTINUE 140 CONTINUE WRITE ( NOUT, FMT = 99988 ) IF ( LLERI ) THEN DO 180 I = 1, PORM DO 160 J = 1, PORP WRITE ( NOUT, FMT = 99996 ) $ ( QCOEFF(I,J,K), K = 1,KPCOEF ) 160 CONTINUE 180 CONTINUE ELSE DO 220 I = 1, PORP DO 200 J = 1, PORM WRITE ( NOUT, FMT = 99996 ) $ ( QCOEFF(I,J,K), K = 1,KPCOEF ) 200 CONTINUE 220 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TB03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB03AD = ',I2) 99997 FORMAT (' The order of the minimal state-space representation = ', $ I2,//' The transformed state dynamics matrix of a minimal', $ ' realization is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' and the dimensions of its diagonal blocks are ',/20(I5) $ ) 99994 FORMAT (/' The transformed input/state matrix of a minimal reali', $ 'zation is ') 99993 FORMAT (/' The transformed state/output matrix of a minimal real', $ 'ization is ') 99992 FORMAT (/' The observability index of the transformed minimal sy', $ 'stem representation = ',I2) 99991 FORMAT (/' The controllability index of the transformed minimal ', $ 'system representation = ',I2) 99990 FORMAT (/' INDEX is ',/20(I5)) 99989 FORMAT (/' The denominator matrix P(s) is ') 99988 FORMAT (/' The numerator matrix Q(s) is ') 99987 FORMAT (/' N is out of range.',/' N = ',I5) 99986 FORMAT (/' M is out of range.',/' M = ',I5) 99985 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB04AD.f000077500000000000000000000141301201767322700165370ustar00rootroot00000000000000* TB04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, LDUCO2, $ NMAXP1 PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP, LDDCOE = MAXMP, LDUCO1 = MAXMP, $ LDUCO2 = MAXMP, NMAXP1 = NMAX+1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX + 1 ) + $ MAX( NMAX*MAXMP + 2*NMAX + $ MAX( NMAX, MAXMP ), 3*MAXMP ) ) * .. Local Scalars .. DOUBLE PRECISION TOL1, TOL2 INTEGER I, II, IJ, INDBLK, INFO, J, JJ, KDCOEF, M, N, $ NR, P, PORM, PORP CHARACTER*1 ROWCOL CHARACTER*132 ULINE LOGICAL LROWCO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DCOEFF(LDDCOE,NMAXP1), $ DWORK(LDWORK), UCOEFF(LDUCO1,LDUCO2,NMAXP1) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB04AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL1, TOL2, ROWCOL LROWCO = LSAME( ROWCOL, 'R' ) ULINE(1:20) = ' ' DO 20 I = 21, 132 ULINE(I:I) = '-' 20 CONTINUE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99986 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99985 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99984 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the transfer matrix T(s) of (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 40 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE INDBLK = 0 DO 100 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 100 CONTINUE IF ( LROWCO ) THEN PORM = P PORP = M WRITE ( NOUT, FMT = 99993 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) ELSE PORM = M PORP = P WRITE ( NOUT, FMT = 99992 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) END IF WRITE ( NOUT, FMT = 99991 ) ( INDEX(I), I = 1,PORM ) WRITE ( NOUT, FMT = 99990 ) KDCOEF = 0 DO 120 I = 1, PORM KDCOEF = MAX( KDCOEF, INDEX(I) ) 120 CONTINUE KDCOEF = KDCOEF + 1 DO 160 II = 1, PORM DO 140 JJ = 1, PORP WRITE ( NOUT, FMT = 99989 ) II, JJ, $ ( UCOEFF(II,JJ,IJ), IJ = 1,KDCOEF ) WRITE ( NOUT, FMT = 99988 ) ULINE(1:7*KDCOEF+21) WRITE ( NOUT, FMT = 99987 ) $ ( DCOEFF(II,IJ), IJ = 1,KDCOEF ) 140 CONTINUE 160 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB04AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB04AD = ',I2) 99997 FORMAT (' The order of the transformed state-space representatio', $ 'n = ',I2,//' The transformed state dynamics matrix A is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed input/state matrix B is ') 99994 FORMAT (/' The transformed state/output matrix C is ') 99993 FORMAT (/' The controllability index of the transformed state-sp', $ 'ace representation = ',I2,//' The dimensions of the diag', $ 'onal blocks of the transformed A are ',/20(I5)) 99992 FORMAT (/' The observability index of the transformed state-spac', $ 'e representation = ',I2,//' The dimensions of the diagon', $ 'al blocks of the transformed A are ',/20(I5)) 99991 FORMAT (/' The degrees of the denominator polynomials are',/20(I5) $ ) 99990 FORMAT (/' The coefficients of polynomials in the transfer matri', $ 'x T(s) are ') 99989 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2)) 99988 FORMAT (1X,A) 99987 FORMAT (20X,20(1X,F6.2)) 99986 FORMAT (/' N is out of range.',/' N = ',I5) 99985 FORMAT (/' M is out of range.',/' M = ',I5) 99984 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB04BD.f000077500000000000000000000104341201767322700165430ustar00rootroot00000000000000* TB04BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, MDMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, $ MDMAX = NMAX + 1 ) INTEGER PMNMAX PARAMETER ( PMNMAX = PMAX*MMAX*MDMAX ) INTEGER LDA, LDB, LDC, LDD, LDIGD, LDIGN PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDIGD = PMAX, LDIGN = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX + PMAX ) + $ MAX( NMAX + MAX( NMAX, PMAX ), $ NMAX*( 2*NMAX + 5 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, IJ, INFO, J, K, M, MD, N, P CHARACTER*1 JOBD, ORDER, EQUIL CHARACTER*132 ULINE * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), GD(PMNMAX), $ GN(PMNMAX) INTEGER IGD(LDIGD,MMAX), IGN(LDIGN,MMAX), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB04BD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBD, ORDER, EQUIL MD = N + 1 ULINE(1:20) = ' ' DO 20 I = 21, 132 ULINE(I:I) = '-' 20 CONTINUE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99989 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the transfer matrix T(s) of (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( ORDER, 'I' ) ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99996 ) END IF WRITE ( NOUT, FMT = 99995 ) DO 60 J = 1, M DO 40 I = 1, P IJ = ( (J-1)*P + I-1 )*MD + 1 WRITE ( NOUT, FMT = 99994 ) I, J, $ ( GN(K), K = IJ,IJ+IGN(I,J) ) WRITE ( NOUT, FMT = 99993 ) $ ULINE(1:7*(IGD(I,J)+1)+21) WRITE ( NOUT, FMT = 99992 ) $ ( GD(K), K = IJ,IJ+IGD(I,J) ) 40 CONTINUE 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB04BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB04BD = ',I2) 99997 FORMAT (/' The polynomial coefficients appear in increasing', $ ' order'/' of the powers of the indeterminate') 99996 FORMAT (/' The polynomial coefficients appear in decreasing', $ ' order'/' of the powers of the indeterminate') 99995 FORMAT (/' The coefficients of polynomials in the transfer matri', $ 'x T(s) are ') 99994 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2)) 99993 FORMAT (1X,A) 99992 FORMAT (20X,20(1X,F6.2)) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB04CD.f000077500000000000000000000104441201767322700165450ustar00rootroot00000000000000* TB04CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NPZMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, $ NPZMAX = NMAX ) INTEGER PMNMAX PARAMETER ( PMNMAX = PMAX*MMAX*NPZMAX ) INTEGER LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDGAIN = PMAX, LDNP = PMAX, $ LDNZ = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX + PMAX ) + $ MAX( NMAX + MAX( NMAX, PMAX ), $ NMAX*( 2*NMAX + 3 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, IJ, INFO, J, K, M, N, NPZ, P CHARACTER*1 JOBD, EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), GAINS(LDGAIN,MMAX), $ POLESI(PMNMAX), POLESR(PMNMAX), ZEROSI(PMNMAX), $ ZEROSR(PMNMAX) INTEGER IWORK(LIWORK), NP(LDNP,MMAX), NZ(LDNZ,MMAX) * .. External Subroutines .. EXTERNAL TB04CD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBD, EQUIL NPZ = N IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the transfer matrix T(s) of (A,B,C,D) in the * pole-zero-gain form. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 60 J = 1, M DO 40 I = 1, P IJ = ( (J-1)*P + I-1 )*NPZ + 1 IF ( NZ(I,J).EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) I, J ELSE WRITE ( NOUT, FMT = 99995 ) I, J, $ ( ZEROSR(K), ZEROSI(K), $ K = IJ,IJ+NZ(I,J)-1 ) END IF WRITE ( NOUT, FMT = 99994 ) I, J, $ ( POLESR(K), POLESI(K), K = IJ,IJ+NP(I,J)-1 ) WRITE ( NOUT, FMT = 99993 ) I, J, ( GAINS(I,J) ) 40 CONTINUE 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB04CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB04CD = ',I2) 99997 FORMAT (/' The poles, zeros and gains of the transfer matrix', $ ' elements: ') 99996 FORMAT (/' no zeros for element (',I2,',',I2,')') 99995 FORMAT (/' zeros of element (',I2,',',I2,') are ',// $ ' real part imag part '// (2X,F9.4,5X,F9.4)) 99994 FORMAT (/' poles of element (',I2,',',I2,') are ',// $ ' real part imag part '// (2X,F9.4,5X,F9.4)) 99993 FORMAT (/' gain of element (',I2,',',I2,') is ', F9.4) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTB05AD.f000077500000000000000000000074661201767322700165560ustar00rootroot00000000000000* TB05AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDG, LDHINV PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDG = PMAX, $ LDHINV = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NMAX ) INTEGER LZWORK PARAMETER ( LZWORK = NMAX*( NMAX+2 ) ) * .. Local Scalars .. COMPLEX*16 FREQ DOUBLE PRECISION RCOND INTEGER I, INFO, J, M, N, P CHARACTER*1 BALEIG, INITA LOGICAL LBALBA, LBALEA, LBALEB, LBALEC, LINITA * .. Local Arrays .. COMPLEX*16 G(LDG,MMAX), HINVB(LDHINV,MMAX), ZWORK(LZWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), EVIM(NMAX), EVRE(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB05AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, FREQ, INITA, BALEIG LBALEC = LSAME( BALEIG, 'C' ) LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' ) LBALEA = LSAME( BALEIG, 'A' ) LBALBA = LBALEB.OR.LBALEA LINITA = LSAME( INITA, 'G' ) IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the frequency response matrix of the ssr (A,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( ( LBALEC ) .OR. ( LBALEA ) ) WRITE ( NOUT, $ FMT = 99997 ) RCOND IF ( ( LINITA ) .AND. ( LBALBA ) ) $ WRITE ( NOUT, FMT = 99996 ) $ ( EVRE(I), EVIM(I), I = 1,N ) WRITE ( NOUT, FMT = 99995 ) DO 20 I = 1, P WRITE ( NOUT, FMT = 99994 ) ( G(I,J), J = 1,M ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( HINVB(I,J), J = 1,M ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB05AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB05AD = ',I2) 99997 FORMAT (' RCOND = ',F4.2) 99996 FORMAT (/' Eigenvalues of the state transmission matrix A are ', $ /(1X,2F7.2,'*j')) 99995 FORMAT (/' The frequency response matrix G(freq) is ') 99994 FORMAT (20(' (',F5.2,',',F5.2,') ',:)) 99993 FORMAT (/' H(inverse)*B is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTC01OD.f000077500000000000000000000061371201767322700165630ustar00rootroot00000000000000* TC01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, INDMAX PARAMETER ( MMAX = 20, PMAX = 20, INDMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDPCO1, LDPCO2, LDQCO1, LDQCO2 PARAMETER ( LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP ) * .. Local Scalars .. INTEGER I, INDLIM, INFO, J, K, M, P, PORM CHARACTER*1 LERI LOGICAL LLERI * .. Local Arrays .. DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,INDMAX), $ QCOEFF(LDQCO1,LDQCO2,INDMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TC01OD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, INDLIM, LERI LLERI = LSAME( LERI, 'L' ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99993 ) P ELSE IF ( INDLIM.LE.0 .OR. INDLIM.GT.INDMAX ) THEN WRITE ( NOUT, FMT = 99992 ) INDLIM ELSE PORM = P IF ( .NOT.LLERI ) PORM = M READ ( NIN, FMT = * ) $ ( ( ( PCOEFF(I,J,K), K = 1,INDLIM ), J = 1,PORM ), $ I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( QCOEFF(I,J,K), K = 1,INDLIM ), J = 1,M ), I = 1,P ) * Find the dual right pmr of the given left pmr. CALL TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, PORM DO 20 J = 1, PORM WRITE ( NOUT, FMT = 99996 ) I, J, $ ( PCOEFF(I,J,K), K = 1,INDLIM ) 20 CONTINUE 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 80 I = 1, M DO 60 J = 1, P WRITE ( NOUT, FMT = 99996 ) I, J, $ ( QCOEFF(I,J,K), K = 1,INDLIM ) 60 CONTINUE 80 CONTINUE END IF END IF STOP * 99999 FORMAT (' TC01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TC01OD = ',I2) 99997 FORMAT (' The coefficients of the denominator matrix of the dual', $ ' system are ') 99996 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2)) 99995 FORMAT (//' The coefficients of the numerator matrix of the dual', $ ' system are ') 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' P is out of range.',/' P = ',I5) 99992 FORMAT (/' INDLIM is out of range.',/' INDLIM = ',I5) END slicot-5.0+20101122/examples/TTC04AD.f000077500000000000000000000104671201767322700165510ustar00rootroot00000000000000* TC04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KPCMAX, NMAX PARAMETER ( MMAX = 5, PMAX = 5, KPCMAX = 5, NMAX = 5 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDPCO1, LDPCO2, LDQCO1, LDQCO2, LDA, LDB, LDC, $ LDD PARAMETER ( LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP, $ LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = ( MAXMP )*( MAXMP+4 ) ) * .. Local Scalars .. DOUBLE PRECISION RCOND INTEGER I, INFO, J, K, KPCOEF, M, N, P, PORM, PORP CHARACTER*1 LERI LOGICAL LLERI * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), PCOEFF(LDPCO1,LDPCO2,KPCMAX), $ QCOEFF(LDQCO1,LDQCO2,KPCMAX), DWORK(LDWORK) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TC04AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, LERI LLERI = LSAME( LERI, 'L' ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE PORM = P IF ( .NOT.LLERI ) PORM = M READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM ) PORP = M IF ( .NOT.LLERI ) PORP = P KPCOEF = 0 DO 20 I = 1, PORM KPCOEF = MAX( KPCOEF, INDEX(I) ) 20 CONTINUE KPCOEF = KPCOEF + 1 IF ( KPCOEF.LE.0 .OR. KPCOEF.GT.KPCMAX ) THEN WRITE ( NOUT, FMT = 99989 ) KPCOEF ELSE READ ( NIN, FMT = * ) $ ( ( ( PCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORM ), $ I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( QCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORP ), $ I = 1,PORM ) * Find a ssr of the given left pmr. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) N, RCOND WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 80 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 100 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TC04AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TC04AD = ',I2) 99997 FORMAT (' The order of the resulting state-space representation ', $ ' = ',I2,//' RCOND = ',F4.2) 99996 FORMAT (/' The state dynamics matrix A is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The input/state matrix B is ') 99993 FORMAT (/' The state/output matrix C is ') 99992 FORMAT (/' The direct transmission matrix D is ') 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) 99989 FORMAT (/' KPCOEF is out of range.',/' KPCOEF = ',I5) END slicot-5.0+20101122/examples/TTC05AD.f000077500000000000000000000070331201767322700165450ustar00rootroot00000000000000* TC05AD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KPCMAX PARAMETER ( MMAX = 20, PMAX = 20, KPCMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2 PARAMETER ( LDCFRE = MAXMP, LDPCO1 = MAXMP, $ LDPCO2 = MAXMP, LDQCO1 = MAXMP, $ LDQCO2 = MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MAXMP ) INTEGER LZWORK PARAMETER ( LZWORK = ( MAXMP )*( MAXMP+2 ) ) * .. Local Scalars .. COMPLEX*16 SVAL DOUBLE PRECISION RCOND INTEGER I, INFO, J, K, KPCOEF, M, P, PORM, PORP CHARACTER*1 LERI LOGICAL LLERI * .. Local Arrays .. COMPLEX*16 CFREQR(LDCFRE,MAXMP), ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK), PCOEFF(LDPCO1,LDPCO2,KPCMAX), $ QCOEFF(LDQCO1,LDQCO2,KPCMAX) INTEGER INDEX(MAXMP), IWORK(MAXMP) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TC05AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, SVAL, LERI LLERI = LSAME( LERI, 'L' ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99995 ) M ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99994 ) P ELSE PORM = P IF ( .NOT.LLERI ) PORM = M READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM ) PORP = M IF ( .NOT.LLERI ) PORP = P KPCOEF = 0 DO 20 I = 1, PORM KPCOEF = MAX( KPCOEF, INDEX(I) ) 20 CONTINUE KPCOEF = KPCOEF + 1 IF ( KPCOEF.LE.0 .OR. KPCOEF.GT.KPCMAX ) THEN WRITE ( NOUT, FMT = 99993 ) KPCOEF ELSE READ ( NIN, FMT = * ) $ ( ( ( PCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORM ), $ I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( QCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORP ), $ I = 1,PORM ) * Find the standard frequency response matrix of left pmr * at 0.5*j. CALL TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1, $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR, $ LDCFRE, IWORK, DWORK, ZWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RCOND DO 40 I = 1, PORM WRITE ( NOUT, FMT = 99996 ) $ ( CFREQR(I,J), J = 1,PORP ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TC05AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TC05AD = ',I2) 99997 FORMAT (' RCOND = ',F4.2,//' The frequency response matrix T(SVA', $ 'L) is ') 99996 FORMAT (20(' (',F5.2,',',F5.2,') ',:)) 99995 FORMAT (/' M is out of range.',/' M = ',I5) 99994 FORMAT (/' P is out of range.',/' P = ',I5) 99993 FORMAT (/' KPCOEF is out of range.',/' KPCOEF = ',I5) END slicot-5.0+20101122/examples/TTD03AD.f000077500000000000000000000153121201767322700165430ustar00rootroot00000000000000* TD03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KDCMAX, NMAX PARAMETER ( MMAX = 8, PMAX = 8, KDCMAX = 8, NMAX = 8 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, LDPCO2, $ LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, LDVCO2 PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP, LDDCOE = MAXMP, $ LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP, $ LDUCO1 = MAXMP, LDUCO2 = MAXMP, $ LDVCO1 = MAXMP, LDVCO2 = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( NMAX + MAX( NMAX, 3*MAXMP ), $ MAXMP*( MAXMP + 2 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL CHARACTER*1 EQUIL, LERI, ROWCOL INTEGER I, INDBLK, INFO, J, K, KDCOEF, M, MAXINP, N, NR, $ P, PORMD, PORMP * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DCOEFF(LDDCOE,KDCMAX), $ DWORK(LDWORK), PCOEFF(LDPCO1,LDPCO2,NMAX+1), $ QCOEFF(LDQCO1,LDQCO2,NMAX+1), $ UCOEFF(LDUCO1,LDUCO2,KDCMAX), $ VCOEFF(LDVCO1,LDVCO2,NMAX+1) INTEGER INDEXD(MAXMP), INDEXP(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TD03AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, TOL, ROWCOL, LERI, EQUIL IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99986 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99985 ) P ELSE PORMD = P IF ( LSAME( ROWCOL, 'C' ) ) PORMD = M PORMP = M IF ( LSAME( LERI, 'R' ) ) PORMP = P READ ( NIN, FMT = * ) ( INDEXD(I), I = 1,PORMD ) * KDCOEF = 0 N = 0 DO 20 I = 1, PORMD KDCOEF = MAX( KDCOEF, INDEXD(I) ) N = N + INDEXD(I) 20 CONTINUE KDCOEF = KDCOEF + 1 * IF ( KDCOEF.LE.0 .OR. KDCOEF.GT.KDCMAX ) THEN WRITE ( NOUT, FMT = 99984 ) KDCOEF ELSE READ ( NIN, FMT = * ) $ ( ( DCOEFF(I,J), J = 1,KDCOEF ), I = 1,PORMD ) READ ( NIN, FMT = * ) $ ( ( ( UCOEFF(I,J,K), K = 1,KDCOEF ), J = 1,M ), I = 1,P ) * Find a relatively prime left pmr for the given transfer * function. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 40 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 100 CONTINUE INDBLK = 0 DO 120 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 120 CONTINUE IF ( LSAME( LERI, 'L' ) ) THEN WRITE ( NOUT, FMT = 99992 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) WRITE ( NOUT, FMT = 99990 ) ( INDEXP(I), I = 1,P ) ELSE WRITE ( NOUT, FMT = 99991 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) WRITE ( NOUT, FMT = 99989 ) ( INDEXP(I), I = 1,M ) END IF MAXINP = 0 DO 140 I = 1, PORMP MAXINP = MAX( MAXINP, INDEXP(I) ) 140 CONTINUE MAXINP = MAXINP + 1 WRITE ( NOUT, FMT = 99988 ) DO 180 I = 1, PORMP DO 160 J = 1, PORMP WRITE ( NOUT, FMT = 99996 ) $ ( PCOEFF(I,J,K), K = 1,MAXINP ) 160 CONTINUE 180 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 220 I = 1, PORMP DO 200 J = 1, PORMD WRITE ( NOUT, FMT = 99996 ) $ ( QCOEFF(I,J,K), K = 1,MAXINP ) 200 CONTINUE 220 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TD03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TD03AD = ',I2) 99997 FORMAT (' The order of the resulting minimal realization = ',I2, $ //' The state dynamics matrix A is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix B is ') 99994 FORMAT (/' The state/output matrix C is ') 99993 FORMAT (/' The direct transmission matrix D is ') 99992 FORMAT (/' The observability index of the minimal realization = ', $ I2,//' The dimensions of the diagonal blocks of the state', $ ' dynamics matrix are ',/20(I5)) 99991 FORMAT (/' The controllability index of the minimal realization ', $ '= ',I2,//' The dimensions of the diagonal blocks of the ', $ 'state dynamics matrix are ',/20(I5)) 99990 FORMAT (/' The row degrees of the denominator matrix P(s) are', $ /20(I5)) 99989 FORMAT (/' The column degrees of the denominator matrix P(s) are', $ /20(I5)) 99988 FORMAT (/' The denominator matrix P(s) is ') 99987 FORMAT (/' The numerator matrix Q(s) is ') 99986 FORMAT (/' M is out of range.',/' M = ',I5) 99985 FORMAT (/' P is out of range.',/' P = ',I5) 99984 FORMAT (/' KDCOEF is out of range.',/' KDCOEF = ',I5) END slicot-5.0+20101122/examples/TTD04AD.f000077500000000000000000000117501201767322700165460ustar00rootroot00000000000000* TD04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KDCMAX, NMAX PARAMETER ( MMAX = 10, PMAX = 10, KDCMAX = 10, NMAX = 10 ) INTEGER MAXMP PARAMETER ( MAXMP = MAX( MMAX, PMAX ) ) INTEGER LDDCOE, LDUCO1, LDUCO2, LDA, LDB, LDC, LDD PARAMETER ( LDDCOE = MAXMP, LDUCO1 = MAXMP, $ LDUCO2 = MAXMP, LDA = NMAX, LDB = NMAX, $ LDC = MAXMP, LDD = MAXMP ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX + MAX( NMAX, 3*MAXMP ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INDBLK, INFO, J, K, KDCOEF, M, N, NR, P, PORM CHARACTER*1 ROWCOL LOGICAL LROWCO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DCOEFF(LDDCOE,KDCMAX), $ DWORK(LDWORK), UCOEFF(LDUCO1,LDUCO2,KDCMAX) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TD04AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, TOL, ROWCOL LROWCO = LSAME( ROWCOL, 'R' ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99989 ) P ELSE PORM = P IF ( .NOT.LROWCO ) PORM = M READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM ) * N = 0 KDCOEF = 0 DO 20 I = 1, PORM N = N + INDEX(I) KDCOEF = MAX( KDCOEF, INDEX(I) ) 20 CONTINUE KDCOEF = KDCOEF + 1 * IF ( KDCOEF.LE.0 .OR. KDCOEF.GT.KDCMAX ) THEN WRITE ( NOUT, FMT = 99988 ) KDCOEF ELSE READ ( NIN, FMT = * ) $ ( ( DCOEFF(I,J), J = 1,KDCOEF ), I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( UCOEFF(I,J,K), K = 1,KDCOEF ), J = 1,M ), I = 1,P ) * Find a minimal state-space representation (A,B,C,D). CALL TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, $ LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D, $ LDD, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 40 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 100 CONTINUE INDBLK = 0 DO 120 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 120 CONTINUE IF ( LROWCO ) THEN WRITE ( NOUT, FMT = 99992 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) ELSE WRITE ( NOUT, FMT = 99991 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) END IF END IF END IF END IF STOP * 99999 FORMAT (' TD04AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TD04AD = ',I2) 99997 FORMAT (' The order of the minimal realization = ',I2,//' The st', $ 'ate dynamics matrix A of a minimal realization is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix B of a minimal realization is ') 99994 FORMAT (/' The state/output matrix C of a minimal realization is ' $ ) 99993 FORMAT (/' The direct transmission matrix D is ') 99992 FORMAT (/' The observability index of a minimal state-space repr', $ 'esentation = ',I2,//' The dimensions of the diagonal blo', $ 'cks of the state dynamics matrix are',/20(1X,I2)) 99991 FORMAT (/' The controllability index of a minimal state-space re', $ 'presentation = ',I2,//' The dimensions of the diagonal b', $ 'locks of the state dynamics matrix are',/20(1X,I2)) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' P is out of range.',/' P = ',I5) 99988 FORMAT (/' KDCOEF is out of range.',/' KDCOEF = ',I5) END slicot-5.0+20101122/examples/TTD05AD.f000077500000000000000000000040651201767322700165500ustar00rootroot00000000000000* TD05AD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NP1MAX, MP1MAX PARAMETER ( NP1MAX = 20, MP1MAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION VALI, VALR, W INTEGER I, INFO, MP1, NP1 CHARACTER*1 UNITF, OUTPUT * .. Local Arrays .. DOUBLE PRECISION A(NP1MAX), B(MP1MAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TD05AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NP1, MP1, W, UNITF, OUTPUT IF ( NP1.LE.0 .OR. NP1.GT.NP1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP1 ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,NP1 ) IF ( MP1.LE.0 .OR. MP1.GT.MP1MAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP1 ELSE READ ( NIN, FMT = * ) ( B(I), I = 1,MP1 ) * Find the real and imaginary parts of G(jW), where * W = 1.0 radian. CALL TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( OUTPUT, 'C' ) ) THEN WRITE ( NOUT, FMT = 99997 ) VALR, VALI ELSE WRITE ( NOUT, FMT = 99996 ) VALR, VALI END IF END IF END IF END IF STOP * 99999 FORMAT (' TD05AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TD05AD = ',I2) 99997 FORMAT (' Complex value of G(jW) = ',F8.4,1X,F8.4,'*j') 99996 FORMAT (' Magnitude of G(jW) = ',F8.4,' dBs, Phase of G(jW) = ', $ F8.4,' degrees ') 99995 FORMAT (/' NP1 is out of range.',/' NP1 = ',I5) 99994 FORMAT (/' MP1 is out of range.',/' MP1 = ',I5) END slicot-5.0+20101122/examples/TTF01MD.f000077500000000000000000000057401201767322700165630ustar00rootroot00000000000000* TF01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NYMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, NYMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDU, LDY PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDU = MMAX, LDY = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N, NY, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), U(LDU,NYMAX), $ X(NMAX), Y(LDY,NYMAX) * .. External Subroutines .. EXTERNAL TF01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NY IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N ) READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M ) READ ( NIN, FMT = * ) ( X(I), I = 1,N ) IF ( NY.LE.0 .OR. NY.GT.NYMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NY ELSE READ ( NIN, FMT = * ) $ ( ( U(I,J), I = 1,M ), J = 1,NY ) * Compute y(1),...,y(NY) of the given system. CALL TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, $ LDD, U, LDU, X, Y, LDY, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NY DO 20 K = 1, NY WRITE ( NOUT, FMT = 99996 ) K, Y(1,K) WRITE ( NOUT, FMT = 99995 ) ( Y(J,K), J = 2,P ) 20 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TF01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01MD = ',I2) 99997 FORMAT (' The output sequence Y(1),...,Y(',I2,') is',/) 99996 FORMAT (' Y(',I2,') : ',F8.4) 99995 FORMAT (9X,F8.4,/) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' NY is out of range.',/' NY = ',I5) END slicot-5.0+20101122/examples/TTF01ND.f000077500000000000000000000060471201767322700165650ustar00rootroot00000000000000* TF01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NYMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, NYMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDU, LDY PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDU = MMAX, LDY = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. CHARACTER*1 UPLO INTEGER I, INFO, J, K, M, N, NY, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), U(LDU,NYMAX), $ X(NMAX), Y(LDY,NYMAX) * .. External Subroutines .. EXTERNAL TF01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NY, UPLO IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N ) READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M ) READ ( NIN, FMT = * ) ( X(I), I = 1,N ) IF ( NY.LE.0 .OR. NY.GT.NYMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NY ELSE READ ( NIN, FMT = * ) $ ( ( U(I,J), I = 1,M ), J = 1,NY ) * Compute y(1),...,y(NY) of the given system. CALL TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, $ LDC, D, LDD, U, LDU, X, Y, LDY, DWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NY DO 20 K = 1, NY WRITE ( NOUT, FMT = 99996 ) K, Y(1,K) WRITE ( NOUT, FMT = 99995 ) ( Y(J,K), J = 2,P ) 20 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TF01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01ND = ',I2) 99997 FORMAT (' The output sequence Y(1),...,Y(',I2,') is',/) 99996 FORMAT (' Y(',I2,') : ',F8.4) 99995 FORMAT (9X,F8.4,/) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' NY is out of range.',/' NY = ',I5) END slicot-5.0+20101122/examples/TTF01OD.f000077500000000000000000000043011201767322700165550ustar00rootroot00000000000000* TF01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NH1MAX, NH2MAX, NRMAX, NCMAX PARAMETER ( NH1MAX = 20, NH2MAX = 20, NRMAX = 20, $ NCMAX = 20 ) INTEGER LDH, LDT PARAMETER ( LDH = NH1MAX, LDT = NH1MAX*NRMAX ) * .. Local Scalars .. INTEGER I, INFO, J, NC, NCT, NH1, NH2, NR, NRT * .. Local Arrays .. DOUBLE PRECISION H(LDH,(NRMAX+NCMAX-1)*NH2MAX), $ T(LDT,NH2MAX*NCMAX) * .. External Subroutines .. EXTERNAL TF01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NH1, NH2, NR, NC IF ( NH1.LE.0 .OR. NH1.GE.NH1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) NH1 ELSE IF ( NH2.LE.0 .OR. NH2.GT.NH2MAX ) THEN WRITE ( NOUT, FMT = 99994 ) NH2 ELSE IF ( NR.LE.0 .OR. NR.GT.NRMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NR ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NC ELSE READ ( NIN, FMT = * ) $ ( ( H(I,J), I = 1,NH1 ), J = 1,( NR+NC-1 )*NH2 ) * Construct the NRT by NCT block Hankel expansion of M(k). CALL TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE NRT = NH1*NR NCT = NH2*NC WRITE ( NOUT, FMT = 99997 ) NRT, NCT DO 20 I = 1, NRT WRITE ( NOUT, FMT = 99996 ) ( T(I,J), J = 1,NCT ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' TF01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01OD = ',I2) 99997 FORMAT (' The ',I2,' by ',I2,' matrix T is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' NH1 is out of range.',/' NH1 = ',I5) 99994 FORMAT (/' NH2 is out of range.',/' NH2 = ',I5) 99993 FORMAT (/' NR is out of range.',/' NR = ',I5) 99992 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples/TTF01PD.f000077500000000000000000000043031201767322700165600ustar00rootroot00000000000000* TF01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NH1MAX, NH2MAX, NRMAX, NCMAX PARAMETER ( NH1MAX = 20, NH2MAX = 20, NRMAX = 20, $ NCMAX = 20 ) INTEGER LDH, LDT PARAMETER ( LDH = NH1MAX, LDT = NH1MAX*NRMAX ) * .. Local Scalars .. INTEGER I, INFO, J, NC, NCT, NH1, NH2, NR, NRT * .. Local Arrays .. DOUBLE PRECISION H(LDH,(NRMAX+NCMAX-1)*NH2MAX), $ T(LDT,NH2MAX*NCMAX) * .. External Subroutines .. EXTERNAL TF01PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NH1, NH2, NR, NC IF ( NH1.LE.0 .OR. NH1.GE.NH1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) NH1 ELSE IF ( NH2.LE.0 .OR. NH2.GT.NH2MAX ) THEN WRITE ( NOUT, FMT = 99994 ) NH2 ELSE IF ( NR.LE.0 .OR. NR.GT.NRMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NR ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NC ELSE READ ( NIN, FMT = * ) $ ( ( H(I,J), I = 1,NH1 ), J = 1,( NR+NC-1 )*NH2 ) * Construct the NRT by NCT block Toeplitz expansion of M(k). CALL TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE NRT = NH1*NR NCT = NH2*NC WRITE ( NOUT, FMT = 99997 ) NRT, NCT DO 20 I = 1, NRT WRITE ( NOUT, FMT = 99996 ) ( T(I,J), J = 1,NCT ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' TF01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01PD = ',I2) 99997 FORMAT (' The ',I2,' by ',I2,' matrix T is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' NH1 is out of range.',/' NH1 = ',I5) 99994 FORMAT (/' NH2 is out of range.',/' NH2 = ',I5) 99993 FORMAT (/' NR is out of range.',/' NR = ',I5) 99992 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples/TTF01QD.f000077500000000000000000000057541201767322700165740ustar00rootroot00000000000000* TF01QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NAMAX, NBMAX, NCMAX PARAMETER ( NMAX = 20, NAMAX = 20, NBMAX = 20, NCMAX = 20 ) INTEGER LDH PARAMETER ( LDH = NCMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, N, NA, NASUM, NB, NC, NL, NORD LOGICAL ERROR * .. Local Arrays .. DOUBLE PRECISION AR(NAMAX), H(LDH,NMAX*NBMAX), MA(NAMAX) INTEGER IORD(NCMAX*NBMAX) * .. External Subroutines .. EXTERNAL TF01QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NA, NB, NC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( NA.LE.0 .OR. NA.GT.NAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NA ELSE IF ( NB.LE.0 .OR. NB.GT.NBMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NB ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NC ELSE ERROR = .FALSE. NL = 0 K = 1 NASUM = 0 DO 40 I = 1, NC DO 20 J = 1, NB READ ( NIN, FMT = * ) NORD NASUM = NASUM + NORD IF ( NA.GE.NASUM ) THEN READ ( NIN, FMT = * ) ( MA(NL+L), L = 1,NORD ) READ ( NIN, FMT = * ) ( AR(NL+L), L = 1,NORD ) IORD(K) = NORD K = K + 1 NL = NL + NORD ELSE WRITE ( NOUT, FMT = 99993 ) NA ERROR = .TRUE. END IF 20 CONTINUE 40 CONTINUE IF ( .NOT. ERROR ) THEN * Compute M(1),...,M(N) from the given transfer function * matrix G(z). CALL TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) N DO 80 K = 1, N WRITE ( NOUT, FMT = 99996 ) K, $ ( H(1,(K-1)*NB+J), J = 1,NB ) DO 60 I = 2, NC WRITE ( NOUT, FMT = 99995 ) $ ( H(I,(K-1)*NB+J), J = 1,NB ) 60 CONTINUE 80 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TF01QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01QD = ',I2) 99997 FORMAT (' The Markov Parameters M(1),...,M(',I1,') are ') 99996 FORMAT (/' M(',I1,') : ',20(1X,F8.4)) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' NA is out of range.',/' NA = ',I5) 99992 FORMAT (/' NB is out of range.',/' NB = ',I5) 99991 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples/TTF01RD.f000077500000000000000000000054401201767322700165650ustar00rootroot00000000000000* TF01RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NAMAX, NBMAX, NCMAX PARAMETER ( NMAX = 20, NAMAX = 20, NBMAX = 20, NCMAX = 20 ) INTEGER LDA, LDB, LDC, LDH PARAMETER ( LDA = NAMAX, LDB = NAMAX, LDC = NCMAX, $ LDH = NCMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NAMAX*NCMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, N, NA, NB, NC * .. Local Arrays .. DOUBLE PRECISION A(LDA,NAMAX), B(LDB,NBMAX), C(LDC,NAMAX), $ H(LDH,NMAX*NBMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL TF01RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NA, NB, NC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( NA.LE.0 .OR. NA.GT.NAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NA ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,NA ), J = 1,NA ) IF ( NB.LE.0 .OR. NB.GT.NBMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NB ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,NA ), J = 1,NB ) IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NC ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,NC ), J = 1,NA ) * Compute M(1),...,M(N) from the system (A,B,C). CALL TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, $ LDH, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) N DO 40 K = 1, N WRITE ( NOUT, FMT = 99996 ) K, $ ( H(1,(K-1)*NB+J), J = 1,NB ) DO 20 I = 2, NC WRITE ( NOUT, FMT = 99995 ) $ ( H(I,(K-1)*NB+J), J = 1,NB ) 20 CONTINUE 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TF01RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01RD = ',I2) 99997 FORMAT (' The Markov Parameters M(1),...,M(',I1,') are ') 99996 FORMAT (/' M(',I1,') : ',20(1X,F8.4)) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' NA is out of range.',/' NA = ',I5) 99992 FORMAT (/' NB is out of range.',/' NB = ',I5) 99991 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples/TTG01AD.f000077500000000000000000000120261201767322700165430ustar00rootroot00000000000000* TG01AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 3*(LMAX+NMAX ) ) ) * .. Local Scalars .. CHARACTER*1 JOBS INTEGER I, INFO, J, L, M, N, P DOUBLE PRECISION ABCNRM, ENORM, SABCNM, SENORM, THRESH * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), LSCALE(LMAX), $ RSCALE(NMAX) * .. External Functions .. DOUBLE PRECISION DLANGE EXTERNAL DLANGE * .. External Subroutines .. EXTERNAL TG01AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, JOBS, THRESH IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Compute norms before scaling ABCNRM = MAX( DLANGE( '1', L, N, A, LDA, DWORK ), $ DLANGE( '1', L, M, B, LDB, DWORK ), $ DLANGE( '1', P, N, C, LDC, DWORK ) ) ENORM = DLANGE( '1', L, N, E, LDE, DWORK ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL TG01AD( JOBS, L, N, M, P, THRESH, A, LDA, E, LDE, $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE SABCNM = MAX( DLANGE( '1', L, N, A, LDA, DWORK ), $ DLANGE( '1', L, M, B, LDB, DWORK ), $ DLANGE( '1', P, N, C, LDC, DWORK ) ) SENORM = DLANGE( '1', L, N, E, LDE, DWORK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99995 ) ( LSCALE(I), I = 1,L ) WRITE ( NOUT, FMT = 99990 ) WRITE ( NOUT, FMT = 99995 ) ( RSCALE(J), J = 1,N ) WRITE ( NOUT, FMT = 99994 ) $ ABCNRM, SABCNM, ENORM, SENORM END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01AD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Dl*A*Dr is ') 99996 FORMAT (/' The transformed descriptor matrix Dl*E*Dr is ') 99995 FORMAT (20(1X,F9.4)) 99994 FORMAT (/' Norm of [ A B; C 0] =', 1PD10.3/ $ ' Norm of scaled [ A B; C 0] =', 1PD10.3/ $ ' Norm of E =', 1PD10.3/ $ ' Norm of scaled E =', 1PD10.3) 99993 FORMAT (/' The transformed input/state matrix Dl*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Dr is ') 99991 FORMAT (/' The diagonal of left scaling matrix Dl is ') 99990 FORMAT (/' The diagonal of right scaling matrix Dr is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTG01AZ.f000077500000000000000000000120771201767322700165770ustar00rootroot00000000000000* TG01AZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, 3*(LMAX+NMAX ) ) ) * .. Local Scalars .. CHARACTER*1 JOBS INTEGER I, INFO, J, L, M, N, P DOUBLE PRECISION ABCNRM, ENORM, SABCNM, SENORM, THRESH * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ E(LDE,NMAX) DOUBLE PRECISION DWORK(LDWORK), LSCALE(LMAX), RSCALE(NMAX) * .. External Functions .. DOUBLE PRECISION ZLANGE EXTERNAL ZLANGE * .. External Subroutines .. EXTERNAL TG01AZ * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, JOBS, THRESH IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Compute norms before scaling ABCNRM = MAX( ZLANGE( '1', L, N, A, LDA, DWORK ), $ ZLANGE( '1', L, M, B, LDB, DWORK ), $ ZLANGE( '1', P, N, C, LDC, DWORK ) ) ENORM = ZLANGE( '1', L, N, E, LDE, DWORK ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL TG01AZ( JOBS, L, N, M, P, THRESH, A, LDA, E, LDE, $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE SABCNM = MAX( ZLANGE( '1', L, N, A, LDA, DWORK ), $ ZLANGE( '1', L, M, B, LDB, DWORK ), $ ZLANGE( '1', P, N, C, LDC, DWORK ) ) SENORM = ZLANGE( '1', L, N, E, LDE, DWORK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99985 ) ( LSCALE(I), I = 1,L ) WRITE ( NOUT, FMT = 99990 ) WRITE ( NOUT, FMT = 99985 ) ( RSCALE(J), J = 1,N ) WRITE ( NOUT, FMT = 99994 ) $ ABCNRM, SABCNM, ENORM, SENORM END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01AZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01AZ = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Dl*A*Dr is ') 99996 FORMAT (/' The transformed descriptor matrix Dl*E*Dr is ') 99995 FORMAT (20(1X,F9.4,SP,F9.4,S,'i ')) 99994 FORMAT (/' Norm of [ A B; C 0] =', 1PD10.3/ $ ' Norm of scaled [ A B; C 0] =', 1PD10.3/ $ ' Norm of E =', 1PD10.3/ $ ' Norm of scaled E =', 1PD10.3) 99993 FORMAT (/' The transformed input/state matrix Dl*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Dr is ') 99991 FORMAT (/' The diagonal of left scaling matrix Dl is ') 99990 FORMAT (/' The diagonal of right scaling matrix Dr is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) 99985 FORMAT (20(1X,F9.4)) END slicot-5.0+20101122/examples/TTG01CD.f000077500000000000000000000062551201767322700165540ustar00rootroot00000000000000* TG01CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20) INTEGER LDA, LDB, LDE, LDQ PARAMETER ( LDA = LMAX, LDB = LMAX, $ LDE = LMAX, LDQ = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MIN(LMAX,NMAX)+MAX(LMAX,NMAX,MMAX) ) * .. Local Scalars .. CHARACTER*1 COMPQ INTEGER I, INFO, J, L, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX) * .. External Subroutines .. EXTERNAL TG01CD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M COMPQ = 'I' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) * Find the transformed descriptor system pair * (A-lambda E,B). CALL TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, $ Q, LDQ, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01CD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The transformed input/state matrix Q''*B is ') 99993 FORMAT (/' The left transformation matrix Q is ') 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TTG01DD.f000077500000000000000000000062461201767322700165550ustar00rootroot00000000000000* TG01DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, PMAX = 20) INTEGER LDA, LDC, LDE, LDZ PARAMETER ( LDA = LMAX, LDC = PMAX, $ LDE = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MIN(LMAX,NMAX)+MAX(LMAX,NMAX,PMAX) ) * .. Local Scalars .. CHARACTER*1 COMPZ INTEGER I, INFO, J, L, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01DD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, P COMPZ = 'I' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system pair * (A-lambda E,B). CALL TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, $ Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01DD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The transformed input/state matrix C*Z is ') 99993 FORMAT (/' The right transformation matrix Z is ') 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTG01ED.f000077500000000000000000000110151201767322700165440ustar00rootroot00000000000000* TG01ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, MIN( LMAX, NMAX ) + $ MAX( MMAX, PMAX, 3*MIN( LMAX, NMAX ) + $ MAX( LMAX, NMAX ), $ 5*MIN( LMAX, NMAX ) ) ) ) * .. Local Scalars .. CHARACTER*1 JOBA INTEGER I, INFO, J, L, M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01ED * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL JOBA = 'R' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, $ TOL, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22 WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01ED = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Rank of matrix E =', I5/ $ ' Rank of matrix A22 =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTG01FD.f000077500000000000000000000110241201767322700165450ustar00rootroot00000000000000* TG01FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, PMAX, $ MIN(LMAX,NMAX)+MAX( 3*NMAX, MMAX, LMAX ) ) ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBA INTEGER I, INFO, J, L, M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01FD * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL COMPQ = 'I' COMPZ = 'I' JOBA = 'R' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22 WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01FD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Rank of matrix E =', I5/ $ ' Rank of matrix A22 =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTG01FZ.f000077500000000000000000000112371201767322700166010ustar00rootroot00000000000000* TG01FZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NMAX ) INTEGER LZWORK PARAMETER ( LZWORK = MAX( 1, NMAX+PMAX, $ MIN(LMAX,NMAX)+MAX( 3*NMAX-1, MMAX, LMAX ) ) ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBA INTEGER I, INFO, J, L, M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(NMAX) COMPLEX*16 A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ E(LDE,NMAX), Q(LDQ,LMAX), Z(LDZ,NMAX), $ ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK) * .. External Subroutines .. EXTERNAL TG01FZ * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL COMPQ = 'I' COMPZ = 'I' JOBA = 'R' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22 WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01FZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01FZ = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4,SP,F8.4,S,'i ')) 99994 FORMAT (' Rank of matrix E =', I5/ $ ' Rank of matrix A22 =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TTG01HD.f000077500000000000000000000106741201767322700165610ustar00rootroot00000000000000* TG01HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, NMAX, 2*MMAX ) ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBCO INTEGER I, INFO, J, M, N, NCONT, NIUCON, NRBLCK, P DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(MMAX), RTAU(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01HD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBCO COMPQ = 'I' COMPZ = 'I' IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system (A-lambda E,B,C). CALL TG01HD( JOBCO, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NCONT, NIUCON WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99984 ) ( RTAU(I), I = 1,NRBLCK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01HD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Dimension of controllable part =', I5/ $ ' Number of uncontrollable infinite eigenvalues =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) 99985 FORMAT (/' The staircase form row dimensions are ' ) 99984 FORMAT (10I5) END slicot-5.0+20101122/examples/TTG01ID.f000077500000000000000000000110301201767322700165450ustar00rootroot00000000000000* TG01ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MPMX PARAMETER ( MPMX = MAX( MMAX, PMAX ) ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = MAX(MMAX,PMAX), $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MAX( 1, NMAX, 2*PMAX ) ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBOBS INTEGER I, INFO, J, M, N, NOBSV, NIUOBS, NLBLCK, P DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(MMAX), CTAU(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MPMX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01ID * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBOBS COMPQ = 'I' COMPZ = 'I' IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system (A-lambda E,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NOBSV, NIUOBS WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99984 ) ( CTAU(I), I = 1,NLBLCK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01ID = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Dimension of observable part =', I5/ $ ' Number of unobservable infinite eigenvalues =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) 99985 FORMAT (/' The staircase form column dimensions are ' ) 99984 FORMAT (10I5) END slicot-5.0+20101122/examples/TTG01JD.f000077500000000000000000000075461201767322700165670ustar00rootroot00000000000000* TG01JD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDE = NMAX ) INTEGER LDWORK, LIWORK PARAMETER ( LDWORK = MAX( 8*NMAX,2*MMAX,2*PMAX ), $ LIWORK = NMAX + MAX( MMAX, PMAX ) ) * .. Local Scalars .. CHARACTER EQUIL, JOB, SYSTYP INTEGER I, INFO, J, M, N, NR, P DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER INFRED(7), IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX) * .. External Subroutines .. EXTERNAL TG01JD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOB, SYSTYP, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the irreducible descriptor system (Ar-lambda Er,Br,Cr). CALL TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE, $ B, LDB, C, LDC, NR, INFRED, TOL, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NR WRITE ( NOUT, FMT = 99991 ) DO 10 I = 1, 4 IF( INFRED(I).GE.0 ) $ WRITE ( NOUT, FMT = 99990 ) I, INFRED(I) 10 CONTINUE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 30 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,NR ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 50 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 50 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01JD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01JD = ',I2) 99997 FORMAT (/' The reduced state dynamics matrix Ar is ') 99996 FORMAT (/' The reduced descriptor matrix Er is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Order of reduced system =', I5 ) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' Achieved order reductions in different phases') 99990 FORMAT (' Phase',I2,':', I3, ' elliminated eigenvalue(s)' ) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples/TUD01BD.f000077500000000000000000000037021201767322700165430ustar00rootroot00000000000000* UD01BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MPMAX, NPMAX, DPMAX PARAMETER ( MPMAX = 10, NPMAX = 10, DPMAX = 5 ) INTEGER LDP1, LDP2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX ) * .. Local Scalars .. INTEGER DP, INFO, L, MP, NP * .. Local Arrays .. DOUBLE PRECISION P(LDP1,LDP2,DPMAX) * .. External Subroutines .. EXTERNAL UD01BD, UD01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, 99996 ) MP, NP, DP * Write the coefficients of the matrix polynomial P(s). L = 5 CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, ' P', $ INFO ) IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' UD01BD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01BD = ',I2) 99997 FORMAT (' INFO on exit from UD01ND = ',I2) 99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2) 99995 FORMAT (/' NP is out of range.',/' NP = ',I5) 99994 FORMAT (/' MP is out of range.',/' MP = ',I5) 99993 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples/TUD01CD.f000077500000000000000000000037301201767322700165450ustar00rootroot00000000000000* UD01CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MPMAX, NPMAX, DPMAX PARAMETER ( MPMAX = 10, NPMAX = 10, DPMAX = 5 ) INTEGER LDP1, LDP2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX ) * .. Local Scalars .. INTEGER DP, INFO, INFO1, L, MP, NP * .. Local Arrays .. DOUBLE PRECISION P(LDP1,LDP2,DPMAX) * .. External Subroutines .. EXTERNAL UD01CD, UD01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) IF ( INFO.GE.0 ) THEN WRITE ( NOUT, 99996 ) MP, NP, DP * Write the coefficients of the matrix polynomial P(s). L = 5 CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, ' P', $ INFO1 ) IF ( INFO1.NE.0 ) $ WRITE ( NOUT, FMT = 99997 ) INFO1 END IF IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO END IF STOP * 99999 FORMAT (' UD01CD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01CD = ',I2) 99997 FORMAT (' INFO on exit from UD01ND = ',I2) 99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2) 99995 FORMAT (/' NP is out of range.',/' NP = ',I5) 99994 FORMAT (/' MP is out of range.',/' MP = ',I5) 99993 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples/TUD01DD.f000077500000000000000000000030641201767322700165460ustar00rootroot00000000000000* UD01DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 10, NMAX = 10 ) INTEGER LDA PARAMETER ( LDA = NMAX ) * .. Local Scalars .. INTEGER INFO, INFO1, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX) * .. External Subroutines .. EXTERNAL UD01DD, UD01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01DD( M, N, NIN, A, LDA, INFO ) IF ( INFO.GE.0 ) THEN * Write the matrix A. CALL UD01MD( M, N, 5, NOUT, A, LDA, ' Matrix A', INFO1 ) IF ( INFO1.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO1 END IF IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99997 ) INFO END IF STOP * 99999 FORMAT (' UD01DD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01MD = ',I2) 99997 FORMAT (' INFO on exit from UD01DD = ',I2) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TUD01MD.f000077500000000000000000000025371201767322700165630ustar00rootroot00000000000000* UD01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, L, M, N CHARACTER*72 TEXT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX) * .. External Subroutines .. EXTERNAL UD01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, L, TEXT IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99997 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) * Print out the matrix A. CALL UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) IF ( INFO.NE.0 ) WRITE ( NOUT, FMT = 99998 ) INFO END IF STOP * 99999 FORMAT (' UD01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from UD01MD = ',I2) 99997 FORMAT (/' N is out of range.',/' N = ',I5) 99996 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples/TUD01ND.f000077500000000000000000000037251201767322700165640ustar00rootroot00000000000000* UD01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MPMAX, NPMAX, DPMAX PARAMETER ( MPMAX = 10, NPMAX = 10, DPMAX = 5 ) INTEGER LDP1, LDP2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX ) * .. Local Scalars .. INTEGER DP, INFO, L, MP, NP CHARACTER*72 TEXT * .. Local Arrays .. DOUBLE PRECISION P(LDP1,LDP2,DPMAX) * .. External Subroutines .. EXTERNAL UD01BD, UD01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP, L, TEXT IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, 99996 ) MP, NP, DP * Write the coefficients of the matrix polynomial P(s). CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, $ INFO ) IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) INFO END IF END IF STOP * 99999 FORMAT (' UD01ND EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01ND = ',I2) 99997 FORMAT (' INFO on exit from UD01BD = ',I2) 99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2) 99995 FORMAT (/' NP is out of range.',/' NP = ',I5) 99994 FORMAT (/' MP is out of range.',/' MP = ',I5) 99993 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples/UD01BD.dat000077500000000000000000000005671201767322700167500ustar00rootroot00000000000000UD01BD EXAMPLE PROGRAM DATA 4 3 2 P0 1.0D-00 0.0D-00 0.0D-00 0.0D-00 2.0D-00 4.0D-00 0.0D-00 4.0D-00 8.0D-00 0.0D-00 6.0D-00 1.2D+01 P1 0.0D-00 1.0D-00 2.0D-00 1.0D-00 0.0D-00 0.0D-00 2.0D-00 0.0D-00 0.0D-00 3.0D-00 0.0D-00 0.0D-00 P2 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 slicot-5.0+20101122/examples/UD01BD.res000077500000000000000000000015301201767322700167600ustar00rootroot00000000000000 UD01BD EXAMPLE PROGRAM RESULTS MP = 4 NP = 3 DP = 2 P( 0) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.2000000D+01 0.4000000D+01 3 0.0000000D+00 0.4000000D+01 0.8000000D+01 4 0.0000000D+00 0.6000000D+01 0.1200000D+02 P( 1) ( 4X 3) 1 2 3 1 0.0000000D+00 0.1000000D+01 0.2000000D+01 2 0.1000000D+01 0.0000000D+00 0.0000000D+00 3 0.2000000D+01 0.0000000D+00 0.0000000D+00 4 0.3000000D+01 0.0000000D+00 0.0000000D+00 P( 2) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 slicot-5.0+20101122/examples/UD01CD.dat000077500000000000000000000001621201767322700167400ustar00rootroot00000000000000UD01CD EXAMPLE PROGRAM DATA 4 3 2 1 1 1 1.0 1.0 2 2 2 2.0 0.0 1.0 3 3 2 0.0 3.0 1.0 4 1 0 4.0 slicot-5.0+20101122/examples/UD01CD.res000077500000000000000000000015301201767322700167610ustar00rootroot00000000000000 UD01CD EXAMPLE PROGRAM RESULTS MP = 4 NP = 3 DP = 2 P( 0) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.2000000D+01 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 4 0.4000000D+01 0.0000000D+00 0.0000000D+00 P( 1) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.3000000D+01 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 P( 2) ( 4X 3) 1 2 3 1 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.1000000D+01 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.1000000D+01 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 slicot-5.0+20101122/examples/UD01DD.dat000077500000000000000000000002431201767322700167410ustar00rootroot00000000000000UD01DD EXAMPLE PROGRAM DATA 6 5 1 1 -1.1 6 1 1.5 2 2 -2.2 6 2 2.5 3 3 -3.3 6 3 3.5 4 4 -4.4 6 4 4.5 5 5 -5.5 6 5 5.5 slicot-5.0+20101122/examples/UD01DD.res000077500000000000000000000011471201767322700167660ustar00rootroot00000000000000 UD01DD EXAMPLE PROGRAM RESULTS Matrix A ( 6X 5) 1 2 3 4 5 1 -0.1100000D+01 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 -0.2200000D+01 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 -0.3300000D+01 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.4400000D+01 0.0000000D+00 5 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.5500000D+01 6 0.1500000D+01 0.2500000D+01 0.3500000D+01 0.4500000D+01 0.5500000D+01 slicot-5.0+20101122/examples/UD01MD.dat000077500000000000000000000002411201767322700167500ustar00rootroot00000000000000 UD01MD EXAMPLE PROGRAM DATA 4 4 4 'Matrix A' 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 slicot-5.0+20101122/examples/UD01MD.res000077500000000000000000000005711201767322700167770ustar00rootroot00000000000000 UD01MD EXAMPLE PROGRAM RESULTS Matrix A ( 4X 4) 1 2 3 4 1 0.1000000D+01 0.2000000D+01 0.3000000D+01 0.4000000D+01 2 0.5000000D+01 0.6000000D+01 0.7000000D+01 0.8000000D+01 3 0.9000000D+01 0.1000000D+02 0.1100000D+02 0.1200000D+02 4 0.1300000D+02 0.1400000D+02 0.1500000D+02 0.1600000D+02 slicot-5.0+20101122/examples/UD01ND.dat000077500000000000000000000006041201767322700167540ustar00rootroot00000000000000UD01ND EXAMPLE PROGRAM DATA 4 3 2 5 P P0 1.0D-00 0.0D-00 0.0D-00 0.0D-00 2.0D-00 4.0D-00 0.0D-00 4.0D-00 8.0D-00 0.0D-00 6.0D-00 1.2D+01 P1 0.0D-00 1.0D-00 2.0D-00 1.0D-00 0.0D-00 0.0D-00 2.0D-00 0.0D-00 0.0D-00 3.0D-00 0.0D-00 0.0D-00 P2 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 slicot-5.0+20101122/examples/UD01ND.res000077500000000000000000000015251201767322700170000ustar00rootroot00000000000000 UD01ND EXAMPLE PROGRAM RESULTS MP = 4 NP = 3 DP = 2 P( 0) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.2000000D+01 0.4000000D+01 3 0.0000000D+00 0.4000000D+01 0.8000000D+01 4 0.0000000D+00 0.6000000D+01 0.1200000D+02 P( 1) ( 4X 3) 1 2 3 1 0.0000000D+00 0.1000000D+01 0.2000000D+01 2 0.1000000D+01 0.0000000D+00 0.0000000D+00 3 0.2000000D+01 0.0000000D+00 0.0000000D+00 4 0.3000000D+01 0.0000000D+00 0.0000000D+00 P( 2) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 slicot-5.0+20101122/examples/makefile000077500000000000000000001373121201767322700170760ustar00rootroot00000000000000#################################################################### # SLICOT examples makefile # # Makefile for generating and running SLICOT Library example # # programs on Unix machines. # # SLICOT, Release 5.0 ./slicot/examples/makefile # # Vasile Sima, KU Leuven # # October 31, 1996. # # Revised December 7, 1999, Jan. 8 2009. # #################################################################### # # This makefile compiles, links, and runs the example programs for # the SLICOT Library on Unix machines. # # The example programs can be executed for double precision only. # To compile, link, and run the example programs, enter 'make'. # The executable files are created in the current directory level. # The files with the results have the extension .exa, and are also # created in the current directory level, so they can automatically be # compared with the .res files provided in this directory. Note that, # for some programs, the signs of some matrix elements could differ; # this does not mean erroneous results. # # To remove the .exa files after the programs have been run, enter # make clean # # To remove the .exa files, as well as the executable programs, enter # make cleanup # # To re-run specific programs after a make, enter (for example): # 'rm TAB01MD; make' or: # 'make TAB01MD' or: # 'touch AB01MD.dat; make' (to re-run the TAB01MD program). # # 'rm TAB01*D; make' (to re-run all programs of section AB01). # #################################################################### include ../make.inc all: AB01MD.exa AB01ND.exa AB01OD.exa AB04MD.exa AB05MD.exa AB05ND.exa \ AB05OD.exa AB05PD.exa AB05QD.exa AB05RD.exa AB07MD.exa AB07ND.exa \ AB08ND.exa AB09AD.exa AB09BD.exa AB09CD.exa AB09DD.exa AB09ED.exa \ AB09FD.exa AB09GD.exa AB09HD.exa AB09ID.exa AB09JD.exa AB09KD.exa \ AB09MD.exa AB09ND.exa AB13AD.exa AB13BD.exa AB13CD.exa AB13DD.exa \ AB13ED.exa AB13FD.exa AB13MD.exa AG08BD.exa \ BB01AD.exa BB02AD.exa BB03AD.exa BB04AD.exa BD01AD.exa BD02AD.exa \ DE01OD.exa DE01PD.exa DF01MD.exa DG01MD.exa DG01ND.exa DG01OD.exa \ DK01MD.exa \ FB01QD.exa FB01RD.exa FB01SD.exa FB01TD.exa FB01VD.exa FD01AD.exa \ IB01AD.exa IB01BD.exa IB01CD.exa IB03AD.exa IB03BD.exa \ MB01TD.exa MB02CD.exa MB02DD.exa MB02ED.exa MB02FD.exa MB02GD.exa \ MB02HD.exa MB02ID.exa MB02JD.exa MB02JX.exa MB02KD.exa MB02MD.exa \ MB02ND.exa MB02QD.exa MB02SD.exa MB02VD.exa MB03MD.exa MB03ND.exa \ MB03OD.exa MB03PD.exa MB03QD.exa MB03RD.exa MB03SD.exa MB03UD.exa \ MB03VD.exa MB03WD.exa MB04DY.exa MB04GD.exa MB04MD.exa MB04OD.exa \ MB04UD.exa MB04VD.exa MB04XD.exa MB04YD.exa MB04ZD.exa MB05MD.exa \ MB05ND.exa MB05OD.exa MC01MD.exa MC01ND.exa MC01OD.exa MC01PD.exa \ MC01QD.exa MC01RD.exa MC01SD.exa MC01TD.exa MC01VD.exa MC01WD.exa \ MC03MD.exa MC03ND.exa \ MD03AD.exa MD03BD.exa \ SB01BD.exa SB01DD.exa SB01MD.exa SB02MD.exa SB02ND.exa SB02OD.exa \ SB02PD.exa SB02QD.exa SB02RD.exa SB02SD.exa SB03MD.exa SB03OD.exa \ SB03QD.exa SB03SD.exa SB03TD.exa SB03UD.exa SB04MD.exa SB04ND.exa \ SB04OD.exa SB04PD.exa SB04QD.exa SB04RD.exa SB06ND.exa SB08CD.exa \ SB08DD.exa SB08ED.exa SB08FD.exa SB08MD.exa SB08ND.exa SB09MD.exa \ SB10DD.exa SB10ED.exa SB10FD.exa SB10HD.exa SB10ID.exa SB10KD.exa \ SB10ZD.exa SB16AD.exa SB16BD.exa SB16CD.exa SG02AD.exa SG03AD.exa \ SG03BD.exa \ TB01ID.exa TB01KD.exa TB01LD.exa TB01MD.exa TB01ND.exa TB01PD.exa \ TB01TD.exa TB01UD.exa TB01WD.exa TB01ZD.exa TB03AD.exa TB04AD.exa \ TB04BD.exa TB04CD.exa TB05AD.exa TC01OD.exa TC04AD.exa TC05AD.exa \ TD03AD.exa TD04AD.exa TD05AD.exa TF01MD.exa TF01ND.exa TF01OD.exa \ TF01PD.exa TF01QD.exa TF01RD.exa TG01AD.exa TG01CD.exa TG01DD.exa \ TG01ED.exa TG01FD.exa TG01HD.exa TG01ID.exa TG01JD.exa \ UD01BD.exa UD01CD.exa UD01DD.exa UD01MD.exa UD01ND.exa \ MB03TD.exa MB03XD.exa MB03XP.exa MB03ZD.exa MB04DD.exa \ MB04DS.exa MB04PB.exa MB04PU.exa MB04TB.exa MB04TS.exa \ AB08NZ.exa AG08BZ.exa TB01IZ.exa TG01AZ.exa TG01FZ.exa \ MB03BD.exa MB03KD.exa MB03LD.exa MB04AD.exa MB04BD.exa AB01MD.exa: AB01MD.dat TAB01MD; ./TAB01MD AB01MD.exa AB01ND.exa: AB01ND.dat TAB01ND; ./TAB01ND AB01ND.exa AB01OD.exa: AB01OD.dat TAB01OD; ./TAB01OD AB01OD.exa AB04MD.exa: AB04MD.dat TAB04MD; ./TAB04MD AB04MD.exa AB05MD.exa: AB05MD.dat TAB05MD; ./TAB05MD AB05MD.exa AB05ND.exa: AB05ND.dat TAB05ND; ./TAB05ND AB05ND.exa AB05OD.exa: AB05OD.dat TAB05OD; ./TAB05OD AB05OD.exa AB05PD.exa: AB05PD.dat TAB05PD; ./TAB05PD AB05PD.exa AB05QD.exa: AB05QD.dat TAB05QD; ./TAB05QD AB05QD.exa AB05RD.exa: AB05RD.dat TAB05RD; ./TAB05RD AB05RD.exa AB07MD.exa: AB07MD.dat TAB07MD; ./TAB07MD AB07MD.exa AB07ND.exa: AB07ND.dat TAB07ND; ./TAB07ND AB07ND.exa AB08ND.exa: AB08ND.dat TAB08ND; ./TAB08ND AB08ND.exa AB09AD.exa: AB09AD.dat TAB09AD; ./TAB09AD AB09AD.exa AB09BD.exa: AB09BD.dat TAB09BD; ./TAB09BD AB09BD.exa AB09CD.exa: AB09CD.dat TAB09CD; ./TAB09CD AB09CD.exa AB09DD.exa: AB09DD.dat TAB09DD; ./TAB09DD AB09DD.exa AB09ED.exa: AB09ED.dat TAB09ED; ./TAB09ED AB09ED.exa AB09FD.exa: AB09FD.dat TAB09FD; ./TAB09FD AB09FD.exa AB09GD.exa: AB09GD.dat TAB09GD; ./TAB09GD AB09GD.exa AB09HD.exa: AB09HD.dat TAB09HD; ./TAB09HD AB09HD.exa AB09ID.exa: AB09ID.dat TAB09ID; ./TAB09ID AB09ID.exa AB09JD.exa: AB09JD.dat TAB09JD; ./TAB09JD AB09JD.exa AB09KD.exa: AB09KD.dat TAB09KD; ./TAB09KD AB09KD.exa AB09MD.exa: AB09MD.dat TAB09MD; ./TAB09MD AB09MD.exa AB09ND.exa: AB09ND.dat TAB09ND; ./TAB09ND AB09ND.exa AB13AD.exa: AB13AD.dat TAB13AD; ./TAB13AD AB13AD.exa AB13BD.exa: AB13BD.dat TAB13BD; ./TAB13BD AB13BD.exa AB13CD.exa: AB13CD.dat TAB13CD; ./TAB13CD AB13CD.exa AB13DD.exa: AB13DD.dat TAB13DD; ./TAB13DD AB13DD.exa AB13ED.exa: AB13ED.dat TAB13ED; ./TAB13ED AB13ED.exa AB13FD.exa: AB13FD.dat TAB13FD; ./TAB13FD AB13FD.exa AB13MD.exa: AB13MD.dat TAB13MD; ./TAB13MD AB13MD.exa AG08BD.exa: AG08BD.dat TAG08BD; ./TAG08BD AG08BD.exa BB01AD.exa: BB01AD.dat TBB01AD; ./TBB01AD BB01AD.exa BB02AD.exa: BB02AD.dat TBB02AD; ./TBB02AD BB02AD.exa BB03AD.exa: BB03AD.dat TBB03AD; ./TBB03AD BB03AD.exa BB04AD.exa: BB04AD.dat TBB04AD; ./TBB04AD BB04AD.exa BD01AD.exa: BD01AD.dat TBD01AD; ./TBD01AD BD01AD.exa BD02AD.exa: BD02AD.dat TBD02AD; ./TBD02AD BD02AD.exa DE01OD.exa: DE01OD.dat TDE01OD; ./TDE01OD DE01OD.exa DE01PD.exa: DE01PD.dat TDE01PD; ./TDE01PD DE01PD.exa DF01MD.exa: DF01MD.dat TDF01MD; ./TDF01MD DF01MD.exa DG01MD.exa: DG01MD.dat TDG01MD; ./TDG01MD DG01MD.exa DG01ND.exa: DG01ND.dat TDG01ND; ./TDG01ND DG01ND.exa DG01OD.exa: DG01OD.dat TDG01OD; ./TDG01OD DG01OD.exa DK01MD.exa: DK01MD.dat TDK01MD; ./TDK01MD DK01MD.exa FB01QD.exa: FB01QD.dat TFB01QD; ./TFB01QD FB01QD.exa FB01RD.exa: FB01RD.dat TFB01RD; ./TFB01RD FB01RD.exa FB01SD.exa: FB01SD.dat TFB01SD; ./TFB01SD FB01SD.exa FB01TD.exa: FB01TD.dat TFB01TD; ./TFB01TD FB01TD.exa FB01VD.exa: FB01VD.dat TFB01VD; ./TFB01VD FB01VD.exa FD01AD.exa: FD01AD.dat TFD01AD; ./TFD01AD FD01AD.exa IB01AD.exa: IB01AD.dat TIB01AD; ./TIB01AD IB01AD.exa IB01BD.exa: IB01BD.dat TIB01BD; ./TIB01BD IB01BD.exa IB01CD.exa: IB01CD.dat TIB01CD; ./TIB01CD IB01CD.exa IB03AD.exa: IB03AD.dat TIB03AD; ./TIB03AD IB03AD.exa IB03BD.exa: IB03BD.dat TIB03BD; ./TIB03BD IB03BD.exa MB01TD.exa: MB01TD.dat TMB01TD; ./TMB01TD MB01TD.exa MB02CD.exa: MB02CD.dat TMB02CD; ./TMB02CD MB02CD.exa MB02DD.exa: MB02DD.dat TMB02DD; ./TMB02DD MB02DD.exa MB02ED.exa: MB02ED.dat TMB02ED; ./TMB02ED MB02ED.exa MB02FD.exa: MB02FD.dat TMB02FD; ./TMB02FD MB02FD.exa MB02GD.exa: MB02GD.dat TMB02GD; ./TMB02GD MB02GD.exa MB02HD.exa: MB02HD.dat TMB02HD; ./TMB02HD MB02HD.exa MB02ID.exa: MB02ID.dat TMB02ID; ./TMB02ID MB02ID.exa MB02JD.exa: MB02JD.dat TMB02JD; ./TMB02JD MB02JD.exa MB02JX.exa: MB02JX.dat TMB02JX; ./TMB02JX MB02JX.exa MB02KD.exa: MB02KD.dat TMB02KD; ./TMB02KD MB02KD.exa MB02MD.exa: MB02MD.dat TMB02MD; ./TMB02MD MB02MD.exa MB02ND.exa: MB02ND.dat TMB02ND; ./TMB02ND MB02ND.exa MB02QD.exa: MB02QD.dat TMB02QD; ./TMB02QD MB02QD.exa MB02SD.exa: MB02SD.dat TMB02SD; ./TMB02SD MB02SD.exa MB02VD.exa: MB02VD.dat TMB02VD; ./TMB02VD MB02VD.exa MB03MD.exa: MB03MD.dat TMB03MD; ./TMB03MD MB03MD.exa MB03ND.exa: MB03ND.dat TMB03ND; ./TMB03ND MB03ND.exa MB03OD.exa: MB03OD.dat TMB03OD; ./TMB03OD MB03OD.exa MB03PD.exa: MB03PD.dat TMB03PD; ./TMB03PD MB03PD.exa MB03QD.exa: MB03QD.dat TMB03QD; ./TMB03QD MB03QD.exa MB03RD.exa: MB03RD.dat TMB03RD; ./TMB03RD MB03RD.exa MB03SD.exa: MB03SD.dat TMB03SD; ./TMB03SD MB03SD.exa MB03UD.exa: MB03UD.dat TMB03UD; ./TMB03UD MB03UD.exa MB03VD.exa: MB03VD.dat TMB03VD; ./TMB03VD MB03VD.exa MB03WD.exa: MB03WD.dat TMB03WD; ./TMB03WD MB03WD.exa MB04DY.exa: MB04DY.dat TMB04DY; ./TMB04DY MB04DY.exa MB04GD.exa: MB04GD.dat TMB04GD; ./TMB04GD MB04GD.exa MB04MD.exa: MB04MD.dat TMB04MD; ./TMB04MD MB04MD.exa MB04OD.exa: MB04OD.dat TMB04OD; ./TMB04OD MB04OD.exa MB04UD.exa: MB04UD.dat TMB04UD; ./TMB04UD MB04UD.exa MB04VD.exa: MB04VD.dat TMB04VD; ./TMB04VD MB04VD.exa MB04XD.exa: MB04XD.dat TMB04XD; ./TMB04XD MB04XD.exa MB04YD.exa: MB04YD.dat TMB04YD; ./TMB04YD MB04YD.exa MB04ZD.exa: MB04ZD.dat TMB04ZD; ./TMB04ZD MB04ZD.exa MB05MD.exa: MB05MD.dat TMB05MD; ./TMB05MD MB05MD.exa MB05ND.exa: MB05ND.dat TMB05ND; ./TMB05ND MB05ND.exa MB05OD.exa: MB05OD.dat TMB05OD; ./TMB05OD MB05OD.exa MC01MD.exa: MC01MD.dat TMC01MD; ./TMC01MD MC01MD.exa MC01ND.exa: MC01ND.dat TMC01ND; ./TMC01ND MC01ND.exa MC01OD.exa: MC01OD.dat TMC01OD; ./TMC01OD MC01OD.exa MC01PD.exa: MC01PD.dat TMC01PD; ./TMC01PD MC01PD.exa MC01QD.exa: MC01QD.dat TMC01QD; ./TMC01QD MC01QD.exa MC01RD.exa: MC01RD.dat TMC01RD; ./TMC01RD MC01RD.exa MC01SD.exa: MC01SD.dat TMC01SD; ./TMC01SD MC01SD.exa MC01TD.exa: MC01TD.dat TMC01TD; ./TMC01TD MC01TD.exa MC01VD.exa: MC01VD.dat TMC01VD; ./TMC01VD MC01VD.exa MC01WD.exa: MC01WD.dat TMC01WD; ./TMC01WD MC01WD.exa MC03MD.exa: MC03MD.dat TMC03MD; ./TMC03MD MC03MD.exa MC03ND.exa: MC03ND.dat TMC03ND; ./TMC03ND MC03ND.exa MD03AD.exa: MD03AD.dat TMD03AD; ./TMD03AD MD03AD.exa MD03BD.exa: MD03BD.dat TMD03BD; ./TMD03BD MD03BD.exa SB01BD.exa: SB01BD.dat TSB01BD; ./TSB01BD SB01BD.exa SB01DD.exa: SB01DD.dat TSB01DD; ./TSB01DD SB01DD.exa SB01MD.exa: SB01MD.dat TSB01MD; ./TSB01MD SB01MD.exa SB02MD.exa: SB02MD.dat TSB02MD; ./TSB02MD SB02MD.exa SB02ND.exa: SB02ND.dat TSB02ND; ./TSB02ND SB02ND.exa SB02OD.exa: SB02OD.dat TSB02OD; ./TSB02OD SB02OD.exa SB02PD.exa: SB02PD.dat TSB02PD; ./TSB02PD SB02PD.exa SB02QD.exa: SB02QD.dat TSB02QD; ./TSB02QD SB02QD.exa SB02RD.exa: SB02RD.dat TSB02RD; ./TSB02RD SB02RD.exa SB02SD.exa: SB02SD.dat TSB02SD; ./TSB02SD SB02SD.exa SB03MD.exa: SB03MD.dat TSB03MD; ./TSB03MD SB03MD.exa SB03OD.exa: SB03OD.dat TSB03OD; ./TSB03OD SB03OD.exa SB03QD.exa: SB03QD.dat TSB03QD; ./TSB03QD SB03QD.exa SB03SD.exa: SB03SD.dat TSB03SD; ./TSB03SD SB03SD.exa SB03TD.exa: SB03TD.dat TSB03TD; ./TSB03TD SB03TD.exa SB03UD.exa: SB03UD.dat TSB03UD; ./TSB03UD SB03UD.exa SB04MD.exa: SB04MD.dat TSB04MD; ./TSB04MD SB04MD.exa SB04ND.exa: SB04ND.dat TSB04ND; ./TSB04ND SB04ND.exa SB04OD.exa: SB04OD.dat TSB04OD; ./TSB04OD SB04OD.exa SB04PD.exa: SB04PD.dat TSB04PD; ./TSB04PD SB04PD.exa SB04QD.exa: SB04QD.dat TSB04QD; ./TSB04QD SB04QD.exa SB04RD.exa: SB04RD.dat TSB04RD; ./TSB04RD SB04RD.exa SB06ND.exa: SB06ND.dat TSB06ND; ./TSB06ND SB06ND.exa SB08CD.exa: SB08CD.dat TSB08CD; ./TSB08CD SB08CD.exa SB08DD.exa: SB08DD.dat TSB08DD; ./TSB08DD SB08DD.exa SB08ED.exa: SB08ED.dat TSB08ED; ./TSB08ED SB08ED.exa SB08FD.exa: SB08FD.dat TSB08FD; ./TSB08FD SB08FD.exa SB08MD.exa: SB08MD.dat TSB08MD; ./TSB08MD SB08MD.exa SB08ND.exa: SB08ND.dat TSB08ND; ./TSB08ND SB08ND.exa SB09MD.exa: SB09MD.dat TSB09MD; ./TSB09MD SB09MD.exa SB10DD.exa: SB10DD.dat TSB10DD; ./TSB10DD SB10DD.exa SB10ED.exa: SB10ED.dat TSB10ED; ./TSB10ED SB10ED.exa SB10FD.exa: SB10FD.dat TSB10FD; ./TSB10FD SB10FD.exa SB10HD.exa: SB10HD.dat TSB10HD; ./TSB10HD SB10HD.exa SB10ID.exa: SB10ID.dat TSB10ID; ./TSB10ID SB10ID.exa SB10KD.exa: SB10KD.dat TSB10KD; ./TSB10KD SB10KD.exa SB10ZD.exa: SB10ZD.dat TSB10ZD; ./TSB10ZD SB10ZD.exa SB16AD.exa: SB16AD.dat TSB16AD; ./TSB16AD SB16AD.exa SB16BD.exa: SB16BD.dat TSB16BD; ./TSB16BD SB16BD.exa SB16CD.exa: SB16CD.dat TSB16CD; ./TSB16CD SB16CD.exa SG02AD.exa: SG02AD.dat TSG02AD; ./TSG02AD SG02AD.exa SG03AD.exa: SG03AD.dat TSG03AD; ./TSG03AD SG03AD.exa SG03BD.exa: SG03BD.dat TSG03BD; ./TSG03BD SG03BD.exa TB01ID.exa: TB01ID.dat TTB01ID; ./TTB01ID TB01ID.exa TB01KD.exa: TB01KD.dat TTB01KD; ./TTB01KD TB01KD.exa TB01LD.exa: TB01LD.dat TTB01LD; ./TTB01LD TB01LD.exa TB01MD.exa: TB01MD.dat TTB01MD; ./TTB01MD TB01MD.exa TB01ND.exa: TB01ND.dat TTB01ND; ./TTB01ND TB01ND.exa TB01PD.exa: TB01PD.dat TTB01PD; ./TTB01PD TB01PD.exa TB01TD.exa: TB01TD.dat TTB01TD; ./TTB01TD TB01TD.exa TB01UD.exa: TB01UD.dat TTB01UD; ./TTB01UD TB01UD.exa TB01WD.exa: TB01WD.dat TTB01WD; ./TTB01WD TB01WD.exa TB01ZD.exa: TB01ZD.dat TTB01ZD; ./TTB01ZD TB01ZD.exa TB03AD.exa: TB03AD.dat TTB03AD; ./TTB03AD TB03AD.exa TB04AD.exa: TB04AD.dat TTB04AD; ./TTB04AD TB04AD.exa TB04BD.exa: TB04BD.dat TTB04BD; ./TTB04BD TB04BD.exa TB04CD.exa: TB04CD.dat TTB04CD; ./TTB04CD TB04CD.exa TB05AD.exa: TB05AD.dat TTB05AD; ./TTB05AD TB05AD.exa TC01OD.exa: TC01OD.dat TTC01OD; ./TTC01OD TC01OD.exa TC04AD.exa: TC04AD.dat TTC04AD; ./TTC04AD TC04AD.exa TC05AD.exa: TC05AD.dat TTC05AD; ./TTC05AD TC05AD.exa TD03AD.exa: TD03AD.dat TTD03AD; ./TTD03AD TD03AD.exa TD04AD.exa: TD04AD.dat TTD04AD; ./TTD04AD TD04AD.exa TD05AD.exa: TD05AD.dat TTD05AD; ./TTD05AD TD05AD.exa TF01MD.exa: TF01MD.dat TTF01MD; ./TTF01MD TF01MD.exa TF01ND.exa: TF01ND.dat TTF01ND; ./TTF01ND TF01ND.exa TF01OD.exa: TF01OD.dat TTF01OD; ./TTF01OD TF01OD.exa TF01PD.exa: TF01PD.dat TTF01PD; ./TTF01PD TF01PD.exa TF01QD.exa: TF01QD.dat TTF01QD; ./TTF01QD TF01QD.exa TF01RD.exa: TF01RD.dat TTF01RD; ./TTF01RD TF01RD.exa TG01AD.exa: TG01AD.dat TTG01AD; ./TTG01AD TG01AD.exa TG01CD.exa: TG01CD.dat TTG01CD; ./TTG01CD TG01CD.exa TG01DD.exa: TG01DD.dat TTG01DD; ./TTG01DD TG01DD.exa TG01ED.exa: TG01ED.dat TTG01ED; ./TTG01ED TG01ED.exa TG01FD.exa: TG01FD.dat TTG01FD; ./TTG01FD TG01FD.exa TG01HD.exa: TG01HD.dat TTG01HD; ./TTG01HD TG01HD.exa TG01ID.exa: TG01ID.dat TTG01ID; ./TTG01ID TG01ID.exa TG01JD.exa: TG01JD.dat TTG01JD; ./TTG01JD TG01JD.exa UD01BD.exa: UD01BD.dat TUD01BD; ./TUD01BD UD01BD.exa UD01CD.exa: UD01CD.dat TUD01CD; ./TUD01CD UD01CD.exa UD01DD.exa: UD01DD.dat TUD01DD; ./TUD01DD UD01DD.exa UD01MD.exa: UD01MD.dat TUD01MD; ./TUD01MD UD01MD.exa UD01ND.exa: UD01ND.dat TUD01ND; ./TUD01ND UD01ND.exa MB03TD.exa: MB03TD.dat TMB03TD; ./TMB03TD MB03TD.exa MB03XD.exa: MB03XD.dat TMB03XD; ./TMB03XD MB03XD.exa MB03XP.exa: MB03XP.dat TMB03XP; ./TMB03XP MB03XP.exa MB03ZD.exa: MB03ZD.dat TMB03ZD; ./TMB03ZD MB03ZD.exa MB04DD.exa: MB04DD.dat TMB04DD; ./TMB04DD MB04DD.exa MB04DS.exa: MB04DS.dat TMB04DS; ./TMB04DS MB04DS.exa MB04PB.exa: MB04PB.dat TMB04PB; ./TMB04PB MB04PB.exa MB04PU.exa: MB04PU.dat TMB04PU; ./TMB04PU MB04PU.exa MB04TB.exa: MB04TB.dat TMB04TB; ./TMB04TB MB04TB.exa MB04TS.exa: MB04TS.dat TMB04TS; ./TMB04TS MB04TS.exa AB08NZ.exa: AB08NZ.dat TAB08NZ; ./TAB08NZ AB08NZ.exa AG08BZ.exa: AG08BZ.dat TAG08BZ; ./TAG08BZ AG08BZ.exa TB01IZ.exa: TB01IZ.dat TTB01IZ; ./TTB01IZ TB01IZ.exa TG01AZ.exa: TG01AZ.dat TTG01AZ; ./TTG01AZ TG01AZ.exa TG01FZ.exa: TG01FZ.dat TTG01FZ; ./TTG01FZ TG01FZ.exa MB03BD.exa: MB03BD.dat TMB03BD; ./TMB03BD MB03BD.exa MB03KD.exa: MB03KD.dat TMB03KD; ./TMB03KD MB03KD.exa MB03LD.exa: MB03LD.dat TMB03LD; ./TMB03LD MB03LD.exa MB04AD.exa: MB04AD.dat TMB04AD; ./TMB04AD MB04AD.exa MB04BD.exa: MB04BD.dat TMB04BD; ./TMB04BD MB04BD.exa TAB01MD: TAB01MD.o ; $(LOADER) -o TAB01MD TAB01MD.o $(LOADOPTS) TAB01ND: TAB01ND.o ; $(LOADER) -o TAB01ND TAB01ND.o $(LOADOPTS) TAB01OD: TAB01OD.o ; $(LOADER) -o TAB01OD TAB01OD.o $(LOADOPTS) TAB04MD: TAB04MD.o ; $(LOADER) -o TAB04MD TAB04MD.o $(LOADOPTS) TAB05MD: TAB05MD.o ; $(LOADER) -o TAB05MD TAB05MD.o $(LOADOPTS) TAB05ND: TAB05ND.o ; $(LOADER) -o TAB05ND TAB05ND.o $(LOADOPTS) TAB05OD: TAB05OD.o ; $(LOADER) -o TAB05OD TAB05OD.o $(LOADOPTS) TAB05PD: TAB05PD.o ; $(LOADER) -o TAB05PD TAB05PD.o $(LOADOPTS) TAB05QD: TAB05QD.o ; $(LOADER) -o TAB05QD TAB05QD.o $(LOADOPTS) TAB05RD: TAB05RD.o ; $(LOADER) -o TAB05RD TAB05RD.o $(LOADOPTS) TAB07MD: TAB07MD.o ; $(LOADER) -o TAB07MD TAB07MD.o $(LOADOPTS) TAB07ND: TAB07ND.o ; $(LOADER) -o TAB07ND TAB07ND.o $(LOADOPTS) TAB08ND: TAB08ND.o ; $(LOADER) -o TAB08ND TAB08ND.o $(LOADOPTS) TAB09AD: TAB09AD.o ; $(LOADER) -o TAB09AD TAB09AD.o $(LOADOPTS) TAB09BD: TAB09BD.o ; $(LOADER) -o TAB09BD TAB09BD.o $(LOADOPTS) TAB09CD: TAB09CD.o ; $(LOADER) -o TAB09CD TAB09CD.o $(LOADOPTS) TAB09DD: TAB09DD.o ; $(LOADER) -o TAB09DD TAB09DD.o $(LOADOPTS) TAB09ED: TAB09ED.o ; $(LOADER) -o TAB09ED TAB09ED.o $(LOADOPTS) TAB09FD: TAB09FD.o ; $(LOADER) -o TAB09FD TAB09FD.o $(LOADOPTS) TAB09GD: TAB09GD.o ; $(LOADER) -o TAB09GD TAB09GD.o $(LOADOPTS) TAB09HD: TAB09HD.o ; $(LOADER) -o TAB09HD TAB09HD.o $(LOADOPTS) TAB09ID: TAB09ID.o ; $(LOADER) -o TAB09ID TAB09ID.o $(LOADOPTS) TAB09JD: TAB09JD.o ; $(LOADER) -o TAB09JD TAB09JD.o $(LOADOPTS) TAB09KD: TAB09KD.o ; $(LOADER) -o TAB09KD TAB09KD.o $(LOADOPTS) TAB09MD: TAB09MD.o ; $(LOADER) -o TAB09MD TAB09MD.o $(LOADOPTS) TAB09ND: TAB09ND.o ; $(LOADER) -o TAB09ND TAB09ND.o $(LOADOPTS) TAB13AD: TAB13AD.o ; $(LOADER) -o TAB13AD TAB13AD.o $(LOADOPTS) TAB13BD: TAB13BD.o ; $(LOADER) -o TAB13BD TAB13BD.o $(LOADOPTS) TAB13CD: TAB13CD.o ; $(LOADER) -o TAB13CD TAB13CD.o $(LOADOPTS) TAB13DD: TAB13DD.o ; $(LOADER) -o TAB13DD TAB13DD.o $(LOADOPTS) TAB13ED: TAB13ED.o ; $(LOADER) -o TAB13ED TAB13ED.o $(LOADOPTS) TAB13FD: TAB13FD.o ; $(LOADER) -o TAB13FD TAB13FD.o $(LOADOPTS) TAB13MD: TAB13MD.o ; $(LOADER) -o TAB13MD TAB13MD.o $(LOADOPTS) TAG08BD: TAG08BD.o ; $(LOADER) -o TAG08BD TAG08BD.o $(LOADOPTS) TBB01AD: TBB01AD.o ; $(LOADER) -o TBB01AD TBB01AD.o $(LOADOPTS) TBB02AD: TBB02AD.o ; $(LOADER) -o TBB02AD TBB02AD.o $(LOADOPTS) TBB03AD: TBB03AD.o ; $(LOADER) -o TBB03AD TBB03AD.o $(LOADOPTS) TBB04AD: TBB04AD.o ; $(LOADER) -o TBB04AD TBB04AD.o $(LOADOPTS) TBD01AD: TBD01AD.o ; $(LOADER) -o TBD01AD TBD01AD.o $(LOADOPTS) TBD02AD: TBD02AD.o ; $(LOADER) -o TBD02AD TBD02AD.o $(LOADOPTS) TDE01OD: TDE01OD.o ; $(LOADER) -o TDE01OD TDE01OD.o $(LOADOPTS) TDE01PD: TDE01PD.o ; $(LOADER) -o TDE01PD TDE01PD.o $(LOADOPTS) TDF01MD: TDF01MD.o ; $(LOADER) -o TDF01MD TDF01MD.o $(LOADOPTS) TDG01MD: TDG01MD.o ; $(LOADER) -o TDG01MD TDG01MD.o $(LOADOPTS) TDG01ND: TDG01ND.o ; $(LOADER) -o TDG01ND TDG01ND.o $(LOADOPTS) TDG01OD: TDG01OD.o ; $(LOADER) -o TDG01OD TDG01OD.o $(LOADOPTS) TDK01MD: TDK01MD.o ; $(LOADER) -o TDK01MD TDK01MD.o $(LOADOPTS) TFB01QD: TFB01QD.o ; $(LOADER) -o TFB01QD TFB01QD.o $(LOADOPTS) TFB01RD: TFB01RD.o ; $(LOADER) -o TFB01RD TFB01RD.o $(LOADOPTS) TFB01SD: TFB01SD.o ; $(LOADER) -o TFB01SD TFB01SD.o $(LOADOPTS) TFB01TD: TFB01TD.o ; $(LOADER) -o TFB01TD TFB01TD.o $(LOADOPTS) TFB01VD: TFB01VD.o ; $(LOADER) -o TFB01VD TFB01VD.o $(LOADOPTS) TFD01AD: TFD01AD.o ; $(LOADER) -o TFD01AD TFD01AD.o $(LOADOPTS) TIB01AD: TIB01AD.o ; $(LOADER) -o TIB01AD TIB01AD.o $(LOADOPTS) TIB01BD: TIB01BD.o ; $(LOADER) -o TIB01BD TIB01BD.o $(LOADOPTS) TIB01CD: TIB01CD.o ; $(LOADER) -o TIB01CD TIB01CD.o $(LOADOPTS) TIB03AD: TIB03AD.o ; $(LOADER) -o TIB03AD TIB03AD.o $(LOADOPTS) TIB03BD: TIB03BD.o ; $(LOADER) -o TIB03BD TIB03BD.o $(LOADOPTS) TMB01TD: TMB01TD.o ; $(LOADER) -o TMB01TD TMB01TD.o $(LOADOPTS) TMB02CD: TMB02CD.o ; $(LOADER) -o TMB02CD TMB02CD.o $(LOADOPTS) TMB02DD: TMB02DD.o ; $(LOADER) -o TMB02DD TMB02DD.o $(LOADOPTS) TMB02ED: TMB02ED.o ; $(LOADER) -o TMB02ED TMB02ED.o $(LOADOPTS) TMB02FD: TMB02FD.o ; $(LOADER) -o TMB02FD TMB02FD.o $(LOADOPTS) TMB02GD: TMB02GD.o ; $(LOADER) -o TMB02GD TMB02GD.o $(LOADOPTS) TMB02HD: TMB02HD.o ; $(LOADER) -o TMB02HD TMB02HD.o $(LOADOPTS) TMB02ID: TMB02ID.o ; $(LOADER) -o TMB02ID TMB02ID.o $(LOADOPTS) TMB02JD: TMB02JD.o ; $(LOADER) -o TMB02JD TMB02JD.o $(LOADOPTS) TMB02JX: TMB02JX.o ; $(LOADER) -o TMB02JX TMB02JX.o $(LOADOPTS) TMB02KD: TMB02KD.o ; $(LOADER) -o TMB02KD TMB02KD.o $(LOADOPTS) TMB02MD: TMB02MD.o ; $(LOADER) -o TMB02MD TMB02MD.o $(LOADOPTS) TMB02ND: TMB02ND.o ; $(LOADER) -o TMB02ND TMB02ND.o $(LOADOPTS) TMB02QD: TMB02QD.o ; $(LOADER) -o TMB02QD TMB02QD.o $(LOADOPTS) TMB02SD: TMB02SD.o ; $(LOADER) -o TMB02SD TMB02SD.o $(LOADOPTS) TMB02VD: TMB02VD.o ; $(LOADER) -o TMB02VD TMB02VD.o $(LOADOPTS) TMB03MD: TMB03MD.o ; $(LOADER) -o TMB03MD TMB03MD.o $(LOADOPTS) TMB03ND: TMB03ND.o ; $(LOADER) -o TMB03ND TMB03ND.o $(LOADOPTS) TMB03OD: TMB03OD.o ; $(LOADER) -o TMB03OD TMB03OD.o $(LOADOPTS) TMB03PD: TMB03PD.o ; $(LOADER) -o TMB03PD TMB03PD.o $(LOADOPTS) TMB03QD: TMB03QD.o ; $(LOADER) -o TMB03QD TMB03QD.o $(LOADOPTS) TMB03RD: TMB03RD.o ; $(LOADER) -o TMB03RD TMB03RD.o $(LOADOPTS) TMB03SD: TMB03SD.o ; $(LOADER) -o TMB03SD TMB03SD.o $(LOADOPTS) TMB03UD: TMB03UD.o ; $(LOADER) -o TMB03UD TMB03UD.o $(LOADOPTS) TMB03VD: TMB03VD.o ; $(LOADER) -o TMB03VD TMB03VD.o $(LOADOPTS) TMB03WD: TMB03WD.o ; $(LOADER) -o TMB03WD TMB03WD.o $(LOADOPTS) TMB04DY: TMB04DY.o ; $(LOADER) -o TMB04DY TMB04DY.o $(LOADOPTS) TMB04GD: TMB04GD.o ; $(LOADER) -o TMB04GD TMB04GD.o $(LOADOPTS) TMB04MD: TMB04MD.o ; $(LOADER) -o TMB04MD TMB04MD.o $(LOADOPTS) TMB04OD: TMB04OD.o ; $(LOADER) -o TMB04OD TMB04OD.o $(LOADOPTS) TMB04UD: TMB04UD.o ; $(LOADER) -o TMB04UD TMB04UD.o $(LOADOPTS) TMB04VD: TMB04VD.o ; $(LOADER) -o TMB04VD TMB04VD.o $(LOADOPTS) TMB04XD: TMB04XD.o ; $(LOADER) -o TMB04XD TMB04XD.o $(LOADOPTS) TMB04YD: TMB04YD.o ; $(LOADER) -o TMB04YD TMB04YD.o $(LOADOPTS) TMB04ZD: TMB04ZD.o ; $(LOADER) -o TMB04ZD TMB04ZD.o $(LOADOPTS) TMB05MD: TMB05MD.o ; $(LOADER) -o TMB05MD TMB05MD.o $(LOADOPTS) TMB05ND: TMB05ND.o ; $(LOADER) -o TMB05ND TMB05ND.o $(LOADOPTS) TMB05OD: TMB05OD.o ; $(LOADER) -o TMB05OD TMB05OD.o $(LOADOPTS) TMC01MD: TMC01MD.o ; $(LOADER) -o TMC01MD TMC01MD.o $(LOADOPTS) TMC01ND: TMC01ND.o ; $(LOADER) -o TMC01ND TMC01ND.o $(LOADOPTS) TMC01OD: TMC01OD.o ; $(LOADER) -o TMC01OD TMC01OD.o $(LOADOPTS) TMC01PD: TMC01PD.o ; $(LOADER) -o TMC01PD TMC01PD.o $(LOADOPTS) TMC01QD: TMC01QD.o ; $(LOADER) -o TMC01QD TMC01QD.o $(LOADOPTS) TMC01RD: TMC01RD.o ; $(LOADER) -o TMC01RD TMC01RD.o $(LOADOPTS) TMC01SD: TMC01SD.o ; $(LOADER) -o TMC01SD TMC01SD.o $(LOADOPTS) TMC01TD: TMC01TD.o ; $(LOADER) -o TMC01TD TMC01TD.o $(LOADOPTS) TMC01VD: TMC01VD.o ; $(LOADER) -o TMC01VD TMC01VD.o $(LOADOPTS) TMC01WD: TMC01WD.o ; $(LOADER) -o TMC01WD TMC01WD.o $(LOADOPTS) TMC03MD: TMC03MD.o ; $(LOADER) -o TMC03MD TMC03MD.o $(LOADOPTS) TMC03ND: TMC03ND.o ; $(LOADER) -o TMC03ND TMC03ND.o $(LOADOPTS) TMD03AD: TMD03AD.o ; $(LOADER) -o TMD03AD TMD03AD.o $(LOADOPTS) TMD03BD: TMD03BD.o ; $(LOADER) -o TMD03BD TMD03BD.o $(LOADOPTS) TSB01BD: TSB01BD.o ; $(LOADER) -o TSB01BD TSB01BD.o $(LOADOPTS) TSB01DD: TSB01DD.o ; $(LOADER) -o TSB01DD TSB01DD.o $(LOADOPTS) TSB01MD: TSB01MD.o ; $(LOADER) -o TSB01MD TSB01MD.o $(LOADOPTS) TSB02MD: TSB02MD.o ; $(LOADER) -o TSB02MD TSB02MD.o $(LOADOPTS) TSB02ND: TSB02ND.o ; $(LOADER) -o TSB02ND TSB02ND.o $(LOADOPTS) TSB02OD: TSB02OD.o ; $(LOADER) -o TSB02OD TSB02OD.o $(LOADOPTS) TSB02PD: TSB02PD.o ; $(LOADER) -o TSB02PD TSB02PD.o $(LOADOPTS) TSB02QD: TSB02QD.o ; $(LOADER) -o TSB02QD TSB02QD.o $(LOADOPTS) TSB02RD: TSB02RD.o ; $(LOADER) -o TSB02RD TSB02RD.o $(LOADOPTS) TSB02SD: TSB02SD.o ; $(LOADER) -o TSB02SD TSB02SD.o $(LOADOPTS) TSB03MD: TSB03MD.o ; $(LOADER) -o TSB03MD TSB03MD.o $(LOADOPTS) TSB03OD: TSB03OD.o ; $(LOADER) -o TSB03OD TSB03OD.o $(LOADOPTS) TSB03QD: TSB03QD.o ; $(LOADER) -o TSB03QD TSB03QD.o $(LOADOPTS) TSB03SD: TSB03SD.o ; $(LOADER) -o TSB03SD TSB03SD.o $(LOADOPTS) TSB03TD: TSB03TD.o ; $(LOADER) -o TSB03TD TSB03TD.o $(LOADOPTS) TSB03UD: TSB03UD.o ; $(LOADER) -o TSB03UD TSB03UD.o $(LOADOPTS) TSB04MD: TSB04MD.o ; $(LOADER) -o TSB04MD TSB04MD.o $(LOADOPTS) TSB04ND: TSB04ND.o ; $(LOADER) -o TSB04ND TSB04ND.o $(LOADOPTS) TSB04OD: TSB04OD.o ; $(LOADER) -o TSB04OD TSB04OD.o $(LOADOPTS) TSB04PD: TSB04PD.o ; $(LOADER) -o TSB04PD TSB04PD.o $(LOADOPTS) TSB04QD: TSB04QD.o ; $(LOADER) -o TSB04QD TSB04QD.o $(LOADOPTS) TSB04RD: TSB04RD.o ; $(LOADER) -o TSB04RD TSB04RD.o $(LOADOPTS) TSB06ND: TSB06ND.o ; $(LOADER) -o TSB06ND TSB06ND.o $(LOADOPTS) TSB08CD: TSB08CD.o ; $(LOADER) -o TSB08CD TSB08CD.o $(LOADOPTS) TSB08DD: TSB08DD.o ; $(LOADER) -o TSB08DD TSB08DD.o $(LOADOPTS) TSB08ED: TSB08ED.o ; $(LOADER) -o TSB08ED TSB08ED.o $(LOADOPTS) TSB08FD: TSB08FD.o ; $(LOADER) -o TSB08FD TSB08FD.o $(LOADOPTS) TSB08MD: TSB08MD.o ; $(LOADER) -o TSB08MD TSB08MD.o $(LOADOPTS) TSB08ND: TSB08ND.o ; $(LOADER) -o TSB08ND TSB08ND.o $(LOADOPTS) TSB09MD: TSB09MD.o ; $(LOADER) -o TSB09MD TSB09MD.o $(LOADOPTS) TSB10DD: TSB10DD.o ; $(LOADER) -o TSB10DD TSB10DD.o $(LOADOPTS) TSB10ED: TSB10ED.o ; $(LOADER) -o TSB10ED TSB10ED.o $(LOADOPTS) TSB10FD: TSB10FD.o ; $(LOADER) -o TSB10FD TSB10FD.o $(LOADOPTS) TSB10HD: TSB10HD.o ; $(LOADER) -o TSB10HD TSB10HD.o $(LOADOPTS) TSB10ID: TSB10ID.o ; $(LOADER) -o TSB10ID TSB10ID.o $(LOADOPTS) TSB10KD: TSB10KD.o ; $(LOADER) -o TSB10KD TSB10KD.o $(LOADOPTS) TSB10ZD: TSB10ZD.o ; $(LOADER) -o TSB10ZD TSB10ZD.o $(LOADOPTS) TSB16AD: TSB16AD.o ; $(LOADER) -o TSB16AD TSB16AD.o $(LOADOPTS) TSB16BD: TSB16BD.o ; $(LOADER) -o TSB16BD TSB16BD.o $(LOADOPTS) TSB16CD: TSB16CD.o ; $(LOADER) -o TSB16CD TSB16CD.o $(LOADOPTS) TSG02AD: TSG02AD.o ; $(LOADER) -o TSG02AD TSG02AD.o $(LOADOPTS) TSG03AD: TSG03AD.o ; $(LOADER) -o TSG03AD TSG03AD.o $(LOADOPTS) TSG03BD: TSG03BD.o ; $(LOADER) -o TSG03BD TSG03BD.o $(LOADOPTS) TTB01ID: TTB01ID.o ; $(LOADER) -o TTB01ID TTB01ID.o $(LOADOPTS) TTB01KD: TTB01KD.o ; $(LOADER) -o TTB01KD TTB01KD.o $(LOADOPTS) TTB01LD: TTB01LD.o ; $(LOADER) -o TTB01LD TTB01LD.o $(LOADOPTS) TTB01MD: TTB01MD.o ; $(LOADER) -o TTB01MD TTB01MD.o $(LOADOPTS) TTB01ND: TTB01ND.o ; $(LOADER) -o TTB01ND TTB01ND.o $(LOADOPTS) TTB01PD: TTB01PD.o ; $(LOADER) -o TTB01PD TTB01PD.o $(LOADOPTS) TTB01TD: TTB01TD.o ; $(LOADER) -o TTB01TD TTB01TD.o $(LOADOPTS) TTB01UD: TTB01UD.o ; $(LOADER) -o TTB01UD TTB01UD.o $(LOADOPTS) TTB01WD: TTB01WD.o ; $(LOADER) -o TTB01WD TTB01WD.o $(LOADOPTS) TTB01ZD: TTB01ZD.o ; $(LOADER) -o TTB01ZD TTB01ZD.o $(LOADOPTS) TTB03AD: TTB03AD.o ; $(LOADER) -o TTB03AD TTB03AD.o $(LOADOPTS) TTB04AD: TTB04AD.o ; $(LOADER) -o TTB04AD TTB04AD.o $(LOADOPTS) TTB04BD: TTB04BD.o ; $(LOADER) -o TTB04BD TTB04BD.o $(LOADOPTS) TTB04CD: TTB04CD.o ; $(LOADER) -o TTB04CD TTB04CD.o $(LOADOPTS) TTB05AD: TTB05AD.o ; $(LOADER) -o TTB05AD TTB05AD.o $(LOADOPTS) TTC01OD: TTC01OD.o ; $(LOADER) -o TTC01OD TTC01OD.o $(LOADOPTS) TTC04AD: TTC04AD.o ; $(LOADER) -o TTC04AD TTC04AD.o $(LOADOPTS) TTC05AD: TTC05AD.o ; $(LOADER) -o TTC05AD TTC05AD.o $(LOADOPTS) TTD03AD: TTD03AD.o ; $(LOADER) -o TTD03AD TTD03AD.o $(LOADOPTS) TTD04AD: TTD04AD.o ; $(LOADER) -o TTD04AD TTD04AD.o $(LOADOPTS) TTD05AD: TTD05AD.o ; $(LOADER) -o TTD05AD TTD05AD.o $(LOADOPTS) TTF01MD: TTF01MD.o ; $(LOADER) -o TTF01MD TTF01MD.o $(LOADOPTS) TTF01ND: TTF01ND.o ; $(LOADER) -o TTF01ND TTF01ND.o $(LOADOPTS) TTF01OD: TTF01OD.o ; $(LOADER) -o TTF01OD TTF01OD.o $(LOADOPTS) TTF01PD: TTF01PD.o ; $(LOADER) -o TTF01PD TTF01PD.o $(LOADOPTS) TTF01QD: TTF01QD.o ; $(LOADER) -o TTF01QD TTF01QD.o $(LOADOPTS) TTF01RD: TTF01RD.o ; $(LOADER) -o TTF01RD TTF01RD.o $(LOADOPTS) TTG01AD: TTG01AD.o ; $(LOADER) -o TTG01AD TTG01AD.o $(LOADOPTS) TTG01CD: TTG01CD.o ; $(LOADER) -o TTG01CD TTG01CD.o $(LOADOPTS) TTG01DD: TTG01DD.o ; $(LOADER) -o TTG01DD TTG01DD.o $(LOADOPTS) TTG01ED: TTG01ED.o ; $(LOADER) -o TTG01ED TTG01ED.o $(LOADOPTS) TTG01FD: TTG01FD.o ; $(LOADER) -o TTG01FD TTG01FD.o $(LOADOPTS) TTG01HD: TTG01HD.o ; $(LOADER) -o TTG01HD TTG01HD.o $(LOADOPTS) TTG01ID: TTG01ID.o ; $(LOADER) -o TTG01ID TTG01ID.o $(LOADOPTS) TTG01JD: TTG01JD.o ; $(LOADER) -o TTG01JD TTG01JD.o $(LOADOPTS) TUD01BD: TUD01BD.o ; $(LOADER) -o TUD01BD TUD01BD.o $(LOADOPTS) TUD01CD: TUD01CD.o ; $(LOADER) -o TUD01CD TUD01CD.o $(LOADOPTS) TUD01DD: TUD01DD.o ; $(LOADER) -o TUD01DD TUD01DD.o $(LOADOPTS) TUD01MD: TUD01MD.o ; $(LOADER) -o TUD01MD TUD01MD.o $(LOADOPTS) TUD01ND: TUD01ND.o ; $(LOADER) -o TUD01ND TUD01ND.o $(LOADOPTS) TMB03TD: TMB03TD.o ; $(LOADER) -o TMB03TD TMB03TD.o $(LOADOPTS) TMB03XD: TMB03XD.o ; $(LOADER) -o TMB03XD TMB03XD.o $(LOADOPTS) TMB03XP: TMB03XP.o ; $(LOADER) -o TMB03XP TMB03XP.o $(LOADOPTS) TMB03ZD: TMB03ZD.o ; $(LOADER) -o TMB03ZD TMB03ZD.o $(LOADOPTS) TMB04DD: TMB04DD.o ; $(LOADER) -o TMB04DD TMB04DD.o $(LOADOPTS) TMB04DS: TMB04DS.o ; $(LOADER) -o TMB04DS TMB04DS.o $(LOADOPTS) TMB04PB: TMB04PB.o ; $(LOADER) -o TMB04PB TMB04PB.o $(LOADOPTS) TMB04PU: TMB04PU.o ; $(LOADER) -o TMB04PU TMB04PU.o $(LOADOPTS) TMB04TB: TMB04TB.o ; $(LOADER) -o TMB04TB TMB04TB.o $(LOADOPTS) TMB04TS: TMB04TS.o ; $(LOADER) -o TMB04TS TMB04TS.o $(LOADOPTS) TAB08NZ: TAB08NZ.o ; $(LOADER) -o TAB08NZ TAB08NZ.o $(LOADOPTS) TAG08BZ: TAG08BZ.o ; $(LOADER) -o TAG08BZ TAG08BZ.o $(LOADOPTS) TTB01IZ: TTB01IZ.o ; $(LOADER) -o TTB01IZ TTB01IZ.o $(LOADOPTS) TTG01AZ: TTG01AZ.o ; $(LOADER) -o TTG01AZ TTG01AZ.o $(LOADOPTS) TTG01FZ: TTG01FZ.o ; $(LOADER) -o TTG01FZ TTG01FZ.o $(LOADOPTS) TMB03BD: TMB03BD.o ; $(LOADER) -o TMB03BD TMB03BD.o $(LOADOPTS) TMB03KD: TMB03KD.o ; $(LOADER) -o TMB03KD TMB03KD.o $(LOADOPTS) TMB03LD: TMB03LD.o ; $(LOADER) -o TMB03LD TMB03LD.o $(LOADOPTS) TMB04AD: TMB04AD.o ; $(LOADER) -o TMB04AD TMB04AD.o $(LOADOPTS) TMB04BD: TMB04BD.o ; $(LOADER) -o TMB04BD TMB04BD.o $(LOADOPTS) $(TAB01MD): $(FRC) $(TAB01ND): $(FRC) $(TAB01OD): $(FRC) $(TAB04MD): $(FRC) $(TAB05MD): $(FRC) $(TAB05ND): $(FRC) $(TAB05OD): $(FRC) $(TAB05PD): $(FRC) $(TAB05QD): $(FRC) $(TAB05RD): $(FRC) $(TAB07MD): $(FRC) $(TAB07ND): $(FRC) $(TAB08ND): $(FRC) $(TAB09AD): $(FRC) $(TAB09BD): $(FRC) $(TAB09CD): $(FRC) $(TAB09DD): $(FRC) $(TAB09ED): $(FRC) $(TAB09FD): $(FRC) $(TAB09GD): $(FRC) $(TAB09HD): $(FRC) $(TAB09ID): $(FRC) $(TAB09JD): $(FRC) $(TAB09KD): $(FRC) $(TAB09MD): $(FRC) $(TAB09ND): $(FRC) $(TAB13AD): $(FRC) $(TAB13BD): $(FRC) $(TAB13CD): $(FRC) $(TAB13DD): $(FRC) $(TAB13ED): $(FRC) $(TAB13FD): $(FRC) $(TAB13MD): $(FRC) $(TAG08BD): $(FRC) $(TBB01AD): $(FRC) $(TBB02AD): $(FRC) $(TBB03AD): $(FRC) $(TBB04AD): $(FRC) $(TBD01AD): $(FRC) $(TBD02AD): $(FRC) $(TDE01OD): $(FRC) $(TDE01PD): $(FRC) $(TDF01MD): $(FRC) $(TDG01MD): $(FRC) $(TDG01ND): $(FRC) $(TDG01OD): $(FRC) $(TDK01MD): $(FRC) $(TFB01QD): $(FRC) $(TFB01RD): $(FRC) $(TFB01SD): $(FRC) $(TFB01TD): $(FRC) $(TFB01VD): $(FRC) $(TFD01AD): $(FRC) $(TIB01AD): $(FRC) $(TIB01BD): $(FRC) $(TIB01CD): $(FRC) $(TIB03AD): $(FRC) $(TIB03BD): $(FRC) $(TMB01TD): $(FRC) $(TMB02CD): $(FRC) $(TMB02DD): $(FRC) $(TMB02ED): $(FRC) $(TMB02FD): $(FRC) $(TMB02GD): $(FRC) $(TMB02HD): $(FRC) $(TMB02ID): $(FRC) $(TMB02JD): $(FRC) $(TMB02JX): $(FRC) $(TMB02KD): $(FRC) $(TMB02MD): $(FRC) $(TMB02ND): $(FRC) $(TMB02QD): $(FRC) $(TMB02SD): $(FRC) $(TMB02VD): $(FRC) $(TMB03MD): $(FRC) $(TMB03ND): $(FRC) $(TMB03OD): $(FRC) $(TMB03PD): $(FRC) $(TMB03QD): $(FRC) $(TMB03RD): $(FRC) $(TMB03SD): $(FRC) $(TMB03UD): $(FRC) $(TMB03VD): $(FRC) $(TMB03WD): $(FRC) $(TMB04DY): $(FRC) $(TMB04GD): $(FRC) $(TMB04MD): $(FRC) $(TMB04OD): $(FRC) $(TMB04UD): $(FRC) $(TMB04VD): $(FRC) $(TMB04XD): $(FRC) $(TMB04YD): $(FRC) $(TMB04ZD): $(FRC) $(TMB05MD): $(FRC) $(TMB05ND): $(FRC) $(TMB05OD): $(FRC) $(TMC01MD): $(FRC) $(TMC01ND): $(FRC) $(TMC01OD): $(FRC) $(TMC01PD): $(FRC) $(TMC01QD): $(FRC) $(TMC01RD): $(FRC) $(TMC01SD): $(FRC) $(TMC01TD): $(FRC) $(TMC01VD): $(FRC) $(TMC01WD): $(FRC) $(TMC03MD): $(FRC) $(TMC03ND): $(FRC) $(TMD03AD): $(FRC) $(TMD03BD): $(FRC) $(TSB01BD): $(FRC) $(TSB01DD): $(FRC) $(TSB01MD): $(FRC) $(TSB02MD): $(FRC) $(TSB02ND): $(FRC) $(TSB02OD): $(FRC) $(TSB02PD): $(FRC) $(TSB02QD): $(FRC) $(TSB02RD): $(FRC) $(TSB02SD): $(FRC) $(TSB03MD): $(FRC) $(TSB03OD): $(FRC) $(TSB03QD): $(FRC) $(TSB03SD): $(FRC) $(TSB03TD): $(FRC) $(TSB03UD): $(FRC) $(TSB04MD): $(FRC) $(TSB04ND): $(FRC) $(TSB04OD): $(FRC) $(TSB04PD): $(FRC) $(TSB04QD): $(FRC) $(TSB04RD): $(FRC) $(TSB06ND): $(FRC) $(TSB08CD): $(FRC) $(TSB08DD): $(FRC) $(TSB08ED): $(FRC) $(TSB08FD): $(FRC) $(TSB08MD): $(FRC) $(TSB08ND): $(FRC) $(TSB09MD): $(FRC) $(TSB10DD): $(FRC) $(TSB10ED): $(FRC) $(TSB10FD): $(FRC) $(TSB10HD): $(FRC) $(TSB10ID): $(FRC) $(TSB10KD): $(FRC) $(TSB10ZD): $(FRC) $(TSB16AD): $(FRC) $(TSB16BD): $(FRC) $(TSB16CD): $(FRC) $(TSG02AD): $(FRC) $(TSG03AD): $(FRC) $(TSG03BD): $(FRC) $(TTB01ID): $(FRC) $(TTB01KD): $(FRC) $(TTB01LD): $(FRC) $(TTB01MD): $(FRC) $(TTB01ND): $(FRC) $(TTB01PD): $(FRC) $(TTB01TD): $(FRC) $(TTB01UD): $(FRC) $(TTB01WD): $(FRC) $(TTB01ZD): $(FRC) $(TTB03AD): $(FRC) $(TTB04AD): $(FRC) $(TTB04BD): $(FRC) $(TTB04CD): $(FRC) $(TTB05AD): $(FRC) $(TTC01OD): $(FRC) $(TTC04AD): $(FRC) $(TTC05AD): $(FRC) $(TTD03AD): $(FRC) $(TTD04AD): $(FRC) $(TTD05AD): $(FRC) $(TTF01MD): $(FRC) $(TTF01ND): $(FRC) $(TTF01OD): $(FRC) $(TTF01PD): $(FRC) $(TTF01QD): $(FRC) $(TTF01RD): $(FRC) $(TTG01AD): $(FRC) $(TTG01CD): $(FRC) $(TTG01DD): $(FRC) $(TTG01ED): $(FRC) $(TTG01FD): $(FRC) $(TTG01HD): $(FRC) $(TTG01ID): $(FRC) $(TTG01JD): $(FRC) $(TUD01BD): $(FRC) $(TUD01CD): $(FRC) $(TUD01DD): $(FRC) $(TUD01MD): $(FRC) $(TUD01ND): $(FRC) $(TMB03TD): $(FRC) $(TMB03XD): $(FRC) $(TMB03XP): $(FRC) $(TMB03ZD): $(FRC) $(TMB04DD): $(FRC) $(TMB04DS): $(FRC) $(TMB04PB): $(FRC) $(TMB04PU): $(FRC) $(TMB04TB): $(FRC) $(TMB04TS): $(FRC) $(TAB08NZ): $(FRC) $(TAG08BZ): $(FRC) $(TTB01IZ): $(FRC) $(TTG01AZ): $(FRC) $(TTG01FZ): $(FRC) $(TMB03BD): $(FRC) $(TMB03KD): $(FRC) $(TMB03LD): $(FRC) $(TMB04AD): $(FRC) $(TMB04BD): $(FRC) FRC: @FRC=$(FRC) clean: rm -f *.exa cleanup: rm -f *.exa \ TAB01MD TAB01ND TAB01OD TAB04MD TAB05MD TAB05ND TAB05OD TAB05PD \ TAB05QD TAB05RD TAB07MD TAB07ND TAB08ND TAB09AD TAB09BD TAB09CD \ TAB09DD TAB09ED TAB09FD TAB09GD TAB09HD TAB09ID TAB09JD TAB09KD \ TAB09MD TAB09ND TAB13AD TAB13BD TAB13CD TAB13DD TAB13ED TAB13FD \ TAB13MD TAG08BD \ TBB01AD TBB02AD TBB03AD TBB04AD TBD01AD TBD02AD \ TDE01OD TDE01PD TDF01MD TDG01MD TDG01ND TDG01OD TDK01MD \ TFB01QD TFB01RD TFB01SD TFB01TD TFB01VD TFD01AD \ TIB01AD TIB01BD TIB01CD TIB03AD TIB03BD \ TMB01TD TMB02CD TMB02DD TMB02ED TMB02FD TMB02GD TMB02HD TMB02ID \ TMB02JD TMB02JX TMB02KD TMB02MD TMB02ND TMB02QD TMB02SD TMB02VD \ TMB03MD TMB03ND TMB03OD TMB03PD TMB03QD TMB03RD TMB03SD TMB03UD \ TMB03VD TMB03WD TMB04DY TMB04GD TMB04MD TMB04OD TMB04UD TMB04VD \ TMB04XD TMB04YD TMB04ZD TMB05MD TMB05ND TMB05OD TMC01MD TMC01ND \ TMC01OD TMC01PD TMC01QD TMC01RD TMC01SD TMC01TD TMC01VD TMC01WD \ TMC03MD TMC03ND TMD03AD TMD03BD \ TSB01BD TSB01DD TSB01MD TSB02MD TSB02ND TSB02OD TSB02PD TSB02QD \ TSB02RD TSB02SD TSB03MD TSB03OD TSB03QD TSB03SD TSB03TD TSB03UD \ TSB04MD TSB04ND TSB04OD TSB04PD TSB04QD TSB04RD TSB06ND TSB08CD \ TSB08DD TSB08ED TSB08FD TSB08MD TSB08ND TSB09MD TSB10DD TSB10ED \ TSB10FD TSB10HD TSB10ID TSB10KD TSB10ZD TSB16AD TSB16BD TSB16CD \ TSG02AD TSG03AD TSG03BD \ TTB01ID TTB01KD TTB01LD TTB01MD TTB01ND TTB01PD TTB01TD TTB01UD \ TTB01WD TTB01ZD TTB03AD TTB04AD TTB04BD TTB04CD TTB05AD TTC01OD \ TTC04AD TTC05AD TTD03AD TTD04AD TTD05AD TTF01MD TTF01ND TTF01OD \ TTF01PD TTF01QD TTF01RD TTG01AD TTG01CD TTG01DD TTG01ED TTG01FD \ TTG01HD TTG01ID TTG01JD TUD01BD \ TUD01CD TUD01DD TUD01MD TUD01ND \ TMB03TD TMB03XD TMB03XP TMB03ZD TMB04DD TMB04DS TMB04PB TMB04PU \ TMB04TB TMB04TS \ TAB08NZ TAG08BZ TTB01IZ TTG01AZ TTG01FZ \ TMB03BD TMB03KD TMB03LD TMB04AD TMB04BD TAB01MD.o: TAB01MD.f ; $(FORTRAN) $(OPTS) -c $< TAB01ND.o: TAB01ND.f ; $(FORTRAN) $(OPTS) -c $< TAB01OD.o: TAB01OD.f ; $(FORTRAN) $(OPTS) -c $< TAB04MD.o: TAB04MD.f ; $(FORTRAN) $(OPTS) -c $< TAB05MD.o: TAB05MD.f ; $(FORTRAN) $(OPTS) -c $< TAB05ND.o: TAB05ND.f ; $(FORTRAN) $(OPTS) -c $< TAB05OD.o: TAB05OD.f ; $(FORTRAN) $(OPTS) -c $< TAB05PD.o: TAB05PD.f ; $(FORTRAN) $(OPTS) -c $< TAB05QD.o: TAB05QD.f ; $(FORTRAN) $(OPTS) -c $< TAB05RD.o: TAB05RD.f ; $(FORTRAN) $(OPTS) -c $< TAB07MD.o: TAB07MD.f ; $(FORTRAN) $(OPTS) -c $< TAB07ND.o: TAB07ND.f ; $(FORTRAN) $(OPTS) -c $< TAB08ND.o: TAB08ND.f ; $(FORTRAN) $(OPTS) -c $< TAB09AD.o: TAB09AD.f ; $(FORTRAN) $(OPTS) -c $< TAB09BD.o: TAB09BD.f ; $(FORTRAN) $(OPTS) -c $< TAB09CD.o: TAB09CD.f ; $(FORTRAN) $(OPTS) -c $< TAB09DD.o: TAB09DD.f ; $(FORTRAN) $(OPTS) -c $< TAB09ED.o: TAB09ED.f ; $(FORTRAN) $(OPTS) -c $< TAB09FD.o: TAB09FD.f ; $(FORTRAN) $(OPTS) -c $< TAB09GD.o: TAB09GD.f ; $(FORTRAN) $(OPTS) -c $< TAB09HD.o: TAB09HD.f ; $(FORTRAN) $(OPTS) -c $< TAB09ID.o: TAB09ID.f ; $(FORTRAN) $(OPTS) -c $< TAB09JD.o: TAB09JD.f ; $(FORTRAN) $(OPTS) -c $< TAB09KD.o: TAB09KD.f ; $(FORTRAN) $(OPTS) -c $< TAB09MD.o: TAB09MD.f ; $(FORTRAN) $(OPTS) -c $< TAB09ND.o: TAB09ND.f ; $(FORTRAN) $(OPTS) -c $< TAB13AD.o: TAB13AD.f ; $(FORTRAN) $(OPTS) -c $< TAB13BD.o: TAB13BD.f ; $(FORTRAN) $(OPTS) -c $< TAB13CD.o: TAB13CD.f ; $(FORTRAN) $(OPTS) -c $< TAB13DD.o: TAB13DD.f ; $(FORTRAN) $(OPTS) -c $< TAB13ED.o: TAB13ED.f ; $(FORTRAN) $(OPTS) -c $< TAB13FD.o: TAB13FD.f ; $(FORTRAN) $(OPTS) -c $< TAB13MD.o: TAB13MD.f ; $(FORTRAN) $(OPTS) -c $< TAG08BD.o: TAG08BD.f ; $(FORTRAN) $(OPTS) -c $< TBB01AD.o: TBB01AD.f ; $(FORTRAN) $(OPTS) -c $< TBB02AD.o: TBB02AD.f ; $(FORTRAN) $(OPTS) -c $< TBB03AD.o: TBB03AD.f ; $(FORTRAN) $(OPTS) -c $< TBB04AD.o: TBB04AD.f ; $(FORTRAN) $(OPTS) -c $< TBD01AD.o: TBD01AD.f ; $(FORTRAN) $(OPTS) -c $< TBD02AD.o: TBD02AD.f ; $(FORTRAN) $(OPTS) -c $< TDE01OD.o: TDE01OD.f ; $(FORTRAN) $(OPTS) -c $< TDE01PD.o: TDE01PD.f ; $(FORTRAN) $(OPTS) -c $< TDF01MD.o: TDF01MD.f ; $(FORTRAN) $(OPTS) -c $< TDG01MD.o: TDG01MD.f ; $(FORTRAN) $(OPTS) -c $< TDG01ND.o: TDG01ND.f ; $(FORTRAN) $(OPTS) -c $< TDG01OD.o: TDG01OD.f ; $(FORTRAN) $(OPTS) -c $< TDK01MD.o: TDK01MD.f ; $(FORTRAN) $(OPTS) -c $< TFB01QD.o: TFB01QD.f ; $(FORTRAN) $(OPTS) -c $< TFB01RD.o: TFB01RD.f ; $(FORTRAN) $(OPTS) -c $< TFB01SD.o: TFB01SD.f ; $(FORTRAN) $(OPTS) -c $< TFB01TD.o: TFB01TD.f ; $(FORTRAN) $(OPTS) -c $< TFB01VD.o: TFB01VD.f ; $(FORTRAN) $(OPTS) -c $< TFD01AD.o: TFD01AD.f ; $(FORTRAN) $(OPTS) -c $< TIB01AD.o: TIB01AD.f ; $(FORTRAN) $(OPTS) -c $< TIB01BD.o: TIB01BD.f ; $(FORTRAN) $(OPTS) -c $< TIB01CD.o: TIB01CD.f ; $(FORTRAN) $(OPTS) -c $< TIB03AD.o: TIB03AD.f ; $(FORTRAN) $(OPTS) -c $< TIB03BD.o: TIB03BD.f ; $(FORTRAN) $(OPTS) -c $< TMB01TD.o: TMB01TD.f ; $(FORTRAN) $(OPTS) -c $< TMB02CD.o: TMB02CD.f ; $(FORTRAN) $(OPTS) -c $< TMB02DD.o: TMB02DD.f ; $(FORTRAN) $(OPTS) -c $< TMB02ED.o: TMB02ED.f ; $(FORTRAN) $(OPTS) -c $< TMB02FD.o: TMB02FD.f ; $(FORTRAN) $(OPTS) -c $< TMB02GD.o: TMB02GD.f ; $(FORTRAN) $(OPTS) -c $< TMB02HD.o: TMB02HD.f ; $(FORTRAN) $(OPTS) -c $< TMB02ID.o: TMB02ID.f ; $(FORTRAN) $(OPTS) -c $< TMB02JD.o: TMB02JD.f ; $(FORTRAN) $(OPTS) -c $< TMB02JX.o: TMB02JX.f ; $(FORTRAN) $(OPTS) -c $< TMB02KD.o: TMB02KD.f ; $(FORTRAN) $(OPTS) -c $< TMB02MD.o: TMB02MD.f ; $(FORTRAN) $(OPTS) -c $< TMB02ND.o: TMB02ND.f ; $(FORTRAN) $(OPTS) -c $< TMB02QD.o: TMB02QD.f ; $(FORTRAN) $(OPTS) -c $< TMB02SD.o: TMB02SD.f ; $(FORTRAN) $(OPTS) -c $< TMB02VD.o: TMB02VD.f ; $(FORTRAN) $(OPTS) -c $< TMB03MD.o: TMB03MD.f ; $(FORTRAN) $(OPTS) -c $< TMB03ND.o: TMB03ND.f ; $(FORTRAN) $(OPTS) -c $< TMB03OD.o: TMB03OD.f ; $(FORTRAN) $(OPTS) -c $< TMB03PD.o: TMB03PD.f ; $(FORTRAN) $(OPTS) -c $< TMB03QD.o: TMB03QD.f ; $(FORTRAN) $(OPTS) -c $< TMB03RD.o: TMB03RD.f ; $(FORTRAN) $(OPTS) -c $< TMB03SD.o: TMB03SD.f ; $(FORTRAN) $(OPTS) -c $< TMB03UD.o: TMB03UD.f ; $(FORTRAN) $(OPTS) -c $< TMB03VD.o: TMB03VD.f ; $(FORTRAN) $(OPTS) -c $< TMB03WD.o: TMB03WD.f ; $(FORTRAN) $(OPTS) -c $< TMB04DY.o: TMB04DY.f ; $(FORTRAN) $(OPTS) -c $< TMB04GD.o: TMB04GD.f ; $(FORTRAN) $(OPTS) -c $< TMB04MD.o: TMB04MD.f ; $(FORTRAN) $(OPTS) -c $< TMB04OD.o: TMB04OD.f ; $(FORTRAN) $(OPTS) -c $< TMB04UD.o: TMB04UD.f ; $(FORTRAN) $(OPTS) -c $< TMB04VD.o: TMB04VD.f ; $(FORTRAN) $(OPTS) -c $< TMB04XD.o: TMB04XD.f ; $(FORTRAN) $(OPTS) -c $< TMB04YD.o: TMB04YD.f ; $(FORTRAN) $(OPTS) -c $< TMB04ZD.o: TMB04ZD.f ; $(FORTRAN) $(OPTS) -c $< TMB05MD.o: TMB05MD.f ; $(FORTRAN) $(OPTS) -c $< TMB05ND.o: TMB05ND.f ; $(FORTRAN) $(OPTS) -c $< TMB05OD.o: TMB05OD.f ; $(FORTRAN) $(OPTS) -c $< TMC01MD.o: TMC01MD.f ; $(FORTRAN) $(OPTS) -c $< TMC01ND.o: TMC01ND.f ; $(FORTRAN) $(OPTS) -c $< TMC01OD.o: TMC01OD.f ; $(FORTRAN) $(OPTS) -c $< TMC01PD.o: TMC01PD.f ; $(FORTRAN) $(OPTS) -c $< TMC01QD.o: TMC01QD.f ; $(FORTRAN) $(OPTS) -c $< TMC01RD.o: TMC01RD.f ; $(FORTRAN) $(OPTS) -c $< TMC01SD.o: TMC01SD.f ; $(FORTRAN) $(OPTS) -c $< TMC01TD.o: TMC01TD.f ; $(FORTRAN) $(OPTS) -c $< TMC01VD.o: TMC01VD.f ; $(FORTRAN) $(OPTS) -c $< TMC01WD.o: TMC01WD.f ; $(FORTRAN) $(OPTS) -c $< TMC03MD.o: TMC03MD.f ; $(FORTRAN) $(OPTS) -c $< TMC03ND.o: TMC03ND.f ; $(FORTRAN) $(OPTS) -c $< TMD03AD.o: TMD03AD.f ; $(FORTRAN) $(OPTS) -c $< TMD03BD.o: TMD03BD.f ; $(FORTRAN) $(OPTS) -c $< TSB01BD.o: TSB01BD.f ; $(FORTRAN) $(OPTS) -c $< TSB01DD.o: TSB01DD.f ; $(FORTRAN) $(OPTS) -c $< TSB01MD.o: TSB01MD.f ; $(FORTRAN) $(OPTS) -c $< TSB02MD.o: TSB02MD.f ; $(FORTRAN) $(OPTS) -c $< TSB02ND.o: TSB02ND.f ; $(FORTRAN) $(OPTS) -c $< TSB02OD.o: TSB02OD.f ; $(FORTRAN) $(OPTS) -c $< TSB02PD.o: TSB02PD.f ; $(FORTRAN) $(OPTS) -c $< TSB02QD.o: TSB02QD.f ; $(FORTRAN) $(OPTS) -c $< TSB02RD.o: TSB02RD.f ; $(FORTRAN) $(OPTS) -c $< TSB02SD.o: TSB02SD.f ; $(FORTRAN) $(OPTS) -c $< TSB03MD.o: TSB03MD.f ; $(FORTRAN) $(OPTS) -c $< TSB03OD.o: TSB03OD.f ; $(FORTRAN) $(OPTS) -c $< TSB03QD.o: TSB03QD.f ; $(FORTRAN) $(OPTS) -c $< TSB03SD.o: TSB03SD.f ; $(FORTRAN) $(OPTS) -c $< TSB03TD.o: TSB03TD.f ; $(FORTRAN) $(OPTS) -c $< TSB03UD.o: TSB03UD.f ; $(FORTRAN) $(OPTS) -c $< TSB04MD.o: TSB04MD.f ; $(FORTRAN) $(OPTS) -c $< TSB04ND.o: TSB04ND.f ; $(FORTRAN) $(OPTS) -c $< TSB04OD.o: TSB04OD.f ; $(FORTRAN) $(OPTS) -c $< TSB04PD.o: TSB04PD.f ; $(FORTRAN) $(OPTS) -c $< TSB04QD.o: TSB04QD.f ; $(FORTRAN) $(OPTS) -c $< TSB04RD.o: TSB04RD.f ; $(FORTRAN) $(OPTS) -c $< TSB06ND.o: TSB06ND.f ; $(FORTRAN) $(OPTS) -c $< TSB08CD.o: TSB08CD.f ; $(FORTRAN) $(OPTS) -c $< TSB08DD.o: TSB08DD.f ; $(FORTRAN) $(OPTS) -c $< TSB08ED.o: TSB08ED.f ; $(FORTRAN) $(OPTS) -c $< TSB08FD.o: TSB08FD.f ; $(FORTRAN) $(OPTS) -c $< TSB08MD.o: TSB08MD.f ; $(FORTRAN) $(OPTS) -c $< TSB08ND.o: TSB08ND.f ; $(FORTRAN) $(OPTS) -c $< TSB09MD.o: TSB09MD.f ; $(FORTRAN) $(OPTS) -c $< TSB10DD.o: TSB10DD.f ; $(FORTRAN) $(OPTS) -c $< TSB10ED.o: TSB10ED.f ; $(FORTRAN) $(OPTS) -c $< TSB10FD.o: TSB10FD.f ; $(FORTRAN) $(OPTS) -c $< TSB10HD.o: TSB10HD.f ; $(FORTRAN) $(OPTS) -c $< TSB10ID.o: TSB10ID.f ; $(FORTRAN) $(OPTS) -c $< TSB10KD.o: TSB10KD.f ; $(FORTRAN) $(OPTS) -c $< TSB10ZD.o: TSB10ZD.f ; $(FORTRAN) $(OPTS) -c $< TSB16AD.o: TSB16AD.f ; $(FORTRAN) $(OPTS) -c $< TSB16BD.o: TSB16BD.f ; $(FORTRAN) $(OPTS) -c $< TSB16CD.o: TSB16CD.f ; $(FORTRAN) $(OPTS) -c $< TSG02AD.o: TSG02AD.f ; $(FORTRAN) $(OPTS) -c $< TSG03AD.o: TSG03AD.f ; $(FORTRAN) $(OPTS) -c $< TSG03BD.o: TSG03BD.f ; $(FORTRAN) $(OPTS) -c $< TTB01ID.o: TTB01ID.f ; $(FORTRAN) $(OPTS) -c $< TTB01KD.o: TTB01KD.f ; $(FORTRAN) $(OPTS) -c $< TTB01LD.o: TTB01LD.f ; $(FORTRAN) $(OPTS) -c $< TTB01MD.o: TTB01MD.f ; $(FORTRAN) $(OPTS) -c $< TTB01ND.o: TTB01ND.f ; $(FORTRAN) $(OPTS) -c $< TTB01PD.o: TTB01PD.f ; $(FORTRAN) $(OPTS) -c $< TTB01TD.o: TTB01TD.f ; $(FORTRAN) $(OPTS) -c $< TTB01UD.o: TTB01UD.f ; $(FORTRAN) $(OPTS) -c $< TTB01WD.o: TTB01WD.f ; $(FORTRAN) $(OPTS) -c $< TTB01ZD.o: TTB01ZD.f ; $(FORTRAN) $(OPTS) -c $< TTB03AD.o: TTB03AD.f ; $(FORTRAN) $(OPTS) -c $< TTB04AD.o: TTB04AD.f ; $(FORTRAN) $(OPTS) -c $< TTB04BD.o: TTB04BD.f ; $(FORTRAN) $(OPTS) -c $< TTB04CD.o: TTB04CD.f ; $(FORTRAN) $(OPTS) -c $< TTB05AD.o: TTB05AD.f ; $(FORTRAN) $(OPTS) -c $< TTC01OD.o: TTC01OD.f ; $(FORTRAN) $(OPTS) -c $< TTC04AD.o: TTC04AD.f ; $(FORTRAN) $(OPTS) -c $< TTC05AD.o: TTC05AD.f ; $(FORTRAN) $(OPTS) -c $< TTD03AD.o: TTD03AD.f ; $(FORTRAN) $(OPTS) -c $< TTD04AD.o: TTD04AD.f ; $(FORTRAN) $(OPTS) -c $< TTD05AD.o: TTD05AD.f ; $(FORTRAN) $(OPTS) -c $< TTF01MD.o: TTF01MD.f ; $(FORTRAN) $(OPTS) -c $< TTF01ND.o: TTF01ND.f ; $(FORTRAN) $(OPTS) -c $< TTF01OD.o: TTF01OD.f ; $(FORTRAN) $(OPTS) -c $< TTF01PD.o: TTF01PD.f ; $(FORTRAN) $(OPTS) -c $< TTF01QD.o: TTF01QD.f ; $(FORTRAN) $(OPTS) -c $< TTF01RD.o: TTF01RD.f ; $(FORTRAN) $(OPTS) -c $< TTG01AD.o: TTG01AD.f ; $(FORTRAN) $(OPTS) -c $< TTG01CD.o: TTG01CD.f ; $(FORTRAN) $(OPTS) -c $< TTG01DD.o: TTG01DD.f ; $(FORTRAN) $(OPTS) -c $< TTG01ED.o: TTG01ED.f ; $(FORTRAN) $(OPTS) -c $< TTG01FD.o: TTG01FD.f ; $(FORTRAN) $(OPTS) -c $< TTG01HD.o: TTG01HD.f ; $(FORTRAN) $(OPTS) -c $< TTG01ID.o: TTG01ID.f ; $(FORTRAN) $(OPTS) -c $< TTG01JD.o: TTG01JD.f ; $(FORTRAN) $(OPTS) -c $< TUD01BD.o: TUD01BD.f ; $(FORTRAN) $(OPTS) -c $< TUD01CD.o: TUD01CD.f ; $(FORTRAN) $(OPTS) -c $< TUD01DD.o: TUD01DD.f ; $(FORTRAN) $(OPTS) -c $< TUD01MD.o: TUD01MD.f ; $(FORTRAN) $(OPTS) -c $< TUD01ND.o: TUD01ND.f ; $(FORTRAN) $(OPTS) -c $< TMB03TD.o: TMB03TD.f ; $(FORTRAN) $(OPTS) -c $< TMB03XD.o: TMB03XD.f ; $(FORTRAN) $(OPTS) -c $< TMB03XP.o: TMB03XP.f ; $(FORTRAN) $(OPTS) -c $< TMB03ZD.o: TMB03ZD.f ; $(FORTRAN) $(OPTS) -c $< TMB04DD.o: TMB04DD.f ; $(FORTRAN) $(OPTS) -c $< TMB04DS.o: TMB04DS.f ; $(FORTRAN) $(OPTS) -c $< TMB04PB.o: TMB04PB.f ; $(FORTRAN) $(OPTS) -c $< TMB04PU.o: TMB04PU.f ; $(FORTRAN) $(OPTS) -c $< TMB04TB.o: TMB04TB.f ; $(FORTRAN) $(OPTS) -c $< TMB04TS.o: TMB04TS.f ; $(FORTRAN) $(OPTS) -c $< TAB08NZ.o: TAB08NZ.f ; $(FORTRAN) $(OPTS) -c $< TAG08BZ.o: TAG08BZ.f ; $(FORTRAN) $(OPTS) -c $< TTB01IZ.o: TTB01IZ.f ; $(FORTRAN) $(OPTS) -c $< TTG01AZ.o: TTG01AZ.f ; $(FORTRAN) $(OPTS) -c $< TTG01FZ.o: TTG01FZ.f ; $(FORTRAN) $(OPTS) -c $< TMB03BD.o: TMB03BD.f ; $(FORTRAN) $(OPTS) -c $< TMB03KD.o: TMB03KD.f ; $(FORTRAN) $(OPTS) -c $< TMB03LD.o: TMB03LD.f ; $(FORTRAN) $(OPTS) -c $< TMB04AD.o: TMB04AD.f ; $(FORTRAN) $(OPTS) -c $< TMB04BD.o: TMB04BD.f ; $(FORTRAN) $(OPTS) -c $< .f.o: ; $(FORTRAN) $(OPTS) -c $< slicot-5.0+20101122/examples/readme000077500000000000000000000021241201767322700165460ustar00rootroot00000000000000SLICOT Library Subdirectory examples ------------------------------------ SLICOT Library Subdirectory examples contains all source files for the Fortran 90/95 example programs calling the SLICOT Library routines, the associated data files (files *.dat), and reference results (files *.res). The Fortran files differ from those in the subdirectory examples77 in having references to the INTRINSIC functions MAX and MIN in PARAMETER statements, not allowed in Fortran 77. The reference results have been computed on a Sun Ultra 2 machine, for the Unix distribution, and on an Intel Pentium 3 machine, for the Windows distribution. When installing the SLICOT software (as described in the Installation.txt file from the SLICOT root directory), the executable Fortran example programs are automatically created and executed, and their results are stored in the files *.exa (with the same name as for the files with data and reference results, and extension exa). More details for executing other tasks, e.g., cleaning the subdirectory examples, are given in the file makefile included in this subdirectory. slicot-5.0+20101122/examples77/000077500000000000000000000000001201767322700155425ustar00rootroot00000000000000slicot-5.0+20101122/examples77/AB01MD.dat000077500000000000000000000001741201767322700171050ustar00rootroot00000000000000 AB01MD EXAMPLE PROGRAM DATA 3 0.0 I 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/AB01MD.res000077500000000000000000000007201201767322700171230ustar00rootroot00000000000000 AB01MD EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 3 The state dynamics matrix A of a controllable realization is 1.0000 1.4142 0.0000 2.8284 -1.0000 2.8284 0.0000 1.4142 1.0000 The input/state vector B of a controllable realization is -1.4142 0.0000 0.0000 The similarity transformation matrix Z is -0.7071 0.0000 -0.7071 0.0000 -1.0000 0.0000 -0.7071 0.0000 0.7071 slicot-5.0+20101122/examples77/AB01ND.dat000077500000000000000000000002251201767322700171030ustar00rootroot00000000000000 AB01ND EXAMPLE PROGRAM DATA 3 2 0.0 I -1.0 0.0 0.0 -2.0 -2.0 -2.0 -1.0 0.0 -3.0 1.0 0.0 0.0 0.0 2.0 1.0 slicot-5.0+20101122/examples77/AB01ND.res000077500000000000000000000010771201767322700171320ustar00rootroot00000000000000 AB01ND EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 2 The transformed state dynamics matrix of a controllable realization is -3.0000 2.2361 0.0000 -1.0000 and the dimensions of its diagonal blocks are 2 The transformed input/state matrix B of a controllable realization is 0.0000 -2.2361 1.0000 0.0000 The controllability index of the transformed system representation = 1 The similarity transformation matrix Z is 0.0000 1.0000 0.0000 -0.8944 0.0000 -0.4472 -0.4472 0.0000 0.8944 slicot-5.0+20101122/examples77/AB01OD.dat000077500000000000000000000005011201767322700171010ustar00rootroot00000000000000 AB01OD EXAMPLE PROGRAM DATA 5 2 0.0 F N N 17.0 24.0 1.0 8.0 15.0 23.0 5.0 7.0 14.0 16.0 4.0 6.0 13.0 20.0 22.0 10.0 12.0 19.0 21.0 3.0 11.0 18.0 25.0 2.0 9.0 -1.0 -4.0 4.0 9.0 -9.0 -16.0 16.0 25.0 -25.0 -36.0 slicot-5.0+20101122/examples77/AB01OD.res000077500000000000000000000010331201767322700171230ustar00rootroot00000000000000 AB01OD EXAMPLE PROGRAM RESULTS The transformed state transition matrix is 12.8848 3.2345 11.8211 3.3758 -0.8982 4.4741 -12.5544 5.3509 5.9403 1.4360 14.4576 7.6855 23.1452 26.3872 -29.9557 0.0000 1.4805 27.4668 22.6564 -0.0072 0.0000 0.0000 -30.4822 0.6745 18.8680 The transformed input matrix is 31.1199 47.6865 3.2480 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The number of stairs in the staircase form = 3 The dimensions of the stairs are 2 2 1 slicot-5.0+20101122/examples77/AB04MD.dat000077500000000000000000000002501201767322700171030ustar00rootroot00000000000000 AB04MD EXAMPLE PROGRAM DATA 2 2 2 C 1.0D0 1.0D0 1.0 0.5 0.5 1.0 0.0 -1.0 1.0 0.0 -1.0 0.0 0.0 1.0 1.0 0.0 0.0 -1.0 slicot-5.0+20101122/examples77/AB04MD.res000077500000000000000000000005141201767322700171270ustar00rootroot00000000000000 AB04MD EXAMPLE PROGRAM RESULTS The transformed state matrix is -1.0000 -4.0000 -4.0000 -1.0000 The transformed input matrix is 2.8284 0.0000 0.0000 -2.8284 The transformed output matrix is 0.0000 2.8284 -2.8284 0.0000 The transformed input/output matrix is -1.0000 0.0000 0.0000 -3.0000 slicot-5.0+20101122/examples77/AB05MD.dat000077500000000000000000000005701201767322700171110ustar00rootroot00000000000000 AB05MD EXAMPLE PROGRAM DATA 3 2 2 3 2 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/AB05MD.res000077500000000000000000000015071201767322700171330ustar00rootroot00000000000000 AB05MD EXAMPLE PROGRAM RESULTS The state transition matrix of the cascaded system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 -3.0000 0.0000 0.0000 -3.0000 2.0000 -1.0000 1.0000 0.0000 1.0000 0.0000 2.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the cascaded system is 1.0000 2.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 -1.0000 0.0000 0.0000 2.0000 The state/output matrix of the cascaded system is 3.0000 -1.0000 1.0000 1.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the cascaded system is 1.0000 1.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/AB05ND.dat000077500000000000000000000005621201767322700171130ustar00rootroot00000000000000 AB05ND EXAMPLE PROGRAM DATA 3 2 2 3 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/AB05ND.res000077500000000000000000000015121201767322700171300ustar00rootroot00000000000000 AB05ND EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is -0.5000 -0.2500 -1.5000 -1.2500 -1.2500 0.7500 -1.5000 -0.2500 0.5000 -0.2500 -0.2500 -0.2500 1.0000 0.5000 2.0000 -0.5000 -0.5000 0.5000 0.0000 0.5000 0.0000 -3.5000 -0.5000 0.5000 -1.5000 1.2500 -0.5000 1.2500 0.2500 1.2500 0.0000 1.0000 0.0000 -1.0000 -2.0000 3.0000 The input/state matrix of the connected system is 0.5000 0.7500 0.5000 -0.2500 0.0000 0.5000 0.0000 0.5000 -0.5000 0.2500 0.0000 1.0000 The state/output matrix of the connected system is 1.5000 -1.2500 0.5000 -0.2500 -0.2500 -0.2500 0.0000 0.5000 0.0000 -0.5000 -0.5000 0.5000 The input/output matrix of the connected system is 0.5000 -0.2500 0.0000 0.5000 slicot-5.0+20101122/examples77/AB05OD.dat000077500000000000000000000005701201767322700171130ustar00rootroot00000000000000 AB05OD EXAMPLE PROGRAM DATA 3 2 2 3 2 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/AB05OD.res000077500000000000000000000017321201767322700171350ustar00rootroot00000000000000 AB05OD EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the connected system is 1.0000 2.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 2.0000 The state/output matrix of the connected system is 3.0000 -2.0000 1.0000 1.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the connected system is 1.0000 0.0000 1.0000 1.0000 0.0000 1.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/AB05PD.dat000077500000000000000000000005741201767322700171200ustar00rootroot00000000000000 AB05PD EXAMPLE PROGRAM DATA 3 2 2 3 1.0D0 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/AB05PD.res000077500000000000000000000015121201767322700171320ustar00rootroot00000000000000 AB05PD EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the connected system is 1.0000 2.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 -1.0000 0.0000 0.0000 2.0000 The state/output matrix of the connected system is 3.0000 -2.0000 1.0000 1.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the connected system is 2.0000 1.0000 0.0000 2.0000 slicot-5.0+20101122/examples77/AB05QD.dat000077500000000000000000000005761201767322700171230ustar00rootroot00000000000000 AB05QD EXAMPLE PROGRAM DATA 3 2 2 3 2 2 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 -3.0 0.0 0.0 1.0 0.0 1.0 0.0 -1.0 2.0 0.0 -1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 1.0 1.0 -1.0 1.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/AB05QD.res000077500000000000000000000022221201767322700171320ustar00rootroot00000000000000 AB05QD EXAMPLE PROGRAM RESULTS The state transition matrix of the connected system is 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 The input/state matrix of the connected system is 1.0000 2.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 2.0000 The state/output matrix of the connected system is 3.0000 -2.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 1.0000 -1.0000 The input/output matrix of the connected system is 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/AB05RD.dat000077500000000000000000000005441201767322700171170ustar00rootroot00000000000000 AB05RD EXAMPLE PROGRAM DATA 3 2 2 2 2 1.0 1.0 O D 1.0 0.0 -1.0 0.0 -1.0 1.0 1.0 1.0 2.0 1.0 1.0 0.0 2.0 0.0 1.0 2.0 1.0 0.0 1.0 0.0 1.0 3.0 -2.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 1.0 2.0 3.0 4.0 1.0 1.0 0.0 1.0 4.0 3.0 2.0 1.0 slicot-5.0+20101122/examples77/AB05RD.res000077500000000000000000000010671201767322700171410ustar00rootroot00000000000000 AB05RD EXAMPLE PROGRAM RESULTS The reciprocal condition number of the matrix I - alpha*D*F is 0.2000 The state transition matrix of the closed-loop system is -4.8333 0.1667 -2.8333 -0.8333 0.1667 0.1667 -1.5000 0.5000 1.5000 The input/state matrix of the closed-loop system is -0.5000 -0.8333 0.5000 0.1667 -0.5000 -0.5000 The state/output matrix of the closed-loop system is 1.1667 -1.8333 -0.8333 1.8333 -1.1667 -0.1667 The input/output matrix of the closed-loop system is 0.5000 -0.8333 0.5000 -0.1667 slicot-5.0+20101122/examples77/AB07MD.dat000077500000000000000000000002631201767322700171120ustar00rootroot00000000000000 AB07MD EXAMPLE PROGRAM DATA 3 1 2 D 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/AB07MD.res000077500000000000000000000005601201767322700171330ustar00rootroot00000000000000 AB07MD EXAMPLE PROGRAM RESULTS The dual state dynamics matrix is 1.0000 4.0000 0.0000 2.0000 -1.0000 0.0000 0.0000 0.0000 1.0000 The dual input/state matrix is 0.0000 0.0000 1.0000 0.0000 -1.0000 1.0000 The dual state/output matrix is 1.0000 0.0000 1.0000 The dual direct transmission matrix is 0.0000 1.0000 slicot-5.0+20101122/examples77/AB07ND.dat000077500000000000000000000003101201767322700171040ustar00rootroot00000000000000 AB07ND EXAMPLE PROGRAM DATA 3 2 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 0.0 1.0 1.0 0.0 0.0 1.0 -1.0 0.0 0.0 1.0 4.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/AB07ND.res000077500000000000000000000007331201767322700171360ustar00rootroot00000000000000 AB07ND EXAMPLE PROGRAM RESULTS The state dynamics matrix of the inverse system is 1.0000 1.7500 0.2500 4.0000 -1.0000 -1.0000 0.0000 -0.2500 1.2500 The input/state matrix of the inverse system is -0.2500 0.0000 0.0000 -1.0000 -0.2500 0.0000 The state/output matrix of the inverse system is 0.0000 0.2500 -0.2500 0.0000 0.0000 1.0000 The feedthrough matrix of the inverse system is 0.2500 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/AB08ND.dat000077500000000000000000000007761201767322700171250ustar00rootroot00000000000000 AB08ND EXAMPLE PROGRAM DATA 6 2 3 0.0 N 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 3.0 0.0 0.0 0.0 0.0 0.0 0.0 -4.0 0.0 0.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 0.0 0.0 3.0 0.0 -1.0 -1.0 0.0 1.0 -1.0 0.0 0.0 0.0 1.0 -1.0 -1.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 slicot-5.0+20101122/examples77/AB08ND.res000077500000000000000000000015551201767322700171420ustar00rootroot00000000000000 AB08ND EXAMPLE PROGRAM RESULTS The left Kronecker indices of (A,C) are 1 2 2 The dimension of the observable subspace = 5 The output decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -1.0000 The right Kronecker indices of (A,B) are 2 3 The dimension of the controllable subspace = 5 The input decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -4.0000 The number of finite invariant zeros = 2 The finite invariant zeros are real part imag part 2.0000 -1.0000 which correspond to the generalized eigenvalues of (lambda*BF - AF). The number of infinite zeros = 2 The orders of the infinite zeros are 1 1 The number of right Kronecker indices = 0 The number of left Kronecker indices = 1 The left Kronecker (row) indices of (A,B,C,D) are 2 slicot-5.0+20101122/examples77/AB08NZ.dat000077500000000000000000000015441201767322700171450ustar00rootroot00000000000000 AB08NZ EXAMPLE PROGRAM DATA 6 2 3 0.0 N (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (3.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-4.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (3.0,0.0) (0.0,0.0) (-1.0,0.0) (-1.0,0.0) (0.0,0.0) (1.0,0.0) (-1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (-1.0,0.0) (-1.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (1.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) slicot-5.0+20101122/examples77/AB08NZ.res000077500000000000000000000016331201767322700171650ustar00rootroot00000000000000 AB08NZ EXAMPLE PROGRAM RESULTS The left Kronecker indices of (A,C) are 1 2 2 The dimension of the observable subspace = 5 The output decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -1.0000 +0.0000i The right Kronecker indices of (A,B) are 2 3 The dimension of the controllable subspace = 5 The input decoupling zeros are the eigenvalues of the matrix AF. The matrix AF is -4.0000 +0.0000i The number of finite invariant zeros = 2 The finite invariant zeros are real part imag part 2.0000 +0.0000i -1.0000 +0.0000i which correspond to the generalized eigenvalues of (lambda*BF - AF). The number of infinite zeros = 2 The orders of the infinite zeros are 1 1 The number of right Kronecker indices = 0 The number of left Kronecker indices = 1 The left Kronecker (row) indices of (A,B,C,D) are 2 slicot-5.0+20101122/examples77/AB09AD.dat000077500000000000000000000014641201767322700171040ustar00rootroot00000000000000 AB09AD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 1.E-1 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09AD.res000077500000000000000000000013621201767322700171220ustar00rootroot00000000000000 AB09AD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values HSV are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 The reduced state dynamics matrix Ar is 1.3451 5.0399 0.0000 0.0000 4.5315 -4.0214 -3.6604 0.0000 0.0000 -0.9056 0.0000 0.0000 0.5124 1.7910 0.0000 0.0000 0.0000 -4.2167 -2.9900 0.0000 1.2402 1.6416 0.0000 0.0000 -0.0586 The reduced input/state matrix Br is -0.3857 0.3857 -3.1753 3.1753 -0.7447 -0.7447 -3.6872 -3.6872 1.8197 -1.8197 The reduced state/output matrix Cr is -0.6704 0.1828 -0.6582 0.2222 -0.0104 0.1089 0.4867 0.0000 0.0000 0.8651 0.6704 -0.1828 -0.6582 0.2222 0.0104 slicot-5.0+20101122/examples77/AB09BD.dat000077500000000000000000000015701201767322700171030ustar00rootroot00000000000000 AB09BD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 1.E-1 1.E-14 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09BD.res000077500000000000000000000015201201767322700171170ustar00rootroot00000000000000 AB09BD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 The reduced state dynamics matrix Ar is 1.3960 5.1248 0.0000 0.0000 4.4331 -4.1411 -3.8605 0.0000 0.0000 -0.6738 0.0000 0.0000 0.5847 1.9230 0.0000 0.0000 0.0000 -4.3823 -3.2922 0.0000 1.3261 1.7851 0.0000 0.0000 -0.2249 The reduced input/state matrix Br is -0.2901 0.2901 -3.4004 3.4004 -0.6379 -0.6379 -3.9315 -3.9315 1.9813 -1.9813 The reduced state/output matrix Cr is -0.6570 0.2053 -0.6416 0.2526 -0.0364 0.1094 0.4875 0.0000 0.0000 0.8641 0.6570 -0.2053 -0.6416 0.2526 0.0364 The reduced input/output matrix Dr is 0.0498 -0.0007 0.0010 -0.0010 -0.0007 0.0498 slicot-5.0+20101122/examples77/AB09CD.dat000077500000000000000000000015541201767322700171060ustar00rootroot00000000000000 AB09CD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 1.E-1 1.E-14 C N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09CD.res000077500000000000000000000015201201767322700171200ustar00rootroot00000000000000 AB09CD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 The reduced state dynamics matrix Ar is -0.5038 -5.3070 -3.2250 0.0000 0.0000 1.8355 -0.5038 -2.6289 0.0000 0.0000 0.0000 0.0000 -1.5171 0.0000 0.0000 0.0000 0.0000 0.0000 -1.2925 -9.0718 0.0000 0.0000 0.0000 0.5047 -1.2925 The reduced input/state matrix Br is -1.5343 1.5343 -0.3614 0.3614 -1.1096 1.1096 -4.5325 -4.5325 -0.7396 -0.7396 The reduced state/output matrix Cr is 1.8971 -0.3055 -2.1124 0.4421 -2.1023 -0.0394 1.1112 -0.3119 0.0000 0.0000 -1.8971 0.3055 2.1124 0.4421 -2.1023 The reduced input/output matrix Dr is 0.0126 -0.0126 0.0005 -0.0005 -0.0126 0.0126 slicot-5.0+20101122/examples77/AB09DD.dat000077500000000000000000000016371201767322700171110ustar00rootroot00000000000000 AB09DD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 5 C -0.04165 4.9200 -4.9200 0 0 0 0 0 -3.3300 0 0 0 3.3300 0 0.5450 0 0 -0.5450 0 0 0 0 0 4.9200 -0.04165 4.9200 0 0 0 0 0 0 -3.3300 0 3.3300 -5.2100 0 0 0 0 -12.5000 0 0 0 0 -5.2100 0 0 -12.5000 0 0 0 0 0 0 0 0 0 0 12.5000 0 0 12.5000 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 slicot-5.0+20101122/examples77/AB09DD.res000077500000000000000000000014071201767322700171250ustar00rootroot00000000000000 AB09DD EXAMPLE PROGRAM RESULTS The computed reciprocal condition number = 1.00000D+00 The reduced state dynamics matrix Ar is -0.0416 4.9200 -4.9200 0.0000 0.0000 -1.3879 -3.3300 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 4.9200 -0.0416 4.9200 0.0000 0.0000 0.0000 -1.3879 -3.3300 The reduced input/state matrix Br is 0.0000 0.0000 3.3300 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 The reduced state/output matrix Cr is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 The reduced input/output matrix Dr is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09ED.dat000077500000000000000000000015411201767322700171040ustar00rootroot00000000000000 AB09ED EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -0.6D0 1.E-1 1.E-14 C N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09ED.res000077500000000000000000000015231201767322700171250ustar00rootroot00000000000000 AB09ED EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of ALPHA-stable part are 1.9178 0.8621 0.7666 0.0336 0.0246 The reduced state dynamics matrix Ar is -0.5181 -1.1084 0.0000 0.0000 0.0000 8.8157 -0.5181 0.0000 0.0000 0.0000 0.0000 0.0000 -1.2769 7.3264 0.0000 0.0000 0.0000 -0.6203 -1.2769 0.0000 0.0000 0.0000 0.0000 0.0000 -1.5496 The reduced input/state matrix Br is -1.2837 1.2837 -0.7522 0.7522 3.2016 3.2016 -0.7640 -0.7640 1.3415 -1.3415 The reduced state/output matrix Cr is -0.1380 -0.6445 -0.6247 -2.0857 -0.8964 0.6246 0.0196 0.0000 0.0000 0.6131 0.1380 0.6445 -0.6247 -2.0857 0.8964 The reduced input/output matrix Dr is 0.0168 -0.0168 0.0008 -0.0008 -0.0168 0.0168 slicot-5.0+20101122/examples77/AB09FD.dat000077500000000000000000000014571201767322700171130ustar00rootroot00000000000000 AB08FD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -1.e-1 .1 1.E-10 C L I B S A -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09FD.res000077500000000000000000000014011201767322700171210ustar00rootroot00000000000000 AB09FD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of coprime factors are 13.6047 9.4106 1.7684 0.7456 0.6891 0.0241 0.0230 The reduced state dynamics matrix Ar is 0.0520 -0.1491 0.0037 -0.0232 0.0168 0.2340 0.2618 0.0010 -0.0153 -0.0318 0.1197 0.0075 -0.5752 2.0119 -0.7779 0.1571 -0.2019 -2.1282 -2.1192 -0.3618 0.0368 -0.4810 0.8395 -0.2790 -2.8796 The reduced input/state matrix Br is 1.0454 0.5860 -0.0489 -1.9194 -1.4282 0.0541 -1.6144 -0.7533 0.5916 -1.9242 The reduced state/output matrix Cr is 0.4368 0.1122 -1.2917 1.5888 -0.6354 1.1170 0.3963 0.6115 0.1249 -0.0859 0.0756 -1.8904 0.0144 0.7964 1.9085 slicot-5.0+20101122/examples77/AB09GD.dat000077500000000000000000000015621201767322700171110ustar00rootroot00000000000000 AB08GD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -1.e-1 .1 1.E-10 1.E-10 C L I B S A -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09GD.res000077500000000000000000000015431201767322700171310ustar00rootroot00000000000000 AB09GD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of coprime factors are 13.6047 9.4106 1.7684 0.7456 0.6891 0.0241 0.0230 The reduced state dynamics matrix Ar is 0.0521 -0.1491 0.0032 -0.0242 0.0181 0.2341 0.2615 0.0009 -0.0171 -0.0362 0.1170 0.0076 -0.5471 2.0904 -0.8098 0.1675 -0.2122 -2.2113 -2.4097 -0.4139 0.0390 -0.5061 0.8787 -0.3166 -3.2955 The reduced input/state matrix Br is 1.0449 0.5863 -0.0490 -1.9210 -1.3930 0.0540 -1.7206 -0.8039 0.6358 -2.0542 The reduced state/output matrix Cr is 0.4331 0.1125 -1.2534 1.6965 -0.6773 1.1171 0.3963 0.6102 0.1213 -0.0841 0.0736 -1.8815 0.0134 0.8457 2.0413 The reduced input/output matrix Dr is 0.0480 0.0003 -0.0017 0.0001 0.0005 0.0460 slicot-5.0+20101122/examples77/AB09HD.dat000077500000000000000000000015621201767322700171120ustar00rootroot00000000000000 AB09HD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 0.0 1.0 0.1E0 0.0 C F N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09HD.res000077500000000000000000000015601201767322700171310ustar00rootroot00000000000000 AB09HD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The stochastic Hankel singular values of ALPHA-stable part are 0.8803 0.8506 0.8038 0.4494 0.3973 0.0214 0.0209 The reduced state dynamics matrix Ar is 1.2729 0.0000 6.5947 0.0000 -3.4229 0.0000 0.8169 0.0000 2.4821 0.0000 -2.9889 0.0000 -2.9028 0.0000 -0.3692 0.0000 -3.3921 0.0000 -3.1126 0.0000 -1.4767 0.0000 -2.0339 0.0000 -0.6107 The reduced input/state matrix Br is 0.1331 -0.1331 -0.0862 -0.0862 -2.6777 2.6777 -3.5767 -3.5767 -2.3033 2.3033 The reduced state/output matrix Cr is -0.6907 -0.6882 0.0779 0.0958 -0.0038 0.0676 0.0000 0.6532 0.0000 -0.7522 0.6907 -0.6882 -0.0779 0.0958 0.0038 The reduced input/output matrix Dr is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09ID.dat000077500000000000000000000013401201767322700171050ustar00rootroot00000000000000 AB09ID EXAMPLE PROGRAM DATA (Continuous system) 3 1 1 6 1 0 0 2 0.0 0.0 0.0 0.1E0 0.0 C S S F L S F -26.4000 6.4023 4.3868 32.0000 0 0 0 8.0000 0 16 0 0 9.2994 1.1624 0.1090 0 -1.0000 0 4.0000 -9.2994 -1.1624 -0.1090 0 2.0000 0 -9.2994 -1.1624 -0.1090 0 0 -3.0000 -9.2994 -1.1624 -0.1090 16.0000 16.0000 16.0000 -26.4000 6.4023 4.3868 0 0 0 32.0000 0 0 0 0 0 0 8.0000 0 1 1 1 0 0 0 1 1 1 0 0 0 0 slicot-5.0+20101122/examples77/AB09ID.res000077500000000000000000000006211201767322700171270ustar00rootroot00000000000000 AB09ID EXAMPLE PROGRAM RESULTS The order of reduced model = 2 The Hankel singular values of weighted ALPHA-stable part are 3.8253 0.2005 The reduced state dynamics matrix Ar is 9.1900 0.0000 0.0000 -34.5297 The reduced input/state matrix Br is 11.9593 16.9329 The reduced state/output matrix Cr is 2.8955 6.9152 The reduced input/output matrix Dr is 0.0000 slicot-5.0+20101122/examples77/AB09JD.dat000077500000000000000000000013141201767322700171070ustar00rootroot00000000000000 AB09JD EXAMPLE PROGRAM DATA (Continuous system) 6 1 1 2 0 0 0.0 1.E-1 1.E-14 V N I C S A -3.8637 -7.4641 -9.1416 -7.4641 -3.8637 -1.0000 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0.2000 -1.0000 1.0000 0 1 0 -1.8000 0 1 slicot-5.0+20101122/examples77/AB09JD.res000077500000000000000000000011111201767322700171230ustar00rootroot00000000000000 AB09JD EXAMPLE PROGRAM RESULTS The order of reduced model = 4 The Hankel singular values of weighted ALPHA-stable part are 2.6790 2.1589 0.8424 0.1929 0.0219 0.0011 The reduced state dynamics matrix Ar is -0.2391 0.3072 1.1630 1.1967 -2.9709 -0.2391 2.6270 3.1027 0.0000 0.0000 -0.5137 -1.2842 0.0000 0.0000 0.1519 -0.5137 The reduced input/state matrix Br is -1.0497 -3.7052 0.8223 0.7435 The reduced state/output matrix Cr is -0.4466 0.0143 -0.4780 -0.2013 The reduced input/output matrix Dr is 0.0219 slicot-5.0+20101122/examples77/AB09KD.dat000077500000000000000000000013111201767322700171050ustar00rootroot00000000000000 AB09KD EXAMPLE PROGRAM DATA (Continuous system) 6 1 1 2 0 0 0.0 1.E-1 1.E-14 N C L S A -3.8637 -7.4641 -9.1416 -7.4641 -3.8637 -1.0000 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 0 0 0 0 0 1.0000 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0.2000 -1.0000 1.0000 0 1 0 -1.8000 0 1 slicot-5.0+20101122/examples77/AB09KD.res000077500000000000000000000011111201767322700171240ustar00rootroot00000000000000 AB09KD EXAMPLE PROGRAM RESULTS The order of reduced model = 4 The Hankel singular values of weighted ALPHA-stable part are 2.6790 2.1589 0.8424 0.1929 0.0219 0.0011 The reduced state dynamics matrix Ar is -0.2391 0.3072 1.1630 1.1967 -2.9709 -0.2391 2.6270 3.1027 0.0000 0.0000 -0.5137 -1.2842 0.0000 0.0000 0.1519 -0.5137 The reduced input/state matrix Br is -1.0497 -3.7052 0.8223 0.7435 The reduced state/output matrix Cr is -0.4466 0.0143 -0.4780 -0.2013 The reduced input/output matrix Dr is 0.0219 slicot-5.0+20101122/examples77/AB09MD.dat000077500000000000000000000014471201767322700171210ustar00rootroot00000000000000 AB09MD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -.6D0 1.D-1 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09MD.res000077500000000000000000000013611201767322700171350ustar00rootroot00000000000000 AB09MD EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of ALPHA-stable part are 1.9178 0.8621 0.7666 0.0336 0.0246 The reduced state dynamics matrix Ar is -0.5181 -1.1084 0.0000 0.0000 0.0000 8.8157 -0.5181 0.0000 0.0000 0.0000 0.0000 0.0000 0.5124 0.0000 1.7910 0.0000 0.0000 0.0000 -1.4460 0.0000 0.0000 0.0000 -4.2167 0.0000 -2.9900 The reduced input/state matrix Br is -1.2837 1.2837 -0.7522 0.7522 -0.7447 -0.7447 1.9275 -1.9275 -3.6872 -3.6872 The reduced state/output matrix Cr is -0.1380 -0.6445 -0.6582 -0.5771 0.2222 0.6246 0.0196 0.0000 0.4131 0.0000 0.1380 0.6445 -0.6582 0.5771 0.2222 slicot-5.0+20101122/examples77/AB09ND.dat000077500000000000000000000015531201767322700171200ustar00rootroot00000000000000 AB09ND EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0 -.6D0 1.D-1 1.E-14 C N N A -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB09ND.res000077500000000000000000000015231201767322700171360ustar00rootroot00000000000000 AB09ND EXAMPLE PROGRAM RESULTS The order of reduced model = 5 The Hankel singular values of ALPHA-stable part are 1.9178 0.8621 0.7666 0.0336 0.0246 The reduced state dynamics matrix Ar is -0.5181 -1.1084 0.0000 0.0000 0.0000 8.8157 -0.5181 0.0000 0.0000 0.0000 0.0000 0.0000 0.5847 0.0000 1.9230 0.0000 0.0000 0.0000 -1.6606 0.0000 0.0000 0.0000 -4.3823 0.0000 -3.2922 The reduced input/state matrix Br is -1.2837 1.2837 -0.7522 0.7522 -0.6379 -0.6379 2.0656 -2.0656 -3.9315 -3.9315 The reduced state/output matrix Cr is -0.1380 -0.6445 -0.6416 -0.6293 0.2526 0.6246 0.0196 0.0000 0.4107 0.0000 0.1380 0.6445 -0.6416 0.6293 0.2526 The reduced input/output matrix Dr is 0.0582 -0.0090 0.0015 -0.0015 -0.0090 0.0582 slicot-5.0+20101122/examples77/AB13AD.dat000077500000000000000000000014231201767322700170720ustar00rootroot00000000000000 AB13AD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 0.0 C N -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB13AD.res000077500000000000000000000003201201767322700171060ustar00rootroot00000000000000 AB13AD EXAMPLE PROGRAM RESULTS The Hankel-norm of the ALPHA-projection = 2.51388D+00 The Hankel singular values of ALPHA-projection are 2.5139 2.0846 1.9178 0.7666 0.5473 0.0253 0.0246 slicot-5.0+20101122/examples77/AB13BD.dat000077500000000000000000000015271201767322700171000ustar00rootroot00000000000000 AB13BD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 1.E-10 C L -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/AB13BD.res000077500000000000000000000001151201767322700171110ustar00rootroot00000000000000 AB13BD EXAMPLE PROGRAM RESULTS The L2-norm of the system = 7.93948D+00 slicot-5.0+20101122/examples77/AB13CD.dat000077500000000000000000000006121201767322700170730ustar00rootroot00000000000000 AB13CD EXAMPLE PROGRAM DATA 6 1 1 0.0 1.0 0.0 0.0 0.0 0.0 -0.5 -0.0002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -1.0 -0.00002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -2.0 -0.000002 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 0.000000001 slicot-5.0+20101122/examples77/AB13CD.res000077500000000000000000000002031201767322700171100ustar00rootroot00000000000000 AB13CD EXAMPLE PROGRAM RESULTS The H_infty norm of the system is 0.5000000006D+06 The peak frequency is 0.1414213562D+01 slicot-5.0+20101122/examples77/AB13DD.dat000077500000000000000000000006641201767322700171030ustar00rootroot00000000000000 AB13CD EXAMPLE PROGRAM DATA 6 1 1 0.0 1.0 0.000000001 C I N D 0.0 1.0 0.0 0.0 0.0 0.0 -0.5 -0.0002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -1.0 -0.00002 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 -2.0 -0.000002 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 0.0 slicot-5.0+20101122/examples77/AB13DD.res000077500000000000000000000002031201767322700171110ustar00rootroot00000000000000 AB13DD EXAMPLE PROGRAM RESULTS The L_infty norm of the system is 0.5000000001D+06 The peak frequency is 0.1414213562D+01 slicot-5.0+20101122/examples77/AB13ED.dat000077500000000000000000000004011201767322700170710ustar00rootroot00000000000000AB13ED EXAMPLE PROGRAM DATA 5, 9.0D0 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 1.0D-01 slicot-5.0+20101122/examples77/AB13ED.res000077500000000000000000000011431201767322700171160ustar00rootroot00000000000000 AB13ED EXAMPLE PROGRAM RESULTS N = 5 TOL = 0.900D+01 Matrix A ( 5X 5) 1 2 3 4 5 1 0.1000000D+00 0.1000000D+01 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.1000000D+00 0.1000000D+01 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.1000000D+00 0.1000000D+01 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+00 0.1000000D+01 5 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+00 LOW = 0.20929379255D-05 HIGH = 0.20793050504D-04 slicot-5.0+20101122/examples77/AB13FD.dat000077500000000000000000000004321201767322700170760ustar00rootroot00000000000000AB13FD EXAMPLE PROGRAM DATA 4 0.0D-00 0.0D-00 246.500 242.500 202.500 -197.500 -252.500 -248.500 -207.500 202.500 -302.500 -297.500 -248.500 242.500 -307.500 -302.500 -252.500 246.500 slicot-5.0+20101122/examples77/AB13FD.res000077500000000000000000000007271201767322700171260ustar00rootroot00000000000000 AB13FD EXAMPLE PROGRAM RESULTS N = 4 TOL = 0.000D+00 A ( 4X 4) 1 2 3 4 1 0.2465000D+03 0.2425000D+03 0.2025000D+03 -0.1975000D+03 2 -0.2525000D+03 -0.2485000D+03 -0.2075000D+03 0.2025000D+03 3 -0.3025000D+03 -0.2975000D+03 -0.2485000D+03 0.2425000D+03 4 -0.3075000D+03 -0.3025000D+03 -0.2525000D+03 0.2465000D+03 Stability radius : 0.39196472317D-02 Minimizing omega : 0.98966520430D+00 slicot-5.0+20101122/examples77/AB13MD.dat000077500000000000000000000012741201767322700171120ustar00rootroot00000000000000 AB13MD EXAMPLE PROGRAM DATA 6 5 1 1 2 1 1 1 1 2 2 2 (-1.0D0,6.0D0) (2.0D0,-3.0D0) (3.0D0,8.0D0) (3.0D0,8.0D0) (-5.0D0,-9.0D0) (-6.0D0,2.0D0) (4.0D0,2.0D0) (-2.0D0,5.0D0) (-6.0D0,-7.0D0) (-4.0D0,11.0D0) (8.0D0,-7.0D0) (12.0D0,-1.0D0) (5.0D0,-4.0D0) (-4.0D0,-8.0D0) (1.0D0,-3.0D0) (-6.0D0,14.0D0) (2.0D0,-5.0D0) (4.0D0,16.0D0) (-1.0D0,6.0D0) (2.0D0,-3.0D0) (3.0D0,8.0D0) (3.0D0,8.0D0) (-5.0D0,-9.0D0) (-6.0D0,2.0D0) (4.0D0,2.0D0) (-2.0D0,5.0D0) (-6.0D0,-7.0D0) (-4.0D0,11.0D0) (8.0D0,-7.0D0) (12.0D0,-1.0D0) (5.0D0,-4.0D0) (-4.0D0,-8.0D0) (1.0D0,-3.0D0) (-6.0D0,14.0D0) (2.0D0,-5.0D0) (4.0D0,16.0D0) slicot-5.0+20101122/examples77/AB13MD.res000077500000000000000000000001431201767322700171250ustar00rootroot00000000000000 AB13MD EXAMPLE PROGRAM RESULTS The value of the structured singular value is 0.4174753408D+02 slicot-5.0+20101122/examples77/AG08BD.dat000077500000000000000000000026521201767322700171110ustar00rootroot00000000000000 AG08BD EXAMPLE PROGRAM DATA 9 9 3 3 1.e-7 N 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 -1 0 0 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 1 1 0 3 4 0 0 2 0 1 0 0 4 0 0 2 0 0 0 1 0 -1 4 0 -2 2 1 2 -2 0 -1 -2 0 0 0 slicot-5.0+20101122/examples77/AG08BD.res000077500000000000000000000032451201767322700171310ustar00rootroot00000000000000 AG08BD EXAMPLE PROGRAM RESULTS The number of infinite poles = 6 0 infinite pole(s) of order 1 3 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of A-lambda*E are 3 3 3 The system has no finite poles The number of unobservable infinite poles = 4 0 infinite pole(s) of order 1 2 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E;C] are 1 3 3 The left Kronecker indices of [A-lambda*E;C] are 0 1 1 The system (A-lambda*E,C) has no finite output decoupling zeros The number of uncontrollable infinite poles = 0 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E,B] are 1 1 1 The right Kronecker indices of [A-lambda*E,B] are 2 2 2 The system (A-lambda*E,B) has no finite input decoupling zeros Normal rank of transfer function matrix = 2 The number of finite zeros = 1 The finite zeros are the eigenvalues of the pair (Af,Ef) The matrix Af is 0.7705 The matrix Ef is 0.7705 Finite zeros real part imag part 1.0000 The number of infinite zeros = 2 0 infinite zero(s) of order 1 1 infinite zero(s) of order 2 The number of infinite Kronecker blocks = 5 Multiplicities of infinite eigenvalues of [A-lambda*E,B;C,D] are 1 1 1 1 3 The number of right Kronecker indices = 1 Right Kronecker indices of [A-lambda*E,B;C,D] are 2 The number of left Kronecker indices = 1 The left Kronecker indices of [A-lambda*E,B;C,D] are 1 slicot-5.0+20101122/examples77/AG08BZ.dat000077500000000000000000000036261201767322700171410ustar00rootroot00000000000000 AG08BZ EXAMPLE PROGRAM DATA 9 9 3 3 1.e-7 N (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (0,0) (-1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (-1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (-1,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (0,0) (1,0) (1,0) (0,0) (3,0) (4,0) (0,0) (0,0) (2,0) (0,0) (1,0) (0,0) (0,0) (4,0) (0,0) (0,0) (2,0) (0,0) (0,0) (0,0) (1,0) (0,0) (-1,0) (4,0) (0,0) (-2,0) (2,0) (1,0) (2,0) (-2,0) (0,0) (-1,0) (-2,0) (0,0) (0,0) (0,0) slicot-5.0+20101122/examples77/AG08BZ.res000077500000000000000000000033101201767322700171500ustar00rootroot00000000000000 AG08BZ EXAMPLE PROGRAM RESULTS The number of infinite poles = 6 0 infinite pole(s) of order 1 3 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of A-lambda*E are 3 3 3 The system has no finite poles The number of unobservable infinite poles = 4 0 infinite pole(s) of order 1 2 infinite pole(s) of order 2 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E;C] are 1 3 3 The left Kronecker indices of [A-lambda*E;C] are 0 1 1 The system (A-lambda*E,C) has no finite output decoupling zeros The number of uncontrollable infinite poles = 0 The number of infinite Kronecker blocks = 3 Multiplicities of infinite eigenvalues of [A-lambda*E,B] are 1 1 1 The right Kronecker indices of [A-lambda*E,B] are 2 2 2 The system (A-lambda*E,B) has no finite input decoupling zeros Normal rank of transfer function matrix = 2 The number of finite zeros = 1 The finite zeros are the eigenvalues of the pair (Af,Ef) The matrix Af is -0.7705 +0.0000i The matrix Ef is -0.7705 +0.0000i Finite zeros real part imag part 1.0000 +0.0000i The number of infinite zeros = 2 0 infinite zero(s) of order 1 1 infinite zero(s) of order 2 The number of infinite Kronecker blocks = 5 Multiplicities of infinite eigenvalues of [A-lambda*E,B;C,D] are 1 1 1 1 3 The number of right Kronecker indices = 1 Right Kronecker indices of [A-lambda*E,B;C,D] are 2 The number of left Kronecker indices = 1 The left Kronecker indices of [A-lambda*E,B;C,D] are 1 slicot-5.0+20101122/examples77/BB01AD.dat000077500000000000000000000001101201767322700170600ustar00rootroot00000000000000BB01AD EXAMPLE PROGRAM DATA N 2 3 6 .T. .T. .T. .F. .F. .T. 1 .1234 0 slicot-5.0+20101122/examples77/BB01AD.res000077500000000000000000000010051201767322700171050ustar00rootroot00000000000000 BB01AD EXAMPLE PROGRAM RESULTS Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 2 A = 0.0000 0.1234 0.0000 0.0000 B is not provided. C = 1.0000 0.0000 0.0000 1.0000 G = 0.0000 0.0000 0.0000 1.0000 Q is not provided. W = 1.0000 0.0000 0.0000 1.0000 R is not provided. X = 9.0486 1.0000 1.0000 1.1166 slicot-5.0+20101122/examples77/BB02AD.dat000077500000000000000000000001121201767322700170630ustar00rootroot00000000000000BB02AD EXAMPLE PROGRAM DATA N 2 3 7 .T. .T. .T. .F. .F. .T. .T. 1 .1234 0 slicot-5.0+20101122/examples77/BB02AD.res000077500000000000000000000007631201767322700171200ustar00rootroot00000000000000 BB02AD EXAMPLE PROGRAM RESULTS increasingly bad scaled system as eps -> oo Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 2 A = 0.0000 0.1234 0.0000 0.0000 B = 0.0000 1.0000 C is not provided. G is not provided. Q = 1.0000 0.0000 0.0000 1.0000 Q0 is not provided. R = 1.0000 S = 0.0000 0.0000 X = 1.0000 0.0000 0.0000 1.0152 slicot-5.0+20101122/examples77/BB03AD.dat000077500000000000000000000000641201767322700170720ustar00rootroot00000000000000BB03AD EXAMPLE PROGRAM DATA N 4 1 2 .15D1 .15D1 1 5 slicot-5.0+20101122/examples77/BB03AD.res000077500000000000000000000017461201767322700171230ustar00rootroot00000000000000 BB03AD EXAMPLE PROGRAM RESULTS CTLEX: Example 4.1 Order of matrix A: N = 5 Number of rows in matrix B: M = 1 E is the identity matrix. A = -3.6360 -0.6921 -1.1933 -0.8137 0.3507 0.1406 -2.9375 0.9063 0.1562 0.3438 -2.5735 -1.4421 -2.8183 -1.1887 1.2257 -0.3779 0.0810 0.5544 -1.5891 0.0660 0.8961 1.1586 1.6279 0.5631 -2.2066 B = -3.6914 -3.9753 -0.0247 -1.9012 1.1111 Y = -13.6261 -14.6743 -0.0911 -7.0181 4.1015 -14.6743 -15.8031 -0.0982 -7.5580 4.4170 -0.0911 -0.0982 -0.0006 -0.0469 0.0274 -7.0181 -7.5580 -0.0469 -3.6147 2.1125 4.1015 4.4170 0.0274 2.1125 -1.2346 X = 1.7737 1.9307 -0.0703 1.0497 -0.4681 1.9307 2.1036 -0.0752 1.1489 -0.5069 -0.0703 -0.0752 0.0076 -0.0428 0.0178 1.0497 1.1489 -0.0428 0.6509 -0.2651 -0.4681 -0.5069 0.0178 -0.2651 0.1284 U is not provided. slicot-5.0+20101122/examples77/BB04AD.dat000077500000000000000000000000641201767322700170730ustar00rootroot00000000000000BB04AD EXAMPLE PROGRAM DATA N 4 1 2 .15D1 .15D1 1 5 slicot-5.0+20101122/examples77/BB04AD.res000077500000000000000000000017461201767322700171240ustar00rootroot00000000000000 BB04AD EXAMPLE PROGRAM RESULTS DTLEX: Example 4.1 Order of matrix A: N = 5 Number of rows in matrix B: M = 1 E is the identity matrix. A = 0.4562 0.0308 0.1990 0.0861 0.0217 0.0637 0.5142 -0.1828 0.0096 -0.1148 0.3139 0.1287 0.3484 0.1653 -0.1975 0.1500 0.0053 -0.1838 0.2501 -0.0687 0.0568 -0.1006 -0.3735 -0.0202 0.2285 B = 0.3086 0.0247 -0.4691 0.1728 -0.3704 Y = -0.0953 -0.0076 0.1448 -0.0533 0.1143 -0.0076 -0.0006 0.0116 -0.0043 0.0091 0.1448 0.0116 -0.2201 0.0811 -0.1738 -0.0533 -0.0043 0.0811 -0.0299 0.0640 0.1143 0.0091 -0.1738 0.0640 -0.1372 X = 0.0953 0.0076 -0.1448 0.0533 -0.1143 0.0076 0.0006 -0.0116 0.0043 -0.0091 -0.1448 -0.0116 0.2201 -0.0811 0.1738 0.0533 0.0043 -0.0811 0.0299 -0.0640 -0.1143 -0.0091 0.1738 -0.0640 0.1372 U is not provided. slicot-5.0+20101122/examples77/BD01AD.dat000077500000000000000000000000421201767322700170660ustar00rootroot00000000000000BD01AD EXAMPLE PROGRAM DATA D 1 1 slicot-5.0+20101122/examples77/BD01AD.res000077500000000000000000000006141201767322700171140ustar00rootroot00000000000000 BD01AD EXAMPLE PROGRAM RESULTS Laub 1979, Ex.1 Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 2 E is the identity matrix. A = 0.0000 1.0000 0.0000 0.0000 B = 0.0000 1.0000 C = 1.0000 0.0000 0.0000 1.0000 D is of zeros. slicot-5.0+20101122/examples77/BD02AD.dat000077500000000000000000000000421201767322700170670ustar00rootroot00000000000000BD02AD EXAMPLE PROGRAM DATA D 1 1 slicot-5.0+20101122/examples77/BD02AD.res000077500000000000000000000005711201767322700171170ustar00rootroot00000000000000 BD02AD EXAMPLE PROGRAM RESULTS Laub 1979, Ex. 2: uncontrollable-unobservable data Order of matrix A: N = 2 Number of columns in matrix B: M = 1 Number of rows in matrix C: P = 1 E is the identity matrix. A = 4.0000 3.0000 -4.5000 -3.5000 B = 1.0000 -1.0000 C = 3.0000 2.0000 D is of zeros. slicot-5.0+20101122/examples77/DE01OD.dat000077500000000000000000000003001201767322700171040ustar00rootroot00000000000000 DE01OD EXAMPLE PROGRAM DATA 8 C 0.4862 0.2288 0.1948 0.3671 0.5788 0.6417 -0.5861 0.3875 0.8254 0.2380 0.1815 0.4682 0.2904 0.5312 -0.3599 0.6116 slicot-5.0+20101122/examples77/DE01OD.res000077500000000000000000000002601201767322700171320ustar00rootroot00000000000000 DE01OD EXAMPLE PROGRAM RESULTS Convolution i A(i) 1 0.5844 2 0.5769 3 0.6106 4 1.0433 5 0.6331 6 0.4531 7 0.7027 8 0.9929 slicot-5.0+20101122/examples77/DE01PD.dat000077500000000000000000000003061201767322700171130ustar00rootroot00000000000000 DE01PD EXAMPLE PROGRAM DATA 8 C N 0.4862 0.2288 0.1948 0.3671 0.5788 0.6417 -0.5861 0.3875 0.8254 0.2380 0.1815 0.4682 0.2904 0.5312 -0.3599 0.6116 slicot-5.0+20101122/examples77/DE01PD.res000077500000000000000000000002601201767322700171330ustar00rootroot00000000000000 DE01PD EXAMPLE PROGRAM RESULTS Convolution i A(i) 1 0.5844 2 0.5769 3 0.6106 4 1.0433 5 0.6331 6 0.4531 7 0.7027 8 0.9929 slicot-5.0+20101122/examples77/DF01MD.dat000077500000000000000000000003321201767322700171100ustar00rootroot00000000000000 DF01MD EXAMPLE PROGRAM DATA 17 1.0 C -0.1862 0.1288 0.3948 0.0671 0.6788 -0.2417 0.1861 0.8875 0.7254 0.9380 0.5815 -0.2682 0.4904 0.9312 -0.9599 -0.3116 0.8743 slicot-5.0+20101122/examples77/DF01MD.res000077500000000000000000000005461201767322700171400ustar00rootroot00000000000000 DF01MD EXAMPLE PROGRAM RESULTS Components of cosine transform are i A(i) 1 28.0536 2 3.3726 3 -20.8158 4 6.0566 5 5.7317 6 -3.9347 7 -12.8074 8 -6.8780 9 16.2892 10 -17.0788 11 21.7836 12 -20.8203 13 -7.3277 14 -2.5325 15 -0.3636 16 7.8792 17 11.0048 slicot-5.0+20101122/examples77/DG01MD.dat000077500000000000000000000003001201767322700171040ustar00rootroot00000000000000 DG01MD EXAMPLE PROGRAM DATA 8 D -0.1862 0.1288 0.3948 0.0671 0.6788 -0.2417 0.1861 0.8875 0.7254 0.9380 0.5815 -0.2682 0.4904 0.9312 -0.9599 -0.3116 slicot-5.0+20101122/examples77/DG01MD.res000077500000000000000000000004731201767322700171400ustar00rootroot00000000000000 DG01MD EXAMPLE PROGRAM RESULTS Components of Fourier transform are i XR(i) XI(i) 1 1.9109 2.1311 2 -1.9419 -2.2867 3 -1.4070 -1.3728 4 2.2886 -0.6883 5 1.5059 1.3815 6 -2.2271 0.2915 7 0.1470 2.1274 8 -1.7660 -0.5533 slicot-5.0+20101122/examples77/DG01ND.dat000077500000000000000000000003101201767322700171060ustar00rootroot00000000000000 DG01ND EXAMPLE PROGRAM DATA 8 D -0.1862 0.1288 0.3948 0.0671 0.6788 -0.2417 0.1861 0.8875 0.7254 0.9380 0.5815 -0.2682 0.4904 0.9312 -0.9599 -0.3116 slicot-5.0+20101122/examples77/DG01ND.res000077500000000000000000000005261201767322700171400ustar00rootroot00000000000000 DG01ND EXAMPLE PROGRAM RESULTS Components of Fourier transform are i XR(i) XI(i) 1 4.0420 0.0000 2 -3.1322 -0.2421 3 0.1862 -1.4675 4 -2.1312 -1.1707 5 1.5059 -1.3815 6 2.1927 -0.1908 7 -1.4462 2.0327 8 -0.5757 1.4914 9 -0.2202 0.0000 slicot-5.0+20101122/examples77/DG01OD.dat000077500000000000000000000001631201767322700171150ustar00rootroot00000000000000 DG01OD EXAMPLE 16 N N 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 slicot-5.0+20101122/examples77/DG01OD.res000077500000000000000000000004461201767322700171420ustar00rootroot00000000000000 DG01OD EXAMPLE PROGRAM RESULTS Hartley transform i A(i) 1 136.0000 2 -48.2187 3 -27.3137 4 -19.9728 5 -16.0000 6 -13.3454 7 -11.3137 8 -9.5913 9 -8.0000 10 -6.4087 11 -4.6863 12 -2.6546 13 0.0000 14 3.9728 15 11.3137 16 32.2187 slicot-5.0+20101122/examples77/DK01MD.dat000077500000000000000000000001701201767322700171150ustar00rootroot00000000000000 DK01MD EXAMPLE PROGRAM DATA 8 M 0.3262 0.8723 -0.7972 0.6673 -0.1722 0.3237 0.5263 -0.3275 slicot-5.0+20101122/examples77/DK01MD.res000077500000000000000000000003341201767322700171400ustar00rootroot00000000000000 DK01MD EXAMPLE PROGRAM RESULTS Components of the windowing function are k A(k) 1 0.3262 2 0.8326 3 -0.6591 4 0.4286 5 -0.0754 6 0.0820 7 0.0661 8 -0.0262 slicot-5.0+20101122/examples77/FB01QD.dat000077500000000000000000000010461201767322700171150ustar00rootroot00000000000000 FB01QD EXAMPLE PROGRAM DATA 4 2 2 K 0.0 N 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.2113 0.8497 0.7263 0.8833 0.7560 0.6857 0.1985 0.6525 0.0002 0.8782 0.5442 0.3076 0.3303 0.0683 0.2320 0.9329 0.5618 0.5042 0.5896 0.3493 0.6853 0.3873 0.8906 0.9222 1.0000 0.0000 0.0000 1.0000 0.3616 0.5664 0.5015 0.2693 0.2922 0.4826 0.4368 0.6325 0.9488 0.0000 0.3760 0.7340 slicot-5.0+20101122/examples77/FB01QD.res000077500000000000000000000005221201767322700171340ustar00rootroot00000000000000 FB01QD EXAMPLE PROGRAM RESULTS The square root of the state covariance matrix is -1.2936 0.0000 0.0000 0.0000 -1.1382 -0.2579 0.0000 0.0000 -0.9622 -0.1529 0.2974 0.0000 -1.3076 0.0936 0.4508 -0.4897 The Kalman gain matrix is 0.3638 0.9469 0.3532 0.8179 0.2471 0.5542 0.1982 0.6471 slicot-5.0+20101122/examples77/FB01RD.dat000077500000000000000000000010461201767322700171160ustar00rootroot00000000000000 FB01RD EXAMPLE PROGRAM DATA 4 2 2 K 0.0 N 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.2113 0.8497 0.7263 0.0000 0.7560 0.6857 0.1985 0.6525 0.0002 0.8782 0.5442 0.3076 0.3303 0.0683 0.2320 0.9329 0.5618 0.5042 0.5896 0.3493 0.6853 0.3873 0.8906 0.9222 1.0000 0.0000 0.0000 1.0000 0.3616 0.0000 0.0000 0.0000 0.2922 0.4826 0.0000 0.0000 0.9488 0.0000 0.3760 0.7340 slicot-5.0+20101122/examples77/FB01RD.res000077500000000000000000000005221201767322700171350ustar00rootroot00000000000000 FB01RD EXAMPLE PROGRAM RESULTS The square root of the state covariance matrix is -1.7223 0.0000 0.0000 0.0000 -2.1073 0.5467 0.0000 0.0000 -1.7649 0.1412 -0.1710 0.0000 -1.8291 0.2058 -0.1497 0.7760 The Kalman gain matrix is -0.2135 1.6649 -0.2345 2.1442 -0.2147 1.7069 -0.1345 1.4777 slicot-5.0+20101122/examples77/FB01SD.dat000077500000000000000000000011741201767322700171210ustar00rootroot00000000000000 FB01SD EXAMPLE PROGRAM DATA 4 2 2 X 0.0 P N 0.2113 0.7560 0.0002 0.3303 0.8497 0.6857 0.8782 0.0683 0.7263 0.1985 0.5442 0.2320 0.8833 0.6525 0.3076 0.9329 0.3616 0.5664 0.5015 0.2693 0.2922 0.4826 0.4368 0.6325 1.0000 0.0000 0.0000 1.0000 -0.8805 1.3257 2.1039 0.5207 -0.6075 1.0386 -0.8531 1.1688 1.1159 0.2305 0.0000 0.6597 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0019 0.5075 0.4076 0.8408 0.5017 0.9128 0.2129 0.5591 slicot-5.0+20101122/examples77/FB01SD.res000077500000000000000000000006001201767322700171330ustar00rootroot00000000000000 FB01SD EXAMPLE PROGRAM RESULTS The inverse of the square root of the state covariance matrix is 0.6897 0.7721 0.7079 0.6102 0.0000 -0.3363 -0.2252 -0.2642 0.0000 0.0000 -0.1650 0.0319 0.0000 0.0000 0.0000 0.3708 The components of the estimated filtered state are k X(k) 1 -0.7125 2 -1.8324 3 1.7500 4 1.5854 slicot-5.0+20101122/examples77/FB01TD.dat000077500000000000000000000011661201767322700171230ustar00rootroot00000000000000 FB01TD EXAMPLE PROGRAM DATA 4 2 2 X 0.0 N 0.2113 0.7560 0.0002 0.3303 0.8497 0.6857 0.8782 0.0683 0.7263 0.1985 0.5442 0.2320 0.0000 0.6525 0.3076 0.9329 0.3616 0.5664 0.5015 0.2693 0.2922 0.4826 0.4368 0.6325 1.0000 0.0000 0.0000 1.0000 -0.8805 1.3257 0.0000 0.5207 0.0000 0.0000 0.0000 0.0000 1.1159 0.2305 0.0000 0.6597 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0019 0.5075 0.4076 0.8408 0.5017 0.9128 0.2129 0.5591 slicot-5.0+20101122/examples77/FB01TD.res000077500000000000000000000006001201767322700171340ustar00rootroot00000000000000 FB01TD EXAMPLE PROGRAM RESULTS The inverse of the square root of the state covariance matrix is -0.8731 -1.1461 -1.0260 -0.8901 0.0000 -0.2763 -0.1929 -0.3763 0.0000 0.0000 -0.1110 -0.1051 0.0000 0.0000 0.0000 0.3120 The components of the estimated filtered state are k X(k) 1 -2.0688 2 -0.7814 3 2.2181 4 0.9298 slicot-5.0+20101122/examples77/FB01VD.dat000077500000000000000000000011441201767322700171210ustar00rootroot00000000000000 FB01VD EXAMPLE PROGRAM DATA 4 3 2 0.0 0.5015 0.4368 0.2693 0.6325 0.4368 0.4818 0.2639 0.4148 0.2693 0.2639 0.1121 0.6856 0.6325 0.4148 0.6856 0.8906 0.2113 0.8497 0.7263 0.8833 0.7560 0.6857 0.1985 0.6525 0.0002 0.8782 0.5442 0.3076 0.3303 0.0683 0.2320 0.9329 0.0437 0.7783 0.5618 0.4818 0.2119 0.5896 0.2639 0.1121 0.6853 0.4148 0.6856 0.8906 0.9329 0.2146 0.3126 0.2146 0.2922 0.5664 0.3126 0.5664 0.5935 0.3873 0.9488 0.3760 0.0881 0.9222 0.3435 0.7340 0.4498 1.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/FB01VD.res000077500000000000000000000006561201767322700171510ustar00rootroot00000000000000 FB01VD EXAMPLE PROGRAM RESULTS The state covariance matrix is 1.6007 1.3283 1.1153 1.7177 1.3283 1.2763 1.0132 1.5137 1.1153 1.0132 0.8222 1.2722 1.7177 1.5137 1.2722 2.1562 The Kalman filter gain matrix is 0.1648 0.2241 0.2115 0.1610 0.0728 0.1673 0.1304 0.3892 The square root of the covariance matrix of the innovations is 1.5091 1.1543 0.0000 1.5072 slicot-5.0+20101122/examples77/FD01AD.dat000077500000000000000000000000621201767322700170740ustar00rootroot00000000000000 FD01AD EXAMPLE PROGRAM DATA 2 1.0D-2 B slicot-5.0+20101122/examples77/FD01AD.res000077500000000000000000000003371201767322700171220ustar00rootroot00000000000000 FD01AD EXAMPLE PROGRAM RESULTS i XF(i) YQ(i) EPSBCK(i) 1 4.880088 12.307615 -0.140367 2 -1.456881 2.914057 -0.140367 3 0.980099 EFOR = 0.197D-02 slicot-5.0+20101122/examples77/IB01AD.dat000077500000000000000000000472141201767322700171070ustar00rootroot00000000000000 IB01AD EXAMPLE PROGRAM DATA 15 0 1 1 1000 0.0 -1.0 M C N O N N 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 4.766099 4.763659 4.839359 5.002979 5.017629 5.056699 5.154379 5.361949 5.425439 5.569519 5.681849 5.742899 5.803949 5.918729 5.821049 5.447419 5.061589 4.629349 4.267939 4.011519 3.850349 3.711159 3.569519 3.518239 3.652549 3.818609 3.862559 4.011519 4.353409 4.705049 5.083559 5.344859 5.274039 5.127519 4.761219 4.451089 4.221539 4.045709 3.874769 3.730689 3.662319 3.576849 3.542659 3.479169 3.454749 3.359509 3.298459 3.225199 3.200779 3.225199 3.227639 3.274039 3.457189 3.867449 4.321659 4.492599 4.431549 4.243519 4.050599 3.857679 3.730689 3.791739 3.921169 3.955359 3.847909 3.725809 3.611039 3.716039 4.092109 4.480389 4.814939 5.054259 5.303339 5.486489 5.672089 5.779529 5.799069 5.664759 5.291129 4.880879 4.558529 4.184909 3.889419 3.708719 3.623249 3.569519 3.718479 4.033499 4.412009 4.629349 4.558529 4.394919 4.180019 4.197119 4.431549 4.714819 4.961459 5.300899 5.567079 5.681849 5.545099 5.188569 4.883319 4.600049 4.270379 4.038389 3.838139 3.711159 3.591499 3.535329 3.486489 3.476729 3.425439 3.381489 3.369279 3.364389 3.347299 3.381489 3.420559 3.413229 3.452309 3.635459 4.038389 4.375379 4.727029 5.056699 5.298459 5.532889 5.466959 5.195899 4.885759 4.763659 4.875989 5.042049 5.283809 5.491379 5.596379 5.672089 5.772209 5.830819 5.933379 5.899189 5.935819 5.894309 5.918729 5.994429 5.957799 6.031059 6.062809 6.040829 6.096999 6.123859 6.162929 6.040829 5.845469 5.772209 5.799069 5.923609 5.928499 6.001759 6.001759 6.060369 5.882099 5.510909 5.322879 5.371719 5.454749 5.437649 5.159269 4.902859 4.587839 4.502369 4.595159 4.824709 5.064029 5.271599 5.466959 5.615919 5.528009 5.254499 4.883319 4.517019 4.197119 4.001759 3.806399 3.904079 3.923609 3.869889 3.806399 3.720929 3.818609 4.140949 4.529229 4.805179 5.086009 5.339969 5.532889 5.576849 5.667199 5.791739 5.850349 5.923609 5.921169 5.977339 5.740459 5.388809 5.000539 4.849129 4.944369 5.173919 5.369279 5.447419 5.603709 5.730689 5.850349 5.979779 5.991989 6.084789 5.940709 5.803949 5.791739 5.603709 5.264269 4.946809 4.619579 4.514579 4.433989 4.285029 4.121419 3.945589 3.984659 4.219099 4.546319 4.873549 5.154379 5.388809 5.613479 5.835699 5.884539 5.955359 5.762439 5.459629 5.061589 4.707499 4.458409 4.267939 4.053039 3.943149 3.825929 3.967569 4.280149 4.480389 4.492599 4.390039 4.197119 4.111649 3.982219 3.867449 3.767319 3.872329 4.236189 4.663539 4.971229 5.066469 4.902859 4.675749 4.392479 4.099439 4.114089 4.326539 4.643999 4.971229 5.159269 5.388809 5.576849 5.652549 5.803949 5.913839 5.886979 5.799069 5.730689 5.762439 5.813719 5.821049 5.928499 6.013969 5.764879 5.413229 5.098219 4.678189 4.372939 4.392479 4.590279 4.919949 5.017629 4.858899 4.675749 4.619579 4.834479 5.090889 5.376599 5.681849 5.823489 5.952919 6.062809 6.089669 6.075019 6.026179 5.994429 6.077459 5.857679 5.701389 5.730689 5.784419 5.823489 5.894309 5.762439 5.415679 4.961459 4.595159 4.331429 4.297239 4.582949 4.861339 5.173919 5.166589 4.919949 4.607369 4.370499 4.182469 4.038389 4.145839 4.431549 4.556089 4.480389 4.375379 4.370499 4.558529 4.858899 4.895529 4.741679 4.744129 4.875989 5.105539 5.239849 5.518239 5.652549 5.723369 5.855239 5.962679 5.984659 5.984659 6.055479 6.062809 6.055479 6.070129 5.784419 5.440099 5.056699 4.941929 5.010299 5.134849 5.313109 5.479169 5.623249 5.562199 5.330209 5.010299 4.665979 4.414459 4.201999 4.048159 4.079899 4.189789 4.131179 4.004199 3.916289 3.960239 4.199559 4.624469 4.883319 5.137289 5.379049 5.623249 5.762439 5.833259 5.686739 5.366839 5.225199 5.239849 5.354629 5.508469 5.596379 5.752669 5.874769 5.906519 5.894309 5.742899 5.447419 5.024959 4.883319 4.885759 4.893089 4.714819 4.451089 4.233749 4.043269 3.864999 3.757559 3.669639 3.593939 3.547539 3.506029 3.454749 3.398579 3.361949 3.339969 3.374159 3.520679 3.713599 3.757559 3.779529 3.696509 3.777089 3.886979 3.904079 3.850349 3.965129 4.282589 4.521899 4.714819 4.971229 5.220319 5.532889 5.652549 5.781979 5.955359 6.035939 6.118969 6.133629 6.153159 6.192229 6.143389 6.167809 5.991989 5.652549 5.459629 5.437649 5.339969 5.098219 4.785639 4.492599 4.236189 4.067689 3.933379 3.823489 3.730689 3.611039 3.564639 3.549989 3.557309 3.513359 3.515799 3.694059 4.072579 4.480389 4.705049 4.612259 4.385149 4.201999 4.026179 3.904079 3.774649 3.691619 3.845469 4.201999 4.585399 4.902859 5.256949 5.510909 5.640339 5.843029 5.974889 5.935819 5.821049 5.528009 5.171479 4.810059 4.453529 4.380269 4.565859 4.805179 5.125079 5.354629 5.589059 5.764879 5.923609 5.940709 5.857679 5.694059 5.486489 5.149499 4.844249 4.541439 4.267939 4.060369 3.960239 3.789299 3.642779 3.525569 3.498699 3.454749 3.408349 3.379049 3.376599 3.361949 3.359509 3.369279 3.398579 3.579289 3.948029 4.412009 4.585399 4.514579 4.343639 4.155599 3.984659 4.043269 4.307009 4.421779 4.353409 4.223979 4.053039 3.940709 3.838139 3.730689 3.652549 3.611039 3.564639 3.496259 3.462069 3.454749 3.425439 3.379049 3.432769 3.623249 3.974889 4.380269 4.714819 5.073799 5.369279 5.603709 5.745349 5.652549 5.401019 5.015189 4.709939 4.416899 4.236189 4.236189 4.248399 4.221539 4.297239 4.590279 4.893089 5.134849 5.427889 5.379049 5.364389 5.452309 5.567079 5.672089 5.769769 5.830819 5.923609 5.965129 6.057919 6.050599 6.072579 6.111649 6.070129 5.896749 5.755109 5.718479 5.821049 6.001759 6.001759 5.901629 5.557309 5.173919 4.800289 4.431549 4.194679 4.006639 3.850349 3.747789 3.642779 3.591499 3.569519 3.528009 3.537779 3.554869 3.493819 3.447419 3.440099 3.408349 3.410789 3.452309 3.681849 4.060369 4.441319 4.854019 5.154379 5.425439 5.596379 5.586619 5.354629 5.027399 4.863779 4.761219 4.570739 4.368059 4.397359 4.573189 4.841809 5.203219 5.452309 5.652549 5.855239 5.906519 5.952919 5.828369 5.791739 5.799069 5.813719 5.877209 5.955359 5.781979 5.518239 5.127519 4.763659 4.492599 4.233749 4.011519 3.855239 3.691619 3.635459 3.818609 4.155599 4.590279 4.988329 5.076239 4.907739 4.648889 4.377829 4.216649 4.287469 4.590279 4.846689 5.139729 5.388809 5.689179 5.884539 6.043269 6.170259 6.211769 6.250839 6.209329 6.013969 5.701389 5.469399 5.479169 5.557309 5.728249 5.882099 5.984659 5.901629 5.581729 5.371719 5.418119 5.510909 5.667199 5.791739 5.698949 5.484049 5.154379 4.980999 5.061589 5.195899 5.359509 5.615919 5.762439 5.857679 5.948029 5.835699 5.706269 5.498699 5.188569 5.117749 5.191009 5.315549 5.532889 5.444979 5.396139 5.274039 5.027399 4.744129 4.668419 4.651329 4.514579 4.267939 4.260609 4.263049 4.189789 4.277699 4.600049 4.932159 5.283809 5.528009 5.740459 5.874769 5.955359 5.991989 5.845469 5.528009 5.061589 4.734359 4.534109 4.534109 4.697729 4.744129 4.619579 4.643999 4.832039 5.132399 5.410789 5.625689 5.603709 5.315549 4.961459 4.619579 4.358289 4.155599 4.033499 3.886979 3.772209 3.640339 3.532889 3.435209 3.427889 3.422999 3.398579 3.603709 4.023729 4.451089 4.792969 4.902859 4.780759 4.590279 4.336309 4.145839 4.216649 4.433989 4.714819 5.098219 5.359509 5.569519 5.772209 5.921169 6.055479 5.962679 5.642779 5.435209 5.388809 5.537779 5.681849 5.701389 5.615919 5.667199 5.740459 5.803949 5.882099 5.950469 6.072579 6.148279 6.116529 6.177579 6.201999 6.206889 5.991989 5.564639 5.178799 4.998089 5.051819 5.232529 5.484049 5.686739 5.899189 5.869889 5.977339 6.053039 6.079899 6.128739 6.079899 6.167809 6.194679 6.236189 6.053039 5.652549 5.274039 4.858899 4.534109 4.455969 4.619579 4.866229 5.117749 5.166589 5.056699 5.002979 5.098219 5.325319 5.567079 5.466959 5.252059 4.946809 4.880879 4.980999 5.225199 5.459629 5.723369 5.791739 5.906519 5.991989 5.835699 5.528009 5.142169 4.775869 4.490159 4.236189 4.023729 3.886979 3.752669 3.681849 3.806399 4.145839 4.600049 5.002979 5.303339 5.552429 5.615919 5.523119 5.611039 5.713599 5.845469 5.899189 5.994429 6.092109 6.092109 6.143389 6.153159 6.233749 6.187349 6.013969 5.835699 5.774649 5.686739 5.537779 5.327759 5.054259 4.700169 4.394919 4.180019 4.043269 3.877209 3.752669 3.728249 3.869889 4.206889 4.355849 4.426669 4.453529 4.521899 4.392479 4.155599 3.965129 3.877209 3.970009 4.258169 4.421779 4.336309 4.299679 4.392479 4.675749 4.761219 4.658659 4.490159 4.307009 4.126299 3.972449 4.077459 4.372939 4.741679 5.088449 5.186129 5.037169 4.785639 4.563419 4.534109 4.705049 4.741679 4.648889 4.431549 4.238629 4.065249 3.943149 3.811279 3.691619 3.652549 3.825929 4.223979 4.424219 4.429109 4.319219 4.138509 3.965129 3.886979 3.801509 3.701389 3.640339 3.767319 4.150719 4.648889 4.990769 5.088449 5.022509 4.783199 4.685519 4.665979 4.707499 4.912619 5.195899 5.415679 5.623249 5.740459 5.899189 5.928499 6.050599 6.153159 5.965129 5.586619 5.381489 5.371719 5.486489 5.567079 5.821049 5.913839 5.994429 6.011519 5.999309 6.018849 5.821049 5.728249 5.740459 5.764879 5.882099 5.926049 5.750229 5.415679 4.995649 4.861339 4.902859 5.103099 5.364389 5.596379 5.752669 5.845469 5.928499 6.006639 5.840579 5.518239 5.173919 4.739239 4.458409 4.426669 4.602489 4.822269 5.183689 5.430329 5.652549 5.821049 5.706269 5.369279 5.027399 4.705049 4.414459 4.145839 3.965129 4.033499 4.372939 4.683079 slicot-5.0+20101122/examples77/IB01AD.res000077500000000000000000000003461201767322700171230ustar00rootroot00000000000000 IB01AD EXAMPLE PROGRAM RESULTS The order of the system is 4 The singular values are 69.8841 14.9963 3.6675 1.9677 0.3000 0.2078 0.1651 0.1373 0.1133 0.1059 0.0856 0.0784 0.0733 0.0678 0.0571 slicot-5.0+20101122/examples77/IB01BD.dat000077500000000000000000000472271201767322700171140ustar00rootroot00000000000000 IB01BD EXAMPLE PROGRAM DATA 15 0 1 1 1000 0.0 -1.0 C C N O N N A K 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 4.766099 4.763659 4.839359 5.002979 5.017629 5.056699 5.154379 5.361949 5.425439 5.569519 5.681849 5.742899 5.803949 5.918729 5.821049 5.447419 5.061589 4.629349 4.267939 4.011519 3.850349 3.711159 3.569519 3.518239 3.652549 3.818609 3.862559 4.011519 4.353409 4.705049 5.083559 5.344859 5.274039 5.127519 4.761219 4.451089 4.221539 4.045709 3.874769 3.730689 3.662319 3.576849 3.542659 3.479169 3.454749 3.359509 3.298459 3.225199 3.200779 3.225199 3.227639 3.274039 3.457189 3.867449 4.321659 4.492599 4.431549 4.243519 4.050599 3.857679 3.730689 3.791739 3.921169 3.955359 3.847909 3.725809 3.611039 3.716039 4.092109 4.480389 4.814939 5.054259 5.303339 5.486489 5.672089 5.779529 5.799069 5.664759 5.291129 4.880879 4.558529 4.184909 3.889419 3.708719 3.623249 3.569519 3.718479 4.033499 4.412009 4.629349 4.558529 4.394919 4.180019 4.197119 4.431549 4.714819 4.961459 5.300899 5.567079 5.681849 5.545099 5.188569 4.883319 4.600049 4.270379 4.038389 3.838139 3.711159 3.591499 3.535329 3.486489 3.476729 3.425439 3.381489 3.369279 3.364389 3.347299 3.381489 3.420559 3.413229 3.452309 3.635459 4.038389 4.375379 4.727029 5.056699 5.298459 5.532889 5.466959 5.195899 4.885759 4.763659 4.875989 5.042049 5.283809 5.491379 5.596379 5.672089 5.772209 5.830819 5.933379 5.899189 5.935819 5.894309 5.918729 5.994429 5.957799 6.031059 6.062809 6.040829 6.096999 6.123859 6.162929 6.040829 5.845469 5.772209 5.799069 5.923609 5.928499 6.001759 6.001759 6.060369 5.882099 5.510909 5.322879 5.371719 5.454749 5.437649 5.159269 4.902859 4.587839 4.502369 4.595159 4.824709 5.064029 5.271599 5.466959 5.615919 5.528009 5.254499 4.883319 4.517019 4.197119 4.001759 3.806399 3.904079 3.923609 3.869889 3.806399 3.720929 3.818609 4.140949 4.529229 4.805179 5.086009 5.339969 5.532889 5.576849 5.667199 5.791739 5.850349 5.923609 5.921169 5.977339 5.740459 5.388809 5.000539 4.849129 4.944369 5.173919 5.369279 5.447419 5.603709 5.730689 5.850349 5.979779 5.991989 6.084789 5.940709 5.803949 5.791739 5.603709 5.264269 4.946809 4.619579 4.514579 4.433989 4.285029 4.121419 3.945589 3.984659 4.219099 4.546319 4.873549 5.154379 5.388809 5.613479 5.835699 5.884539 5.955359 5.762439 5.459629 5.061589 4.707499 4.458409 4.267939 4.053039 3.943149 3.825929 3.967569 4.280149 4.480389 4.492599 4.390039 4.197119 4.111649 3.982219 3.867449 3.767319 3.872329 4.236189 4.663539 4.971229 5.066469 4.902859 4.675749 4.392479 4.099439 4.114089 4.326539 4.643999 4.971229 5.159269 5.388809 5.576849 5.652549 5.803949 5.913839 5.886979 5.799069 5.730689 5.762439 5.813719 5.821049 5.928499 6.013969 5.764879 5.413229 5.098219 4.678189 4.372939 4.392479 4.590279 4.919949 5.017629 4.858899 4.675749 4.619579 4.834479 5.090889 5.376599 5.681849 5.823489 5.952919 6.062809 6.089669 6.075019 6.026179 5.994429 6.077459 5.857679 5.701389 5.730689 5.784419 5.823489 5.894309 5.762439 5.415679 4.961459 4.595159 4.331429 4.297239 4.582949 4.861339 5.173919 5.166589 4.919949 4.607369 4.370499 4.182469 4.038389 4.145839 4.431549 4.556089 4.480389 4.375379 4.370499 4.558529 4.858899 4.895529 4.741679 4.744129 4.875989 5.105539 5.239849 5.518239 5.652549 5.723369 5.855239 5.962679 5.984659 5.984659 6.055479 6.062809 6.055479 6.070129 5.784419 5.440099 5.056699 4.941929 5.010299 5.134849 5.313109 5.479169 5.623249 5.562199 5.330209 5.010299 4.665979 4.414459 4.201999 4.048159 4.079899 4.189789 4.131179 4.004199 3.916289 3.960239 4.199559 4.624469 4.883319 5.137289 5.379049 5.623249 5.762439 5.833259 5.686739 5.366839 5.225199 5.239849 5.354629 5.508469 5.596379 5.752669 5.874769 5.906519 5.894309 5.742899 5.447419 5.024959 4.883319 4.885759 4.893089 4.714819 4.451089 4.233749 4.043269 3.864999 3.757559 3.669639 3.593939 3.547539 3.506029 3.454749 3.398579 3.361949 3.339969 3.374159 3.520679 3.713599 3.757559 3.779529 3.696509 3.777089 3.886979 3.904079 3.850349 3.965129 4.282589 4.521899 4.714819 4.971229 5.220319 5.532889 5.652549 5.781979 5.955359 6.035939 6.118969 6.133629 6.153159 6.192229 6.143389 6.167809 5.991989 5.652549 5.459629 5.437649 5.339969 5.098219 4.785639 4.492599 4.236189 4.067689 3.933379 3.823489 3.730689 3.611039 3.564639 3.549989 3.557309 3.513359 3.515799 3.694059 4.072579 4.480389 4.705049 4.612259 4.385149 4.201999 4.026179 3.904079 3.774649 3.691619 3.845469 4.201999 4.585399 4.902859 5.256949 5.510909 5.640339 5.843029 5.974889 5.935819 5.821049 5.528009 5.171479 4.810059 4.453529 4.380269 4.565859 4.805179 5.125079 5.354629 5.589059 5.764879 5.923609 5.940709 5.857679 5.694059 5.486489 5.149499 4.844249 4.541439 4.267939 4.060369 3.960239 3.789299 3.642779 3.525569 3.498699 3.454749 3.408349 3.379049 3.376599 3.361949 3.359509 3.369279 3.398579 3.579289 3.948029 4.412009 4.585399 4.514579 4.343639 4.155599 3.984659 4.043269 4.307009 4.421779 4.353409 4.223979 4.053039 3.940709 3.838139 3.730689 3.652549 3.611039 3.564639 3.496259 3.462069 3.454749 3.425439 3.379049 3.432769 3.623249 3.974889 4.380269 4.714819 5.073799 5.369279 5.603709 5.745349 5.652549 5.401019 5.015189 4.709939 4.416899 4.236189 4.236189 4.248399 4.221539 4.297239 4.590279 4.893089 5.134849 5.427889 5.379049 5.364389 5.452309 5.567079 5.672089 5.769769 5.830819 5.923609 5.965129 6.057919 6.050599 6.072579 6.111649 6.070129 5.896749 5.755109 5.718479 5.821049 6.001759 6.001759 5.901629 5.557309 5.173919 4.800289 4.431549 4.194679 4.006639 3.850349 3.747789 3.642779 3.591499 3.569519 3.528009 3.537779 3.554869 3.493819 3.447419 3.440099 3.408349 3.410789 3.452309 3.681849 4.060369 4.441319 4.854019 5.154379 5.425439 5.596379 5.586619 5.354629 5.027399 4.863779 4.761219 4.570739 4.368059 4.397359 4.573189 4.841809 5.203219 5.452309 5.652549 5.855239 5.906519 5.952919 5.828369 5.791739 5.799069 5.813719 5.877209 5.955359 5.781979 5.518239 5.127519 4.763659 4.492599 4.233749 4.011519 3.855239 3.691619 3.635459 3.818609 4.155599 4.590279 4.988329 5.076239 4.907739 4.648889 4.377829 4.216649 4.287469 4.590279 4.846689 5.139729 5.388809 5.689179 5.884539 6.043269 6.170259 6.211769 6.250839 6.209329 6.013969 5.701389 5.469399 5.479169 5.557309 5.728249 5.882099 5.984659 5.901629 5.581729 5.371719 5.418119 5.510909 5.667199 5.791739 5.698949 5.484049 5.154379 4.980999 5.061589 5.195899 5.359509 5.615919 5.762439 5.857679 5.948029 5.835699 5.706269 5.498699 5.188569 5.117749 5.191009 5.315549 5.532889 5.444979 5.396139 5.274039 5.027399 4.744129 4.668419 4.651329 4.514579 4.267939 4.260609 4.263049 4.189789 4.277699 4.600049 4.932159 5.283809 5.528009 5.740459 5.874769 5.955359 5.991989 5.845469 5.528009 5.061589 4.734359 4.534109 4.534109 4.697729 4.744129 4.619579 4.643999 4.832039 5.132399 5.410789 5.625689 5.603709 5.315549 4.961459 4.619579 4.358289 4.155599 4.033499 3.886979 3.772209 3.640339 3.532889 3.435209 3.427889 3.422999 3.398579 3.603709 4.023729 4.451089 4.792969 4.902859 4.780759 4.590279 4.336309 4.145839 4.216649 4.433989 4.714819 5.098219 5.359509 5.569519 5.772209 5.921169 6.055479 5.962679 5.642779 5.435209 5.388809 5.537779 5.681849 5.701389 5.615919 5.667199 5.740459 5.803949 5.882099 5.950469 6.072579 6.148279 6.116529 6.177579 6.201999 6.206889 5.991989 5.564639 5.178799 4.998089 5.051819 5.232529 5.484049 5.686739 5.899189 5.869889 5.977339 6.053039 6.079899 6.128739 6.079899 6.167809 6.194679 6.236189 6.053039 5.652549 5.274039 4.858899 4.534109 4.455969 4.619579 4.866229 5.117749 5.166589 5.056699 5.002979 5.098219 5.325319 5.567079 5.466959 5.252059 4.946809 4.880879 4.980999 5.225199 5.459629 5.723369 5.791739 5.906519 5.991989 5.835699 5.528009 5.142169 4.775869 4.490159 4.236189 4.023729 3.886979 3.752669 3.681849 3.806399 4.145839 4.600049 5.002979 5.303339 5.552429 5.615919 5.523119 5.611039 5.713599 5.845469 5.899189 5.994429 6.092109 6.092109 6.143389 6.153159 6.233749 6.187349 6.013969 5.835699 5.774649 5.686739 5.537779 5.327759 5.054259 4.700169 4.394919 4.180019 4.043269 3.877209 3.752669 3.728249 3.869889 4.206889 4.355849 4.426669 4.453529 4.521899 4.392479 4.155599 3.965129 3.877209 3.970009 4.258169 4.421779 4.336309 4.299679 4.392479 4.675749 4.761219 4.658659 4.490159 4.307009 4.126299 3.972449 4.077459 4.372939 4.741679 5.088449 5.186129 5.037169 4.785639 4.563419 4.534109 4.705049 4.741679 4.648889 4.431549 4.238629 4.065249 3.943149 3.811279 3.691619 3.652549 3.825929 4.223979 4.424219 4.429109 4.319219 4.138509 3.965129 3.886979 3.801509 3.701389 3.640339 3.767319 4.150719 4.648889 4.990769 5.088449 5.022509 4.783199 4.685519 4.665979 4.707499 4.912619 5.195899 5.415679 5.623249 5.740459 5.899189 5.928499 6.050599 6.153159 5.965129 5.586619 5.381489 5.371719 5.486489 5.567079 5.821049 5.913839 5.994429 6.011519 5.999309 6.018849 5.821049 5.728249 5.740459 5.764879 5.882099 5.926049 5.750229 5.415679 4.995649 4.861339 4.902859 5.103099 5.364389 5.596379 5.752669 5.845469 5.928499 6.006639 5.840579 5.518239 5.173919 4.739239 4.458409 4.426669 4.602489 4.822269 5.183689 5.430329 5.652549 5.821049 5.706269 5.369279 5.027399 4.705049 4.414459 4.145839 3.965129 4.033499 4.372939 4.683079 slicot-5.0+20101122/examples77/IB01BD.res000077500000000000000000000014341201767322700171230ustar00rootroot00000000000000 IB01BD EXAMPLE PROGRAM RESULTS The system state matrix A is 0.8924 0.3887 0.1285 0.1716 -0.0837 0.6186 -0.6273 -0.4582 0.0052 0.1307 0.6685 -0.6755 0.0055 0.0734 -0.2148 0.4788 The system output matrix C is -0.4442 0.6663 0.3961 0.4102 The system input matrix B is -0.2142 -0.1968 0.0525 0.0361 The system input-output matrix D is -0.0041 The Kalman gain matrix K is -1.9513 -0.1867 0.6348 -0.3486 The state covariance matrix Q is 0.0052 0.0005 -0.0017 0.0009 0.0005 0.0000 -0.0002 0.0001 -0.0017 -0.0002 0.0006 -0.0003 0.0009 0.0001 -0.0003 0.0002 The output covariance matrix Ry is 0.0012 The state-output cross-covariance matrix S is -0.0025 -0.0002 0.0008 -0.0005 slicot-5.0+20101122/examples77/IB01CD.dat000077500000000000000000000472351201767322700171140ustar00rootroot00000000000000 IB01CD EXAMPLE PROGRAM DATA 15 0 1 1 1000 0.0 -1.0 C C N O N N A C X 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 3.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 6.41 3.41 3.41 3.41 3.41 3.41 3.41 3.41 6.41 6.41 6.41 6.41 6.41 6.41 4.766099 4.763659 4.839359 5.002979 5.017629 5.056699 5.154379 5.361949 5.425439 5.569519 5.681849 5.742899 5.803949 5.918729 5.821049 5.447419 5.061589 4.629349 4.267939 4.011519 3.850349 3.711159 3.569519 3.518239 3.652549 3.818609 3.862559 4.011519 4.353409 4.705049 5.083559 5.344859 5.274039 5.127519 4.761219 4.451089 4.221539 4.045709 3.874769 3.730689 3.662319 3.576849 3.542659 3.479169 3.454749 3.359509 3.298459 3.225199 3.200779 3.225199 3.227639 3.274039 3.457189 3.867449 4.321659 4.492599 4.431549 4.243519 4.050599 3.857679 3.730689 3.791739 3.921169 3.955359 3.847909 3.725809 3.611039 3.716039 4.092109 4.480389 4.814939 5.054259 5.303339 5.486489 5.672089 5.779529 5.799069 5.664759 5.291129 4.880879 4.558529 4.184909 3.889419 3.708719 3.623249 3.569519 3.718479 4.033499 4.412009 4.629349 4.558529 4.394919 4.180019 4.197119 4.431549 4.714819 4.961459 5.300899 5.567079 5.681849 5.545099 5.188569 4.883319 4.600049 4.270379 4.038389 3.838139 3.711159 3.591499 3.535329 3.486489 3.476729 3.425439 3.381489 3.369279 3.364389 3.347299 3.381489 3.420559 3.413229 3.452309 3.635459 4.038389 4.375379 4.727029 5.056699 5.298459 5.532889 5.466959 5.195899 4.885759 4.763659 4.875989 5.042049 5.283809 5.491379 5.596379 5.672089 5.772209 5.830819 5.933379 5.899189 5.935819 5.894309 5.918729 5.994429 5.957799 6.031059 6.062809 6.040829 6.096999 6.123859 6.162929 6.040829 5.845469 5.772209 5.799069 5.923609 5.928499 6.001759 6.001759 6.060369 5.882099 5.510909 5.322879 5.371719 5.454749 5.437649 5.159269 4.902859 4.587839 4.502369 4.595159 4.824709 5.064029 5.271599 5.466959 5.615919 5.528009 5.254499 4.883319 4.517019 4.197119 4.001759 3.806399 3.904079 3.923609 3.869889 3.806399 3.720929 3.818609 4.140949 4.529229 4.805179 5.086009 5.339969 5.532889 5.576849 5.667199 5.791739 5.850349 5.923609 5.921169 5.977339 5.740459 5.388809 5.000539 4.849129 4.944369 5.173919 5.369279 5.447419 5.603709 5.730689 5.850349 5.979779 5.991989 6.084789 5.940709 5.803949 5.791739 5.603709 5.264269 4.946809 4.619579 4.514579 4.433989 4.285029 4.121419 3.945589 3.984659 4.219099 4.546319 4.873549 5.154379 5.388809 5.613479 5.835699 5.884539 5.955359 5.762439 5.459629 5.061589 4.707499 4.458409 4.267939 4.053039 3.943149 3.825929 3.967569 4.280149 4.480389 4.492599 4.390039 4.197119 4.111649 3.982219 3.867449 3.767319 3.872329 4.236189 4.663539 4.971229 5.066469 4.902859 4.675749 4.392479 4.099439 4.114089 4.326539 4.643999 4.971229 5.159269 5.388809 5.576849 5.652549 5.803949 5.913839 5.886979 5.799069 5.730689 5.762439 5.813719 5.821049 5.928499 6.013969 5.764879 5.413229 5.098219 4.678189 4.372939 4.392479 4.590279 4.919949 5.017629 4.858899 4.675749 4.619579 4.834479 5.090889 5.376599 5.681849 5.823489 5.952919 6.062809 6.089669 6.075019 6.026179 5.994429 6.077459 5.857679 5.701389 5.730689 5.784419 5.823489 5.894309 5.762439 5.415679 4.961459 4.595159 4.331429 4.297239 4.582949 4.861339 5.173919 5.166589 4.919949 4.607369 4.370499 4.182469 4.038389 4.145839 4.431549 4.556089 4.480389 4.375379 4.370499 4.558529 4.858899 4.895529 4.741679 4.744129 4.875989 5.105539 5.239849 5.518239 5.652549 5.723369 5.855239 5.962679 5.984659 5.984659 6.055479 6.062809 6.055479 6.070129 5.784419 5.440099 5.056699 4.941929 5.010299 5.134849 5.313109 5.479169 5.623249 5.562199 5.330209 5.010299 4.665979 4.414459 4.201999 4.048159 4.079899 4.189789 4.131179 4.004199 3.916289 3.960239 4.199559 4.624469 4.883319 5.137289 5.379049 5.623249 5.762439 5.833259 5.686739 5.366839 5.225199 5.239849 5.354629 5.508469 5.596379 5.752669 5.874769 5.906519 5.894309 5.742899 5.447419 5.024959 4.883319 4.885759 4.893089 4.714819 4.451089 4.233749 4.043269 3.864999 3.757559 3.669639 3.593939 3.547539 3.506029 3.454749 3.398579 3.361949 3.339969 3.374159 3.520679 3.713599 3.757559 3.779529 3.696509 3.777089 3.886979 3.904079 3.850349 3.965129 4.282589 4.521899 4.714819 4.971229 5.220319 5.532889 5.652549 5.781979 5.955359 6.035939 6.118969 6.133629 6.153159 6.192229 6.143389 6.167809 5.991989 5.652549 5.459629 5.437649 5.339969 5.098219 4.785639 4.492599 4.236189 4.067689 3.933379 3.823489 3.730689 3.611039 3.564639 3.549989 3.557309 3.513359 3.515799 3.694059 4.072579 4.480389 4.705049 4.612259 4.385149 4.201999 4.026179 3.904079 3.774649 3.691619 3.845469 4.201999 4.585399 4.902859 5.256949 5.510909 5.640339 5.843029 5.974889 5.935819 5.821049 5.528009 5.171479 4.810059 4.453529 4.380269 4.565859 4.805179 5.125079 5.354629 5.589059 5.764879 5.923609 5.940709 5.857679 5.694059 5.486489 5.149499 4.844249 4.541439 4.267939 4.060369 3.960239 3.789299 3.642779 3.525569 3.498699 3.454749 3.408349 3.379049 3.376599 3.361949 3.359509 3.369279 3.398579 3.579289 3.948029 4.412009 4.585399 4.514579 4.343639 4.155599 3.984659 4.043269 4.307009 4.421779 4.353409 4.223979 4.053039 3.940709 3.838139 3.730689 3.652549 3.611039 3.564639 3.496259 3.462069 3.454749 3.425439 3.379049 3.432769 3.623249 3.974889 4.380269 4.714819 5.073799 5.369279 5.603709 5.745349 5.652549 5.401019 5.015189 4.709939 4.416899 4.236189 4.236189 4.248399 4.221539 4.297239 4.590279 4.893089 5.134849 5.427889 5.379049 5.364389 5.452309 5.567079 5.672089 5.769769 5.830819 5.923609 5.965129 6.057919 6.050599 6.072579 6.111649 6.070129 5.896749 5.755109 5.718479 5.821049 6.001759 6.001759 5.901629 5.557309 5.173919 4.800289 4.431549 4.194679 4.006639 3.850349 3.747789 3.642779 3.591499 3.569519 3.528009 3.537779 3.554869 3.493819 3.447419 3.440099 3.408349 3.410789 3.452309 3.681849 4.060369 4.441319 4.854019 5.154379 5.425439 5.596379 5.586619 5.354629 5.027399 4.863779 4.761219 4.570739 4.368059 4.397359 4.573189 4.841809 5.203219 5.452309 5.652549 5.855239 5.906519 5.952919 5.828369 5.791739 5.799069 5.813719 5.877209 5.955359 5.781979 5.518239 5.127519 4.763659 4.492599 4.233749 4.011519 3.855239 3.691619 3.635459 3.818609 4.155599 4.590279 4.988329 5.076239 4.907739 4.648889 4.377829 4.216649 4.287469 4.590279 4.846689 5.139729 5.388809 5.689179 5.884539 6.043269 6.170259 6.211769 6.250839 6.209329 6.013969 5.701389 5.469399 5.479169 5.557309 5.728249 5.882099 5.984659 5.901629 5.581729 5.371719 5.418119 5.510909 5.667199 5.791739 5.698949 5.484049 5.154379 4.980999 5.061589 5.195899 5.359509 5.615919 5.762439 5.857679 5.948029 5.835699 5.706269 5.498699 5.188569 5.117749 5.191009 5.315549 5.532889 5.444979 5.396139 5.274039 5.027399 4.744129 4.668419 4.651329 4.514579 4.267939 4.260609 4.263049 4.189789 4.277699 4.600049 4.932159 5.283809 5.528009 5.740459 5.874769 5.955359 5.991989 5.845469 5.528009 5.061589 4.734359 4.534109 4.534109 4.697729 4.744129 4.619579 4.643999 4.832039 5.132399 5.410789 5.625689 5.603709 5.315549 4.961459 4.619579 4.358289 4.155599 4.033499 3.886979 3.772209 3.640339 3.532889 3.435209 3.427889 3.422999 3.398579 3.603709 4.023729 4.451089 4.792969 4.902859 4.780759 4.590279 4.336309 4.145839 4.216649 4.433989 4.714819 5.098219 5.359509 5.569519 5.772209 5.921169 6.055479 5.962679 5.642779 5.435209 5.388809 5.537779 5.681849 5.701389 5.615919 5.667199 5.740459 5.803949 5.882099 5.950469 6.072579 6.148279 6.116529 6.177579 6.201999 6.206889 5.991989 5.564639 5.178799 4.998089 5.051819 5.232529 5.484049 5.686739 5.899189 5.869889 5.977339 6.053039 6.079899 6.128739 6.079899 6.167809 6.194679 6.236189 6.053039 5.652549 5.274039 4.858899 4.534109 4.455969 4.619579 4.866229 5.117749 5.166589 5.056699 5.002979 5.098219 5.325319 5.567079 5.466959 5.252059 4.946809 4.880879 4.980999 5.225199 5.459629 5.723369 5.791739 5.906519 5.991989 5.835699 5.528009 5.142169 4.775869 4.490159 4.236189 4.023729 3.886979 3.752669 3.681849 3.806399 4.145839 4.600049 5.002979 5.303339 5.552429 5.615919 5.523119 5.611039 5.713599 5.845469 5.899189 5.994429 6.092109 6.092109 6.143389 6.153159 6.233749 6.187349 6.013969 5.835699 5.774649 5.686739 5.537779 5.327759 5.054259 4.700169 4.394919 4.180019 4.043269 3.877209 3.752669 3.728249 3.869889 4.206889 4.355849 4.426669 4.453529 4.521899 4.392479 4.155599 3.965129 3.877209 3.970009 4.258169 4.421779 4.336309 4.299679 4.392479 4.675749 4.761219 4.658659 4.490159 4.307009 4.126299 3.972449 4.077459 4.372939 4.741679 5.088449 5.186129 5.037169 4.785639 4.563419 4.534109 4.705049 4.741679 4.648889 4.431549 4.238629 4.065249 3.943149 3.811279 3.691619 3.652549 3.825929 4.223979 4.424219 4.429109 4.319219 4.138509 3.965129 3.886979 3.801509 3.701389 3.640339 3.767319 4.150719 4.648889 4.990769 5.088449 5.022509 4.783199 4.685519 4.665979 4.707499 4.912619 5.195899 5.415679 5.623249 5.740459 5.899189 5.928499 6.050599 6.153159 5.965129 5.586619 5.381489 5.371719 5.486489 5.567079 5.821049 5.913839 5.994429 6.011519 5.999309 6.018849 5.821049 5.728249 5.740459 5.764879 5.882099 5.926049 5.750229 5.415679 4.995649 4.861339 4.902859 5.103099 5.364389 5.596379 5.752669 5.845469 5.928499 6.006639 5.840579 5.518239 5.173919 4.739239 4.458409 4.426669 4.602489 4.822269 5.183689 5.430329 5.652549 5.821049 5.706269 5.369279 5.027399 4.705049 4.414459 4.145839 3.965129 4.033499 4.372939 4.683079 slicot-5.0+20101122/examples77/IB01CD.res000077500000000000000000000007331201767322700171250ustar00rootroot00000000000000 IB01CD EXAMPLE PROGRAM RESULTS The system state matrix A is 0.8924 0.3887 0.1285 0.1716 -0.0837 0.6186 -0.6273 -0.4582 0.0052 0.1307 0.6685 -0.6755 0.0055 0.0734 -0.2148 0.4788 The system output matrix C is -0.4442 0.6663 0.3961 0.4102 The system input matrix B is -0.2150 -0.1962 0.0511 0.0373 The system input-output matrix D is -0.0018 The initial state vector x0 is -11.4329 -0.6767 0.0472 0.3600 slicot-5.0+20101122/examples77/IB03AD.dat000077500000000000000000001042121201767322700171010ustar00rootroot00000000000000 IB03AD EXAMPLE PROGRAM DATA 10 1 1 1024 4 12 500 1000 0 .00001 .00001 B D F 2.2183165e-01 3.9027807e-02 -5.0295887e-02 8.5386224e-03 7.2431159e-02 -1.7082198e-03 -1.7176287e-01 -2.6198104e-01 -1.7194108e-01 1.8566868e-02 1.5625362e-01 1.7463811e-01 1.1564450e-01 2.8779248e-02 -8.4265993e-02 -2.0978501e-01 -2.6591828e-01 -1.7268680e-01 2.1525013e-02 1.4363602e-01 7.3101431e-02 -1.0259212e-01 -1.6380473e-01 -1.0021167e-02 2.0263451e-01 2.1983417e-01 -2.1636523e-02 -3.0986057e-01 -3.8521982e-01 -2.1785179e-01 -1.4761096e-02 3.7005180e-02 -2.8119028e-02 -4.2167901e-02 5.2117694e-02 1.2023747e-01 1.8863385e-02 -1.9506434e-01 -3.0192175e-01 -1.7000747e-01 8.0740471e-02 2.0188076e-01 8.5108288e-02 -1.3270970e-01 -2.3646822e-01 -1.6505385e-01 -4.7448014e-02 -2.7886815e-02 -1.0152026e-01 -1.4155374e-01 -6.1650823e-02 8.3519614e-02 1.5926650e-01 8.6142760e-02 -9.4385381e-02 -2.6609066e-01 -3.2883874e-01 -2.5908050e-01 -1.1648940e-01 -3.0653766e-03 1.0326675e-02 -5.3445909e-02 -9.2412724e-02 -3.0279541e-02 8.4846832e-02 1.1133075e-01 -3.2135250e-02 -2.5308181e-01 -3.5670882e-01 -2.4458860e-01 -2.5254261e-02 9.3714332e-02 1.8643667e-02 -1.4592119e-01 -2.2730880e-01 -1.7140060e-01 -7.4131665e-02 -3.9669515e-02 -5.1266129e-02 -1.1752833e-02 1.0785565e-01 2.0665525e-01 1.6117322e-01 -2.6938653e-02 -2.1941152e-01 -2.7753567e-01 -1.8805912e-01 -4.6845025e-02 5.8585698e-02 1.2218407e-01 1.7838638e-01 2.2169815e-01 1.9825589e-01 8.0215288e-02 -7.2135308e-02 -1.4381520e-01 -6.8724371e-02 1.0191205e-01 2.3766633e-01 2.3876101e-01 1.1678077e-01 -2.0428168e-02 -5.8973233e-02 3.1326900e-02 1.7391495e-01 2.4558570e-01 1.7650262e-01 1.2444292e-02 -1.1538234e-01 -9.5917970e-02 6.4762165e-02 2.4258524e-01 3.0102251e-01 2.1222960e-01 7.8706189e-02 3.1500466e-02 1.0297577e-01 1.9875173e-01 1.9434906e-01 5.8146667e-02 -1.1941921e-01 -2.1038478e-01 -1.5594967e-01 1.8552198e-03 1.6878529e-01 2.5937416e-01 2.2516346e-01 6.6144472e-02 -1.5623019e-01 -3.3161105e-01 -3.6695732e-01 -2.6565333e-01 -1.3254832e-01 -8.0101064e-02 -1.2531889e-01 -1.8843171e-01 -1.9038956e-01 -1.3230055e-01 -7.0889306e-02 -3.9679280e-02 -2.6286077e-02 -2.3630770e-02 -6.0652834e-02 -1.4929250e-01 -2.2155095e-01 -1.7331044e-01 5.2693564e-03 1.7683919e-01 1.8244690e-01 2.5118458e-02 -1.1051051e-01 -5.1764984e-02 1.6342054e-01 3.1563281e-01 2.3808751e-01 -4.4871135e-03 -1.8778679e-01 -1.6017584e-01 2.3481991e-02 1.9209185e-01 2.4281065e-01 2.1224192e-01 1.8825017e-01 1.9811718e-01 2.0202486e-01 1.6812825e-01 1.1444796e-01 7.2452475e-02 4.0090973e-02 -6.7139529e-03 -6.8721730e-02 -1.1460099e-01 -1.1914168e-01 -8.9852521e-02 -4.5942222e-02 1.0932686e-02 8.1900393e-02 1.3092374e-01 9.0790221e-02 -6.3538148e-02 -2.5119963e-01 -3.2585173e-01 -2.0850925e-01 1.7922009e-02 1.6783753e-01 1.2518317e-01 -4.3517162e-02 -1.5783138e-01 -1.0686847e-01 4.4782565e-02 1.3893172e-01 9.8691579e-02 2.6311282e-03 -1.6073049e-02 7.8512306e-02 1.9453537e-01 2.2504627e-01 1.6121235e-01 7.8124056e-02 2.9774586e-02 -5.3899280e-03 -6.5745322e-02 -1.2329059e-01 -9.5096521e-02 5.5471394e-02 2.5017082e-01 3.4773286e-01 2.6656242e-01 5.3705965e-02 -1.6135006e-01 -2.7310977e-01 -2.6814818e-01 -2.1074926e-01 -1.7743213e-01 -1.9796482e-01 -2.4059041e-01 -2.4663820e-01 -1.8780129e-01 -9.8317382e-02 -4.7848155e-02 -7.3425069e-02 -1.3529842e-01 -1.4739094e-01 -6.2482366e-02 6.8729554e-02 1.3251322e-01 6.1482940e-02 -8.5065014e-02 -1.6074078e-01 -6.7974104e-02 1.3976672e-01 2.9838081e-01 2.8233998e-01 1.1391411e-01 -7.1966946e-02 -1.5876983e-01 -1.3805556e-01 -8.2998592e-02 -5.7864811e-02 -6.5300733e-02 -7.0590592e-02 -5.5847027e-02 -4.1219301e-02 -6.1578267e-02 -1.3176243e-01 -2.2968907e-01 -3.0193311e-01 -2.8770451e-01 -1.5729276e-01 5.4414593e-02 2.5362617e-01 3.4482230e-01 3.0119122e-01 1.8534835e-01 9.6712488e-02 9.3385279e-02 1.6057572e-01 2.4424680e-01 3.0164891e-01 3.1693510e-01 2.8441517e-01 1.9948758e-01 7.3600888e-02 -5.4291337e-02 -1.3721320e-01 -1.5626045e-01 -1.3464149e-01 -1.1510541e-01 -1.2587072e-01 -1.6605420e-01 -2.1242088e-01 -2.3059410e-01 -1.8785957e-01 -7.8188380e-02 5.0484398e-02 1.0697957e-01 2.7421051e-02 -1.4419852e-01 -2.5888039e-01 -1.8018121e-01 7.8519535e-02 3.4009981e-01 4.0793257e-01 2.3842529e-01 -2.7029751e-02 -1.9919385e-01 -2.0420528e-01 -1.1389043e-01 -3.5602606e-02 5.7385906e-04 3.8759790e-02 1.0691941e-01 1.6303496e-01 1.4314046e-01 4.7786789e-02 -4.1030659e-02 -3.5960232e-02 7.0498851e-02 2.0120383e-01 2.6638170e-01 2.3249669e-01 1.2937468e-01 1.3309043e-02 -6.2770099e-02 -5.8936178e-02 3.4143049e-02 1.6425689e-01 2.2228910e-01 1.2062705e-01 -1.0832755e-01 -3.0711352e-01 -3.2002334e-01 -1.4072879e-01 7.6263091e-02 1.6385270e-01 1.0093887e-01 1.7269577e-02 4.3458474e-02 1.6769625e-01 2.4967945e-01 1.7314220e-01 -2.7519776e-02 -1.9806822e-01 -2.1140982e-01 -7.2758850e-02 1.1057470e-01 2.3440218e-01 2.5956640e-01 1.9629970e-01 7.2200120e-02 -6.6390448e-02 -1.4805958e-01 -1.1487691e-01 1.3561014e-02 1.3146288e-01 1.3205007e-01 1.5159726e-02 -9.9141126e-02 -7.9831031e-02 8.4487631e-02 2.6348526e-01 2.9617209e-01 1.3322758e-01 -1.1642178e-01 -2.7289866e-01 -2.2996687e-01 -3.5143323e-02 1.5983180e-01 2.3035457e-01 1.7179773e-01 7.3333592e-02 1.1653452e-02 -1.8499701e-02 -6.7962911e-02 -1.4361094e-01 -1.7665147e-01 -9.1259528e-02 9.8323111e-02 2.6912800e-01 2.8047779e-01 9.9377687e-02 -1.5436535e-01 -2.9569363e-01 -2.3017874e-01 -4.1007324e-02 8.2484352e-02 2.1760384e-02 -1.5212456e-01 -2.4257965e-01 -1.2641528e-01 1.0676585e-01 2.2865135e-01 1.0211687e-01 -1.6408728e-01 -3.0761461e-01 -1.7309336e-01 1.2302931e-01 3.0157576e-01 1.9992664e-01 -6.5766948e-02 -2.2490680e-01 -1.3209725e-01 9.1452627e-02 1.9707770e-01 7.0972862e-02 -1.6016460e-01 -2.7859962e-01 -2.0288880e-01 -4.9817844e-02 1.3587087e-02 -5.2447125e-02 -1.4164147e-01 -1.3776729e-01 -3.9470574e-02 5.4688171e-02 5.9780155e-02 -2.0666265e-02 -1.2306679e-01 -1.9150051e-01 -1.9953793e-01 -1.3072099e-01 1.7129752e-02 1.9139299e-01 2.8015628e-01 1.9737258e-01 -1.0273734e-02 -1.6921879e-01 -1.2914132e-01 8.3866166e-02 2.8290870e-01 3.0288568e-01 1.5939055e-01 1.4121758e-02 -8.0309556e-03 5.7046152e-02 7.8808779e-02 -4.0300321e-04 -9.3021531e-02 -6.6955916e-02 1.0073094e-01 2.8905786e-01 3.4946321e-01 2.4220689e-01 5.3331283e-02 -1.0609621e-01 -1.9358889e-01 -2.2728166e-01 -2.1680862e-01 -1.4144032e-01 -5.2173696e-03 1.1701944e-01 1.2668247e-01 4.8375112e-03 -1.4889224e-01 -1.9905951e-01 -9.9563224e-02 6.4580042e-02 1.5505008e-01 9.7617503e-02 -6.4905019e-02 -2.1769152e-01 -2.6787937e-01 -2.0919394e-01 -1.1033568e-01 -4.3266567e-02 -1.8066266e-02 1.3641281e-02 9.0806946e-02 1.8645977e-01 2.3150216e-01 1.9334856e-01 1.1238648e-01 4.9498545e-02 1.3155560e-02 -3.5876844e-02 -1.0537074e-01 -1.2612890e-01 -1.8934023e-02 1.8850628e-01 3.4290627e-01 3.0108912e-01 9.0554124e-02 -9.4812468e-02 -8.8842381e-02 6.3160674e-02 1.4646977e-01 1.7441277e-02 -2.2104173e-01 -3.1862778e-01 -1.5530235e-01 1.1291463e-01 2.1663682e-01 7.1521680e-02 -1.2722266e-01 -1.3147084e-01 6.8036453e-02 2.2914846e-01 1.4875917e-01 -8.5725554e-02 -1.9280127e-01 -3.7053987e-02 1.9484616e-01 2.0627194e-01 -5.0290692e-02 -2.9703694e-01 -2.4262627e-01 7.3980280e-02 3.1209111e-01 2.0500085e-01 -1.4678863e-01 -3.9620361e-01 -3.3299784e-01 -8.5315346e-02 7.0026906e-02 3.1783466e-02 -5.6224174e-02 -3.8238612e-02 4.1162402e-02 1.4020902e-02 -1.6267337e-01 -3.2229719e-01 -2.8405914e-01 -8.0208074e-02 7.7279407e-02 5.2461001e-02 -5.6931255e-02 -5.7081867e-02 8.4722273e-02 1.8989091e-01 9.1251490e-02 -1.4913841e-01 -3.0047660e-01 -2.2924644e-01 -4.5027749e-02 4.5847665e-02 -1.0582268e-02 -7.0165157e-02 8.8253349e-03 1.7968871e-01 2.6336655e-01 1.6274839e-01 -3.4038513e-02 -1.6866975e-01 -1.7822821e-01 -1.1212378e-01 -2.2511191e-02 9.2633595e-02 2.2273027e-01 2.8312792e-01 1.8855450e-01 -1.3339719e-02 -1.4451328e-01 -7.9411873e-02 9.5243626e-02 1.5825934e-01 8.6924573e-03 -1.9762612e-01 -2.0963986e-01 3.0881541e-02 3.1088543e-01 3.7605990e-01 2.0371110e-01 3.1659734e-03 -4.2255731e-02 2.7937777e-02 4.3768827e-02 -5.0975761e-02 -1.2013869e-01 -1.9514056e-02 1.9409077e-01 3.0061057e-01 1.6772761e-01 -8.4377993e-02 -2.0596833e-01 -8.8137439e-02 1.3053768e-01 2.3231724e-01 1.5592782e-01 3.3546556e-02 1.2609146e-02 8.8143918e-02 1.3076425e-01 5.2445727e-02 -9.1540218e-02 -1.6532665e-01 -8.9700956e-02 9.2256458e-02 2.6287064e-01 3.2206114e-01 2.4782579e-01 1.0180547e-01 -1.2653507e-02 -2.4053903e-02 4.5165362e-02 9.2697417e-02 3.9645255e-02 -7.0244568e-02 -9.7812594e-02 4.0489353e-02 2.5706426e-01 3.5970764e-01 2.4838839e-01 2.8758245e-02 -9.2051146e-02 -1.8531616e-02 1.4540527e-01 2.2483594e-01 1.6366159e-01 6.0613849e-02 2.6700790e-02 4.8805007e-02 2.4088984e-02 -8.7776563e-02 -1.9182802e-01 -1.5875230e-01 2.1332672e-02 2.1574747e-01 2.8121193e-01 1.9605244e-01 5.2140821e-02 -6.0594054e-02 -1.3111027e-01 -1.9003660e-01 -2.3031943e-01 -1.9896872e-01 -7.1576527e-02 8.7126470e-02 1.5966083e-01 8.0700885e-02 -9.6050487e-02 -2.3768453e-01 -2.4174619e-01 -1.1781079e-01 2.4058534e-02 6.3114157e-02 -3.4924911e-02 -1.8708629e-01 -2.5777811e-01 -1.7457598e-01 2.3256558e-03 1.2615984e-01 9.1298660e-02 -7.2869748e-02 -2.3064584e-01 -2.6487668e-01 -1.7896622e-01 -8.1019614e-02 -7.2160218e-02 -1.5109102e-01 -2.2270453e-01 -1.9311631e-01 -5.5949947e-02 1.0558527e-01 1.9015867e-01 1.5010510e-01 9.3491571e-03 -1.6206410e-01 -2.7872156e-01 -2.6789883e-01 -1.0908763e-01 1.3219241e-01 3.2581004e-01 3.6597785e-01 2.5860903e-01 1.1593033e-01 5.3232658e-02 8.9253999e-02 1.5038178e-01 1.6325136e-01 1.2516262e-01 8.1000365e-02 5.6249003e-02 4.1260796e-02 3.6021307e-02 7.0909773e-02 1.5431016e-01 2.1909293e-01 1.6946538e-01 1.3913978e-03 -1.5472276e-01 -1.5445369e-01 -6.5114694e-03 1.1511921e-01 5.3537688e-02 -1.4926948e-01 -2.8563000e-01 -2.0489020e-01 2.2256191e-02 1.8089745e-01 1.3686717e-01 -4.3194077e-02 -1.9185844e-01 -2.2260927e-01 -1.8688905e-01 -1.7299493e-01 -1.9552456e-01 -2.0311384e-01 -1.6521655e-01 -1.1035364e-01 -7.5596967e-02 -5.2167223e-02 -5.0648414e-03 6.7754101e-02 1.2412118e-01 1.2838133e-01 9.0308482e-02 4.0708671e-02 -1.2463102e-02 -7.6325303e-02 -1.2432208e-01 -9.0380523e-02 5.7426602e-02 2.4318485e-01 3.1839858e-01 2.0029814e-01 -2.6893656e-02 -1.7351791e-01 -1.2458940e-01 4.6580380e-02 1.5624992e-01 9.9382689e-02 -5.1882624e-02 -1.4100610e-01 -1.0040874e-01 -1.2845131e-02 -3.6737447e-03 -9.7637188e-02 -2.0172142e-01 -2.1938378e-01 -1.5223806e-01 -7.5818447e-02 -3.6932476e-02 -8.3361793e-03 4.9321106e-02 1.0828653e-01 8.6261922e-02 -5.6487106e-02 -2.4839500e-01 -3.5078033e-01 -2.7598256e-01 -6.2963150e-02 1.5901166e-01 2.7685307e-01 2.7164897e-01 2.1079033e-01 1.7714997e-01 2.0086813e-01 2.4438441e-01 2.4570310e-01 1.8078261e-01 9.0365447e-02 4.4844498e-02 7.6311118e-02 1.4103984e-01 1.5313326e-01 6.6678933e-02 -6.7720328e-02 -1.3565971e-01 -6.6316159e-02 8.3832277e-02 1.6588475e-01 7.6147385e-02 -1.3444251e-01 -2.9759248e-01 -2.8274479e-01 -1.1318459e-01 7.1421886e-02 1.5414324e-01 1.3182338e-01 8.0829372e-02 6.0814130e-02 6.6565578e-02 6.1490382e-02 3.4525574e-02 1.4709018e-02 3.9340413e-02 1.1733787e-01 2.1846966e-01 2.8684125e-01 2.6688313e-01 1.3632576e-01 -6.7370697e-02 -2.5502586e-01 -3.3949317e-01 -3.0013913e-01 -1.9871892e-01 -1.2610649e-01 -1.2941580e-01 -1.8923457e-01 -2.5813995e-01 -3.0533743e-01 -3.1970649e-01 -2.8788006e-01 -1.9500297e-01 -5.4155345e-02 8.1116905e-02 1.5269009e-01 1.4976106e-01 1.1681611e-01 1.0728712e-01 1.3670700e-01 1.8344060e-01 2.2041268e-01 2.2972773e-01 1.9334746e-01 9.8734288e-02 -2.6231283e-02 -9.9070456e-02 -4.1644202e-02 1.2360480e-01 2.5212308e-01 1.9060093e-01 -6.5066267e-02 -3.3581971e-01 -4.0871250e-01 -2.3222990e-01 4.0796545e-02 2.0553146e-01 1.9047036e-01 8.7982654e-02 2.1078714e-02 1.1947834e-02 -7.4158796e-03 -8.0649898e-02 -1.5932177e-01 -1.5963498e-01 -6.7654645e-02 3.3754864e-02 4.5488264e-02 -5.1656648e-02 -1.8439778e-01 -2.5821552e-01 -2.3168258e-01 -1.3075945e-01 -1.4319768e-02 6.0276859e-02 5.2808278e-02 -4.2009846e-02 -1.6857834e-01 -2.1862301e-01 -1.0815610e-01 1.2758494e-01 3.3007803e-01 3.4236071e-01 1.5606744e-01 -7.3906241e-02 -1.7487103e-01 -1.1779263e-01 -2.8797157e-02 -4.2649366e-02 -1.5603253e-01 -2.3465677e-01 -1.6213440e-01 3.1155521e-02 1.9455902e-01 2.0308035e-01 6.4105637e-02 -1.1373221e-01 -2.2912186e-01 -2.4930244e-01 -1.8794162e-01 -6.9023299e-02 6.6894859e-02 1.4860950e-01 1.1319286e-01 -2.1622177e-02 -1.4430675e-01 -1.4139382e-01 -1.4679189e-02 1.0606471e-01 8.3987908e-02 -8.6549724e-02 -2.6473902e-01 -2.8787546e-01 -1.1665499e-01 1.3032718e-01 2.7649250e-01 2.2886289e-01 4.1972959e-02 -1.4166947e-01 -2.1351821e-01 -1.7294568e-01 -9.5242426e-02 -3.9988034e-02 6.0215518e-04 6.4278100e-02 1.4411085e-01 1.7008073e-01 7.6346726e-02 -1.1397897e-01 -2.7942868e-01 -2.8837790e-01 -1.1356283e-01 1.2995490e-01 2.6791352e-01 2.1050936e-01 3.2758432e-02 -8.8492035e-02 -3.6187051e-02 1.3102808e-01 2.2789768e-01 1.2664599e-01 -9.9240525e-02 -2.3008477e-01 -1.1958430e-01 1.3943384e-01 2.8863442e-01 1.6130336e-01 -1.3747854e-01 -3.2522857e-01 -2.2524885e-01 5.3864511e-02 2.3305883e-01 1.5177574e-01 -7.4373920e-02 -1.8870441e-01 -6.7093573e-02 1.6495747e-01 2.8369836e-01 2.0511206e-01 5.1011236e-02 -6.5929875e-03 6.8964562e-02 1.6340844e-01 1.5740112e-01 5.4023734e-02 -4.3471011e-02 -5.1346211e-02 2.3145779e-02 1.1745308e-01 1.8212689e-01 1.9584070e-01 1.4022670e-01 5.9022790e-03 -1.6079919e-01 -2.4935419e-01 -1.7100378e-01 3.1256057e-02 1.8605482e-01 1.4297623e-01 -7.3243962e-02 -2.7593402e-01 -2.9797544e-01 -1.5307840e-01 -4.0914832e-03 2.1269662e-02 -4.1497170e-02 -5.9046655e-02 2.7976789e-02 1.2846949e-01 1.0303296e-01 -7.5938937e-02 -2.8392411e-01 -3.6123552e-01 -2.5664252e-01 -5.3262494e-02 1.2879625e-01 2.3255706e-01 2.6842403e-01 2.5122050e-01 1.7087253e-01 3.4014290e-02 -9.3227815e-02 -1.2001867e-01 -2.1139059e-02 1.2023890e-01 1.7758447e-01 9.6606085e-02 -5.2792108e-02 -1.3892628e-01 -8.4350032e-02 7.1620365e-02 2.1524576e-01 2.5910116e-01 2.0627091e-01 1.2532985e-01 7.1727643e-02 3.8319163e-02 -1.9240088e-02 -1.1662856e-01 -2.1107703e-01 -2.4258539e-01 -1.9809090e-01 -1.2271124e-01 -6.5266079e-02 -2.6001544e-02 2.6587042e-02 8.9979857e-02 1.0112134e-01 -1.6495775e-03 -1.8712095e-01 -3.2285436e-01 -2.8769737e-01 -1.0373843e-01 6.3283390e-02 6.4192144e-02 -6.9141383e-02 -1.4546154e-01 -2.2743165e-02 2.1671482e-01 3.3495240e-01 1.9730942e-01 -6.4245098e-02 -1.8430371e-01 -5.9313975e-02 1.3285821e-01 1.3988590e-01 -6.3313853e-02 -2.3781208e-01 -1.6565753e-01 7.8634007e-02 2.0643470e-01 6.3051903e-02 -1.7337120e-01 -1.9553447e-01 5.8877424e-02 3.1320739e-01 2.6455767e-01 -5.6738794e-02 -3.0614673e-01 -2.0738949e-01 1.4261991e-01 3.9321755e-01 3.3131011e-01 8.6485026e-02 -6.3943179e-02 -2.3354764e-02 5.9552949e-02 3.1845636e-02 -5.2189216e-02 -1.8514555e-02 1.7050716e-01 3.3649462e-01 2.9310084e-01 7.8582244e-02 -8.5200138e-02 -5.9242022e-02 5.3629257e-02 5.3919799e-02 -9.1290610e-02 -1.9983794e-01 -1.0236954e-01 1.3831631e-01 2.9035137e-01 -1.7703630e-01 -1.1470789e-01 -1.7257803e-02 7.3360924e-02 1.2806267e-01 1.3650217e-01 1.0539571e-01 5.4901306e-02 1.0347593e-02 -1.4210364e-02 -2.9316079e-02 -5.9818410e-02 -1.1287079e-01 -1.5651256e-01 -1.3759239e-01 -3.1325918e-02 1.2118952e-01 2.2925439e-01 2.1688928e-01 8.3280850e-02 -9.0968958e-02 -1.9863421e-01 -1.7919413e-01 -5.4874063e-02 9.1323774e-02 1.7241745e-01 1.4973591e-01 5.1202694e-02 -5.0722214e-02 -8.6474562e-02 -3.6675604e-02 5.0794719e-02 9.2852996e-02 3.5475423e-02 -9.8019853e-02 -2.1560266e-01 -2.2054921e-01 -8.4207430e-02 1.2773783e-01 2.9411889e-01 3.1432928e-01 1.7183620e-01 -5.3673166e-02 -2.3087548e-01 -2.5206313e-01 -9.9556443e-02 1.3579254e-01 3.0302360e-01 2.8345210e-01 6.9698019e-02 -2.2311064e-01 -4.2606792e-01 -4.1979542e-01 -2.0235411e-01 1.1680679e-01 3.8269042e-01 4.7499251e-01 3.6130151e-01 1.0698485e-01 -1.5666457e-01 -2.9684785e-01 -2.5130444e-01 -6.7456399e-02 1.2329504e-01 1.8968350e-01 8.9456729e-02 -1.0185072e-01 -2.4339863e-01 -2.2562726e-01 -4.5215735e-02 1.9190737e-01 3.3930982e-01 3.0360010e-01 1.0486525e-01 -1.3364785e-01 -2.6276635e-01 -2.0355127e-01 -1.0514338e-03 2.0109829e-01 2.5410141e-01 1.0538640e-01 -1.6182684e-01 -3.7724711e-01 -3.8906986e-01 -1.6075631e-01 2.0065197e-01 5.0030087e-01 5.6260189e-01 3.3306758e-01 -8.1981699e-02 -4.6637054e-01 -6.1157444e-01 -4.3578631e-01 -3.4787751e-02 3.6943357e-01 5.5331393e-01 4.1651911e-01 3.8203811e-02 -3.6624642e-01 -5.6531588e-01 -4.4111547e-01 -5.7977077e-02 3.6800859e-01 5.8749279e-01 4.6334166e-01 5.9154789e-02 -3.8817476e-01 -6.0585734e-01 -4.5438072e-01 -2.1770889e-02 4.2269933e-01 5.9388393e-01 3.7277877e-01 -1.1367643e-01 -5.6785416e-01 -7.0538273e-01 -4.3261293e-01 9.5667577e-02 5.7311674e-01 7.2849359e-01 4.8697304e-01 9.0040534e-03 -4.1643634e-01 -5.5375692e-01 -3.6053568e-01 1.0675442e-03 2.8391467e-01 3.2050851e-01 1.2014875e-01 -1.5499683e-01 -3.0636590e-01 -2.2845450e-01 3.0168597e-02 3.0447079e-01 4.1814633e-01 2.9408146e-01 3.3795396e-03 -2.8043536e-01 -3.9163122e-01 -2.7524621e-01 -1.6330862e-02 2.2338646e-01 3.1163298e-01 2.1884631e-01 2.0034460e-02 -1.6244160e-01 -2.3122765e-01 -1.5928083e-01 4.5460308e-03 1.6378113e-01 2.2566835e-01 1.5187573e-01 -1.8633628e-02 -1.8835877e-01 -2.5597784e-01 -1.7568160e-01 1.6144538e-02 2.1796548e-01 3.1334397e-01 2.3350541e-01 9.9054075e-04 -2.7139443e-01 -4.3349329e-01 -3.8409180e-01 -1.3941008e-01 1.6850242e-01 3.6865127e-01 3.5669633e-01 1.5962938e-01 -8.6421861e-02 -2.2603591e-01 -1.7879992e-01 1.5608870e-02 2.2316774e-01 2.9540664e-01 1.5777130e-01 -1.3932674e-01 -4.3707134e-01 -5.5308393e-01 -3.9056636e-01 -6.9866596e-03 4.0342788e-01 6.1470960e-01 5.0478901e-01 1.3556472e-01 -2.7661265e-01 -4.8754120e-01 -3.7410263e-01 -1.0933935e-02 3.7332700e-01 5.3265415e-01 3.5296792e-01 -7.5112937e-02 -5.0630963e-01 -6.8543131e-01 -5.0254861e-01 -6.3204556e-02 3.7616490e-01 5.6861420e-01 4.2839911e-01 7.7256895e-02 -2.4286013e-01 -3.2974149e-01 -1.4621212e-01 1.6396591e-01 3.7227253e-01 3.1398669e-01 -1.5203951e-03 -3.8826155e-01 -5.9422715e-01 -4.6290884e-01 -4.4082503e-02 4.2614489e-01 6.6944646e-01 5.4057059e-01 1.1914310e-01 -3.4186097e-01 -5.7361170e-01 -4.5144665e-01 -6.3037624e-02 3.5015696e-01 5.3940241e-01 3.9354970e-01 6.6063109e-05 -4.0735798e-01 -5.8396114e-01 -4.1610263e-01 1.0313382e-02 4.5449701e-01 6.5638620e-01 4.8903578e-01 3.8482894e-02 -4.3952337e-01 -6.6436421e-01 -4.9492372e-01 -1.7915270e-02 4.9445240e-01 7.3828446e-01 5.5772875e-01 4.3827397e-02 -5.1216643e-01 -7.8827423e-01 -6.2373284e-01 -1.1577453e-01 4.4053448e-01 7.3121649e-01 6.0691719e-01 1.6037942e-01 -3.4101558e-01 -6.1837622e-01 -5.3898039e-01 -1.7955555e-01 2.3296574e-01 4.6098842e-01 3.9204767e-01 9.4586522e-02 -2.3425494e-01 -3.9383077e-01 -2.9901136e-01 -2.1727093e-02 2.6290754e-01 3.8667642e-01 2.8641038e-01 3.4299620e-02 -2.1199530e-01 -3.0703990e-01 -2.0539827e-01 1.3733625e-02 1.9989717e-01 2.2856610e-01 8.0442398e-02 -1.4924794e-01 -3.1635143e-01 -3.2043874e-01 -1.6226330e-01 6.7449386e-02 2.5253008e-01 3.1855044e-01 2.6051993e-01 1.2699840e-01 -1.6342455e-02 -1.1750854e-01 -1.5094063e-01 -1.1699324e-01 -3.6407066e-02 5.7070826e-02 1.2470744e-01 1.3295525e-01 6.7237676e-02 -5.6199791e-02 -1.8928499e-01 -2.6860491e-01 -2.4751370e-01 -1.2546869e-01 4.7269068e-02 1.9379936e-01 2.5012057e-01 1.9757699e-01 6.9603172e-02 -6.6884197e-02 -1.4260360e-01 -1.1800895e-01 -4.5690911e-03 1.3505757e-01 2.1176910e-01 1.5667518e-01 -2.9715225e-02 -2.6058872e-01 -4.0072162e-01 -3.4636170e-01 -1.0002597e-01 2.1522385e-01 4.2116592e-01 3.9178740e-01 1.3552073e-01 -2.0194672e-01 -4.2193015e-01 -3.9351670e-01 -1.3365470e-01 2.0423921e-01 4.2544835e-01 4.1162219e-01 1.8730580e-01 -1.0283670e-01 -2.8986993e-01 -2.8756628e-01 -1.3866788e-01 2.8290398e-02 9.5513335e-02 3.5118646e-02 -8.2724881e-02 -1.5147446e-01 -1.0799938e-01 2.6949604e-02 1.6959254e-01 2.3358015e-01 1.8482066e-01 5.6424609e-02 -7.8806247e-02 -1.5583364e-01 -1.5299245e-01 -9.3729273e-02 -1.9708548e-02 3.8600307e-02 7.1469845e-02 7.8472613e-02 5.5625386e-02 -1.0621857e-03 -8.0782039e-02 -1.5057837e-01 -1.6705428e-01 -1.0304932e-01 2.9389143e-02 1.7801990e-01 2.7318425e-01 2.6234323e-01 1.3834554e-01 -5.4215912e-02 -2.3593270e-01 -3.2392000e-01 -2.6898405e-01 -8.5844039e-02 1.4215609e-01 2.9652172e-01 2.8801270e-01 1.1683545e-01 -1.1688760e-01 -2.6947626e-01 -2.4573958e-01 -6.4329645e-02 1.5353975e-01 2.6653313e-01 2.0755588e-01 2.4602079e-02 -1.5772495e-01 -2.2567844e-01 -1.4875573e-01 9.9414396e-03 1.4397851e-01 1.7486115e-01 9.6314112e-02 -3.2169687e-02 -1.2887854e-01 -1.3861783e-01 -5.9693947e-02 6.1826068e-02 1.6117670e-01 1.8758542e-01 1.2643056e-01 4.7038639e-03 -1.2089033e-01 -1.8936563e-01 -1.6676448e-01 -6.8240952e-02 4.6702545e-02 1.0911959e-01 8.7135042e-02 1.1538006e-02 -4.4789930e-02 -2.4262269e-02 6.5437901e-02 1.5116338e-01 1.4886934e-01 3.3820535e-02 -1.3097789e-01 -2.3522600e-01 -2.0099760e-01 -4.2018915e-02 1.4060900e-01 2.2430878e-01 1.4698003e-01 -4.9334401e-02 -2.4015379e-01 -2.9449301e-01 -1.5978257e-01 9.9469238e-02 3.3553927e-01 4.0432846e-01 2.5275189e-01 -4.8157255e-02 -3.4363559e-01 -4.8101858e-01 -3.9093124e-01 -1.2065446e-01 1.9561509e-01 4.0816957e-01 4.2449571e-01 2.4947873e-01 -2.2290220e-02 -2.5535821e-01 -3.3965313e-01 -2.4442241e-01 -3.2717407e-02 1.7386538e-01 2.6131002e-01 1.8344736e-01 -1.4617105e-02 -2.2004617e-01 -3.0989410e-01 -2.1648361e-01 2.9614296e-02 3.0600899e-01 4.6010027e-01 3.9585763e-01 1.3407054e-01 -1.9445050e-01 -4.2254041e-01 -4.4190341e-01 -2.6148822e-01 2.4561144e-03 1.9639531e-01 2.2058130e-01 8.8618067e-02 -8.2771773e-02 -1.5145974e-01 -4.8116921e-02 1.7081593e-01 3.5448643e-01 3.5655964e-01 1.3834184e-01 -1.9528570e-01 -4.5613811e-01 -4.9089820e-01 -2.7873232e-01 5.5837539e-02 3.2156811e-01 3.7683870e-01 2.1007687e-01 -6.1195486e-02 -2.6670692e-01 -2.8529736e-01 -1.1252984e-01 1.4069959e-01 3.1548805e-01 3.0070613e-01 1.0177110e-01 -1.6096596e-01 -3.2711612e-01 -2.9842835e-01 -9.9492033e-02 1.4305421e-01 2.8418081e-01 2.4879424e-01 7.0440776e-02 -1.3708347e-01 -2.5105923e-01 -2.1001593e-01 -4.5285982e-02 1.4155737e-01 2.4209754e-01 2.0725941e-01 7.3959838e-02 -6.6466455e-02 -1.3533231e-01 -1.1722667e-01 -5.6247689e-02 -8.2151160e-03 4.6646596e-03 -5.3013327e-05 6.4836935e-03 3.4885521e-02 7.2093769e-02 9.6085499e-02 9.0621414e-02 5.0063443e-02 -1.9216694e-02 -9.5194586e-02 -1.4177512e-01 -1.2554939e-01 -4.1561203e-02 7.4612994e-02 1.6458119e-01 1.8370169e-01 1.2694288e-01 2.5574339e-02 -7.6209464e-02 -1.4292208e-01 -1.5717793e-01 -1.2150507e-01 -5.7465582e-02 3.0433319e-03 3.8135050e-02 5.3444515e-02 7.4126764e-02 1.1232692e-01 1.4266966e-01 1.1713381e-01 1.2919877e-02 -1.3094351e-01 -2.2903887e-01 -2.1083457e-01 -7.7741149e-02 9.2251468e-02 1.9732652e-01 1.8027267e-01 6.1530912e-02 -8.1015797e-02 -1.6435623e-01 -1.4922825e-01 -5.8874212e-02 3.9408110e-02 7.8379546e-02 3.6886774e-02 -4.2241134e-02 -8.1505612e-02 -2.9557008e-02 9.2798034e-02 2.0055247e-01 2.0414883e-01 7.6944227e-02 -1.2029199e-01 -2.7519345e-01 -2.9408814e-01 -1.6081545e-01 5.1070794e-02 2.1840144e-01 2.3874816e-01 9.4335060e-02 -1.2904879e-01 -2.8774773e-01 -2.6899028e-01 -6.6408095e-02 2.1071698e-01 4.0356249e-01 3.9994180e-01 1.9633323e-01 -1.0730235e-01 -3.6601054e-01 -4.6248715e-01 -3.5922221e-01 -1.1354600e-01 1.4870456e-01 2.9521055e-01 2.5966678e-01 8.3040302e-02 -1.0914113e-01 -1.8742442e-01 -1.0478464e-01 7.3317409e-02 2.1546569e-01 2.1382067e-01 5.6531581e-02 -1.6427012e-01 -3.1183656e-01 -2.9186150e-01 -1.1383004e-01 1.1231696e-01 2.4506533e-01 2.0292544e-01 1.9811075e-02 -1.7391062e-01 -2.3677906e-01 -1.1242105e-01 1.2953875e-01 3.3467916e-01 3.5946938e-01 1.6169418e-01 -1.6880410e-01 -4.5538345e-01 -5.3000472e-01 -3.2991559e-01 5.7588162e-02 4.3386984e-01 5.9508457e-01 4.4813661e-01 6.8860243e-02 -3.3635714e-01 -5.4527976e-01 -4.4370745e-01 -8.9647493e-02 3.1753702e-01 5.4673805e-01 4.6318145e-01 1.0733728e-01 -3.1949400e-01 -5.6446899e-01 -4.7269412e-01 -8.8269356e-02 3.6150197e-01 5.9965309e-01 4.7275161e-01 5.2712510e-02 -4.0097128e-01 -6.0010920e-01 -4.1032807e-01 6.1089052e-02 5.2877389e-01 7.0388838e-01 4.7272792e-01 -3.2841140e-02 -5.1806125e-01 -7.0615746e-01 -5.0443062e-01 -5.3964611e-02 3.6781621e-01 5.2531916e-01 3.6514315e-01 3.1895267e-02 -2.4276338e-01 -2.9561167e-01 -1.2568333e-01 1.2380832e-01 2.6979551e-01 2.0920891e-01 -2.0179145e-02 -2.6980104e-01 -3.7620139e-01 -2.6519009e-01 -1.4966321e-04 2.5905182e-01 3.5875119e-01 2.4783584e-01 5.4317821e-03 -2.1770753e-01 -2.9814845e-01 -2.0810260e-01 -1.7395596e-02 1.5890290e-01 2.2758901e-01 1.6085463e-01 3.3576307e-03 -1.5297196e-01 -2.1737064e-01 -1.5023570e-01 1.2479222e-02 1.7606639e-01 2.4089523e-01 1.6216345e-01 -2.3230254e-02 -2.1504218e-01 -3.0098784e-01 -2.1779026e-01 8.8067567e-03 2.6812984e-01 4.1695437e-01 3.6159556e-01 1.2203070e-01 -1.7147580e-01 -3.5437470e-01 -3.3058973e-01 -1.3341351e-01 9.9954914e-02 2.1969740e-01 1.5589313e-01 -4.1996520e-02 -2.3771826e-01 -2.9083527e-01 -1.4002506e-01 1.5548285e-01 4.3862419e-01 5.3769302e-01 3.6811228e-01 -6.9569482e-03 -3.9769165e-01 -5.8956799e-01 -4.7193386e-01 -1.1138894e-01 2.8025332e-01 4.6943948e-01 3.4372376e-01 -1.6555081e-02 -3.8429530e-01 -5.2185674e-01 -3.2705351e-01 1.0055685e-01 5.1629500e-01 6.7570174e-01 4.8204840e-01 4.6679399e-02 -3.7892485e-01 -5.5799051e-01 -4.1189337e-01 -6.3130989e-02 2.4927425e-01 3.2624429e-01 1.3391859e-01 -1.7899014e-01 -3.7999275e-01 -3.0718591e-01 1.9919795e-02 4.0587411e-01 5.9872071e-01 4.5200311e-01 2.6827172e-02 -4.3774484e-01 -6.7014857e-01 -5.3423365e-01 -1.1312830e-01 3.4367827e-01 5.7281717e-01 4.5156693e-01 6.5481027e-02 -3.4683106e-01 -5.3783781e-01 -3.9562633e-01 -5.2304328e-03 4.0256826e-01 5.8408144e-01 4.2300297e-01 -1.8218267e-04 -4.4833216e-01 -6.5943295e-01 -5.0033881e-01 -5.1578103e-02 4.3192551e-01 6.6545648e-01 5.0237264e-01 2.6477477e-02 -4.8897549e-01 -7.3697545e-01 -5.5960739e-01 -4.7597748e-02 5.0867228e-01 7.8911527e-01 6.3269313e-01 1.3197226e-01 -4.2464681e-01 -7.2603682e-01 -6.1784801e-01 -1.8264666e-01 3.2014735e-01 6.1135123e-01 5.4895999e-01 1.9768580e-01 -2.2062099e-01 -4.6220719e-01 -4.0211731e-01 -9.9950534e-02 2.4465654e-01 4.1872319e-01 3.2500596e-01 3.2810917e-02 -2.7440750e-01 -4.1536442e-01 -3.1832701e-01 -5.5989066e-02 2.0726049e-01 3.1798239e-01 2.2484797e-01 5.1703651e-03 -1.8889751e-01 -2.2927380e-01 -9.1914974e-02 1.3314428e-01 3.0513495e-01 3.2224987e-01 1.7778028e-01 -4.7100451e-02 -2.4007922e-01 -3.2145867e-01 -2.7615883e-01 -1.4545755e-01 4.2822900e-03 1.1399372e-01 1.5138712e-01 1.1530153e-01 3.0234280e-02 -6.4234624e-02 -1.2615802e-01 -1.2407054e-01 -4.9317670e-02 7.5619816e-02 2.0015044e-01 2.6472178e-01 2.3118708e-01 1.0699863e-01 -5.5412012e-02 -1.8550876e-01 -2.3096135e-01 -1.8218227e-01 -7.2615500e-02 4.0881922e-02 1.0372451e-01 8.6362391e-02 -1.1351454e-03 -1.0889033e-01 -1.6548976e-01 -1.1405709e-01 4.6560657e-02 2.4386985e-01 3.6111476e-01 3.0662373e-01 8.1468123e-02 -2.0497551e-01 -3.9165036e-01 -3.6309524e-01 -1.2535574e-01 1.8954273e-01 3.9793935e-01 3.7486538e-01 1.3124068e-01 -1.9174474e-01 -4.0848802e-01 -4.0149539e-01 -1.8960477e-01 9.0301438e-02 2.7507284e-01 2.7972729e-01 1.4341274e-01 -1.2566755e-02 -7.8032703e-02 -2.7425697e-02 7.5351759e-02 1.3487633e-01 9.5488652e-02 -2.4590018e-02 -1.5233210e-01 -2.1189289e-01 -1.7248897e-01 -6.2455423e-02 5.4933614e-02 1.2398028e-01 1.2778044e-01 8.7386392e-02 3.4966577e-02 -1.0850501e-02 -4.6716543e-02 -6.9020828e-02 -6.3681635e-02 -1.6203206e-02 6.7394491e-02 1.5127737e-01 1.8399090e-01 1.2920707e-01 -7.0434827e-03 -1.7216342e-01 -2.8937677e-01 -2.9509198e-01 -1.7314710e-01 3.2745183e-02 2.3542177e-01 3.4097958e-01 2.9247721e-01 1.0411948e-01 -1.3495077e-01 -2.9868629e-01 -2.9240849e-01 -1.1517683e-01 1.2871323e-01 2.8803761e-01 2.6146766e-01 6.7234759e-02 -1.6729947e-01 -2.9180077e-01 -2.3297675e-01 -3.8493954e-02 1.6188055e-01 2.4607750e-01 1.7580193e-01 1.0770499e-02 -1.3917580e-01 -1.8630712e-01 -1.1496682e-01 1.8120146e-02 1.2605380e-01 1.4532251e-01 6.9056099e-02 -5.5814690e-02 -1.6001831e-01 -1.8912751e-01 -1.2778372e-01 -4.4698128e-03 1.2208903e-01 1.8963074e-01 1.6384408e-01 6.0799128e-02 -5.7339158e-02 -1.1860919e-01 -9.0086196e-02 -4.5798607e-03 6.0280807e-02 4.1676388e-02 -5.5180320e-02 -1.5518201e-01 -1.6828578e-01 -6.2049884e-02 1.0561621e-01 2.2337555e-01 2.0643187e-01 5.9839911e-02 -1.2043322e-01 -2.1083864e-01 -1.4415945e-01 4.3538937e-02 2.3203364e-01 2.9044234e-01 1.6171416e-01 -9.5674666e-02 -3.3749265e-01 -4.1795872e-01 -2.7746809e-01 2.0648626e-02 3.2603206e-01 4.8410918e-01 4.1672303e-01 1.5905611e-01 -1.6318595e-01 -3.9931562e-01 -4.4568803e-01 -2.9169291e-01 -2.0960934e-02 2.3175866e-01 3.4693819e-01 2.7877641e-01 7.7125945e-02 -1.4069530e-01 -2.5367798e-01 -2.0150506e-01 -1.6778161e-02 1.9116819e-01 2.9409556e-01 2.1593628e-01 -1.9610708e-02 -2.9401135e-01 -4.5512990e-01 -4.0311941e-01 -1.5075705e-01 1.7921653e-01 4.2153577e-01 4.6143206e-01 2.9688389e-01 3.5275834e-02 -1.7206796e-01 -2.2040717e-01 -1.1280250e-01 4.6014479e-02 1.2005000e-01 3.5297082e-02 -1.6459920e-01 -3.4121448e-01 -3.5130088e-01 -1.4787707e-01 1.7615712e-01 4.3972643e-01 4.8949447e-01 2.9899548e-01 -1.6059656e-02 -2.7414987e-01 -3.4124596e-01 -2.0476598e-01 3.1287353e-02 2.1535118e-01 2.3693813e-01 8.7039128e-02 -1.3914592e-01 -2.9731202e-01 -2.8057123e-01 -8.9244625e-02 1.6445576e-01 3.2621002e-01 2.9949560e-01 1.0678193e-01 -1.3016725e-01 -2.7225661e-01 -2.4687907e-01 -8.3173776e-02 1.1381888e-01 2.2819642e-01 1.9830143e-01 4.8505476e-02 -1.2763594e-01 -2.2560309e-01 -1.9560311e-01 -7.1212054e-02 6.0380807e-02 1.2445307e-01 1.0835168e-01 5.5609724e-02 1.7269294e-02 9.3997346e-03 1.1223045e-02 -4.3543819e-03 -4.2668837e-02 -8.5657964e-02 -1.0909342e-01 -9.7154374e-02 -4.6781850e-02 3.1101930e-02 1.0973840e-01 1.5122945e-01 1.2531404e-01 3.3620966e-02 -8.3194568e-02 -1.6716420e-01 1998. 1999. 2000. 2001. slicot-5.0+20101122/examples77/IB03AD.res000077500000000000000000000014141201767322700171220ustar00rootroot00000000000000 IB03AD EXAMPLE PROGRAM RESULTS Final 2-norm of the residuals = 0.2970365D+00 Number of iterations = 87 Number of conjugate gradients iterations = 0 Number of function evaluations = 1322 Number of Jacobian evaluations = 105 Final approximate solution is -0.9728 0.6465 -1.2888 -0.4296 -0.8529 0.3181 0.9778 0.4570 -0.1420 0.8984 -0.6031 0.0697 -1.0822 0.4465 0.6036 0.3792 0.2532 -0.0285 0.4129 0.4833 0.1746 0.5626 0.2150 -0.3343 0.4013 -0.3679 0.5653 0.8092 -0.2363 -0.6361 -0.6818 0.6110 -0.5506 0.9913 0.0352 0.1968 -0.2502 7.0067 -10.7378 2.6900 -59.8756 -0.9898 -0.8296 2.3429 1.3455 -0.2531 -1.1265 0.0326 0.5617 0.1045 slicot-5.0+20101122/examples77/IB03BD.dat000077500000000000000000001042021201767322700171010ustar00rootroot00000000000000 IB03BD EXAMPLE PROGRAM DATA 10 1 1 1024 4 12 500 1000 0 .00001 .00001 B 2.2183165e-01 3.9027807e-02 -5.0295887e-02 8.5386224e-03 7.2431159e-02 -1.7082198e-03 -1.7176287e-01 -2.6198104e-01 -1.7194108e-01 1.8566868e-02 1.5625362e-01 1.7463811e-01 1.1564450e-01 2.8779248e-02 -8.4265993e-02 -2.0978501e-01 -2.6591828e-01 -1.7268680e-01 2.1525013e-02 1.4363602e-01 7.3101431e-02 -1.0259212e-01 -1.6380473e-01 -1.0021167e-02 2.0263451e-01 2.1983417e-01 -2.1636523e-02 -3.0986057e-01 -3.8521982e-01 -2.1785179e-01 -1.4761096e-02 3.7005180e-02 -2.8119028e-02 -4.2167901e-02 5.2117694e-02 1.2023747e-01 1.8863385e-02 -1.9506434e-01 -3.0192175e-01 -1.7000747e-01 8.0740471e-02 2.0188076e-01 8.5108288e-02 -1.3270970e-01 -2.3646822e-01 -1.6505385e-01 -4.7448014e-02 -2.7886815e-02 -1.0152026e-01 -1.4155374e-01 -6.1650823e-02 8.3519614e-02 1.5926650e-01 8.6142760e-02 -9.4385381e-02 -2.6609066e-01 -3.2883874e-01 -2.5908050e-01 -1.1648940e-01 -3.0653766e-03 1.0326675e-02 -5.3445909e-02 -9.2412724e-02 -3.0279541e-02 8.4846832e-02 1.1133075e-01 -3.2135250e-02 -2.5308181e-01 -3.5670882e-01 -2.4458860e-01 -2.5254261e-02 9.3714332e-02 1.8643667e-02 -1.4592119e-01 -2.2730880e-01 -1.7140060e-01 -7.4131665e-02 -3.9669515e-02 -5.1266129e-02 -1.1752833e-02 1.0785565e-01 2.0665525e-01 1.6117322e-01 -2.6938653e-02 -2.1941152e-01 -2.7753567e-01 -1.8805912e-01 -4.6845025e-02 5.8585698e-02 1.2218407e-01 1.7838638e-01 2.2169815e-01 1.9825589e-01 8.0215288e-02 -7.2135308e-02 -1.4381520e-01 -6.8724371e-02 1.0191205e-01 2.3766633e-01 2.3876101e-01 1.1678077e-01 -2.0428168e-02 -5.8973233e-02 3.1326900e-02 1.7391495e-01 2.4558570e-01 1.7650262e-01 1.2444292e-02 -1.1538234e-01 -9.5917970e-02 6.4762165e-02 2.4258524e-01 3.0102251e-01 2.1222960e-01 7.8706189e-02 3.1500466e-02 1.0297577e-01 1.9875173e-01 1.9434906e-01 5.8146667e-02 -1.1941921e-01 -2.1038478e-01 -1.5594967e-01 1.8552198e-03 1.6878529e-01 2.5937416e-01 2.2516346e-01 6.6144472e-02 -1.5623019e-01 -3.3161105e-01 -3.6695732e-01 -2.6565333e-01 -1.3254832e-01 -8.0101064e-02 -1.2531889e-01 -1.8843171e-01 -1.9038956e-01 -1.3230055e-01 -7.0889306e-02 -3.9679280e-02 -2.6286077e-02 -2.3630770e-02 -6.0652834e-02 -1.4929250e-01 -2.2155095e-01 -1.7331044e-01 5.2693564e-03 1.7683919e-01 1.8244690e-01 2.5118458e-02 -1.1051051e-01 -5.1764984e-02 1.6342054e-01 3.1563281e-01 2.3808751e-01 -4.4871135e-03 -1.8778679e-01 -1.6017584e-01 2.3481991e-02 1.9209185e-01 2.4281065e-01 2.1224192e-01 1.8825017e-01 1.9811718e-01 2.0202486e-01 1.6812825e-01 1.1444796e-01 7.2452475e-02 4.0090973e-02 -6.7139529e-03 -6.8721730e-02 -1.1460099e-01 -1.1914168e-01 -8.9852521e-02 -4.5942222e-02 1.0932686e-02 8.1900393e-02 1.3092374e-01 9.0790221e-02 -6.3538148e-02 -2.5119963e-01 -3.2585173e-01 -2.0850925e-01 1.7922009e-02 1.6783753e-01 1.2518317e-01 -4.3517162e-02 -1.5783138e-01 -1.0686847e-01 4.4782565e-02 1.3893172e-01 9.8691579e-02 2.6311282e-03 -1.6073049e-02 7.8512306e-02 1.9453537e-01 2.2504627e-01 1.6121235e-01 7.8124056e-02 2.9774586e-02 -5.3899280e-03 -6.5745322e-02 -1.2329059e-01 -9.5096521e-02 5.5471394e-02 2.5017082e-01 3.4773286e-01 2.6656242e-01 5.3705965e-02 -1.6135006e-01 -2.7310977e-01 -2.6814818e-01 -2.1074926e-01 -1.7743213e-01 -1.9796482e-01 -2.4059041e-01 -2.4663820e-01 -1.8780129e-01 -9.8317382e-02 -4.7848155e-02 -7.3425069e-02 -1.3529842e-01 -1.4739094e-01 -6.2482366e-02 6.8729554e-02 1.3251322e-01 6.1482940e-02 -8.5065014e-02 -1.6074078e-01 -6.7974104e-02 1.3976672e-01 2.9838081e-01 2.8233998e-01 1.1391411e-01 -7.1966946e-02 -1.5876983e-01 -1.3805556e-01 -8.2998592e-02 -5.7864811e-02 -6.5300733e-02 -7.0590592e-02 -5.5847027e-02 -4.1219301e-02 -6.1578267e-02 -1.3176243e-01 -2.2968907e-01 -3.0193311e-01 -2.8770451e-01 -1.5729276e-01 5.4414593e-02 2.5362617e-01 3.4482230e-01 3.0119122e-01 1.8534835e-01 9.6712488e-02 9.3385279e-02 1.6057572e-01 2.4424680e-01 3.0164891e-01 3.1693510e-01 2.8441517e-01 1.9948758e-01 7.3600888e-02 -5.4291337e-02 -1.3721320e-01 -1.5626045e-01 -1.3464149e-01 -1.1510541e-01 -1.2587072e-01 -1.6605420e-01 -2.1242088e-01 -2.3059410e-01 -1.8785957e-01 -7.8188380e-02 5.0484398e-02 1.0697957e-01 2.7421051e-02 -1.4419852e-01 -2.5888039e-01 -1.8018121e-01 7.8519535e-02 3.4009981e-01 4.0793257e-01 2.3842529e-01 -2.7029751e-02 -1.9919385e-01 -2.0420528e-01 -1.1389043e-01 -3.5602606e-02 5.7385906e-04 3.8759790e-02 1.0691941e-01 1.6303496e-01 1.4314046e-01 4.7786789e-02 -4.1030659e-02 -3.5960232e-02 7.0498851e-02 2.0120383e-01 2.6638170e-01 2.3249669e-01 1.2937468e-01 1.3309043e-02 -6.2770099e-02 -5.8936178e-02 3.4143049e-02 1.6425689e-01 2.2228910e-01 1.2062705e-01 -1.0832755e-01 -3.0711352e-01 -3.2002334e-01 -1.4072879e-01 7.6263091e-02 1.6385270e-01 1.0093887e-01 1.7269577e-02 4.3458474e-02 1.6769625e-01 2.4967945e-01 1.7314220e-01 -2.7519776e-02 -1.9806822e-01 -2.1140982e-01 -7.2758850e-02 1.1057470e-01 2.3440218e-01 2.5956640e-01 1.9629970e-01 7.2200120e-02 -6.6390448e-02 -1.4805958e-01 -1.1487691e-01 1.3561014e-02 1.3146288e-01 1.3205007e-01 1.5159726e-02 -9.9141126e-02 -7.9831031e-02 8.4487631e-02 2.6348526e-01 2.9617209e-01 1.3322758e-01 -1.1642178e-01 -2.7289866e-01 -2.2996687e-01 -3.5143323e-02 1.5983180e-01 2.3035457e-01 1.7179773e-01 7.3333592e-02 1.1653452e-02 -1.8499701e-02 -6.7962911e-02 -1.4361094e-01 -1.7665147e-01 -9.1259528e-02 9.8323111e-02 2.6912800e-01 2.8047779e-01 9.9377687e-02 -1.5436535e-01 -2.9569363e-01 -2.3017874e-01 -4.1007324e-02 8.2484352e-02 2.1760384e-02 -1.5212456e-01 -2.4257965e-01 -1.2641528e-01 1.0676585e-01 2.2865135e-01 1.0211687e-01 -1.6408728e-01 -3.0761461e-01 -1.7309336e-01 1.2302931e-01 3.0157576e-01 1.9992664e-01 -6.5766948e-02 -2.2490680e-01 -1.3209725e-01 9.1452627e-02 1.9707770e-01 7.0972862e-02 -1.6016460e-01 -2.7859962e-01 -2.0288880e-01 -4.9817844e-02 1.3587087e-02 -5.2447125e-02 -1.4164147e-01 -1.3776729e-01 -3.9470574e-02 5.4688171e-02 5.9780155e-02 -2.0666265e-02 -1.2306679e-01 -1.9150051e-01 -1.9953793e-01 -1.3072099e-01 1.7129752e-02 1.9139299e-01 2.8015628e-01 1.9737258e-01 -1.0273734e-02 -1.6921879e-01 -1.2914132e-01 8.3866166e-02 2.8290870e-01 3.0288568e-01 1.5939055e-01 1.4121758e-02 -8.0309556e-03 5.7046152e-02 7.8808779e-02 -4.0300321e-04 -9.3021531e-02 -6.6955916e-02 1.0073094e-01 2.8905786e-01 3.4946321e-01 2.4220689e-01 5.3331283e-02 -1.0609621e-01 -1.9358889e-01 -2.2728166e-01 -2.1680862e-01 -1.4144032e-01 -5.2173696e-03 1.1701944e-01 1.2668247e-01 4.8375112e-03 -1.4889224e-01 -1.9905951e-01 -9.9563224e-02 6.4580042e-02 1.5505008e-01 9.7617503e-02 -6.4905019e-02 -2.1769152e-01 -2.6787937e-01 -2.0919394e-01 -1.1033568e-01 -4.3266567e-02 -1.8066266e-02 1.3641281e-02 9.0806946e-02 1.8645977e-01 2.3150216e-01 1.9334856e-01 1.1238648e-01 4.9498545e-02 1.3155560e-02 -3.5876844e-02 -1.0537074e-01 -1.2612890e-01 -1.8934023e-02 1.8850628e-01 3.4290627e-01 3.0108912e-01 9.0554124e-02 -9.4812468e-02 -8.8842381e-02 6.3160674e-02 1.4646977e-01 1.7441277e-02 -2.2104173e-01 -3.1862778e-01 -1.5530235e-01 1.1291463e-01 2.1663682e-01 7.1521680e-02 -1.2722266e-01 -1.3147084e-01 6.8036453e-02 2.2914846e-01 1.4875917e-01 -8.5725554e-02 -1.9280127e-01 -3.7053987e-02 1.9484616e-01 2.0627194e-01 -5.0290692e-02 -2.9703694e-01 -2.4262627e-01 7.3980280e-02 3.1209111e-01 2.0500085e-01 -1.4678863e-01 -3.9620361e-01 -3.3299784e-01 -8.5315346e-02 7.0026906e-02 3.1783466e-02 -5.6224174e-02 -3.8238612e-02 4.1162402e-02 1.4020902e-02 -1.6267337e-01 -3.2229719e-01 -2.8405914e-01 -8.0208074e-02 7.7279407e-02 5.2461001e-02 -5.6931255e-02 -5.7081867e-02 8.4722273e-02 1.8989091e-01 9.1251490e-02 -1.4913841e-01 -3.0047660e-01 -2.2924644e-01 -4.5027749e-02 4.5847665e-02 -1.0582268e-02 -7.0165157e-02 8.8253349e-03 1.7968871e-01 2.6336655e-01 1.6274839e-01 -3.4038513e-02 -1.6866975e-01 -1.7822821e-01 -1.1212378e-01 -2.2511191e-02 9.2633595e-02 2.2273027e-01 2.8312792e-01 1.8855450e-01 -1.3339719e-02 -1.4451328e-01 -7.9411873e-02 9.5243626e-02 1.5825934e-01 8.6924573e-03 -1.9762612e-01 -2.0963986e-01 3.0881541e-02 3.1088543e-01 3.7605990e-01 2.0371110e-01 3.1659734e-03 -4.2255731e-02 2.7937777e-02 4.3768827e-02 -5.0975761e-02 -1.2013869e-01 -1.9514056e-02 1.9409077e-01 3.0061057e-01 1.6772761e-01 -8.4377993e-02 -2.0596833e-01 -8.8137439e-02 1.3053768e-01 2.3231724e-01 1.5592782e-01 3.3546556e-02 1.2609146e-02 8.8143918e-02 1.3076425e-01 5.2445727e-02 -9.1540218e-02 -1.6532665e-01 -8.9700956e-02 9.2256458e-02 2.6287064e-01 3.2206114e-01 2.4782579e-01 1.0180547e-01 -1.2653507e-02 -2.4053903e-02 4.5165362e-02 9.2697417e-02 3.9645255e-02 -7.0244568e-02 -9.7812594e-02 4.0489353e-02 2.5706426e-01 3.5970764e-01 2.4838839e-01 2.8758245e-02 -9.2051146e-02 -1.8531616e-02 1.4540527e-01 2.2483594e-01 1.6366159e-01 6.0613849e-02 2.6700790e-02 4.8805007e-02 2.4088984e-02 -8.7776563e-02 -1.9182802e-01 -1.5875230e-01 2.1332672e-02 2.1574747e-01 2.8121193e-01 1.9605244e-01 5.2140821e-02 -6.0594054e-02 -1.3111027e-01 -1.9003660e-01 -2.3031943e-01 -1.9896872e-01 -7.1576527e-02 8.7126470e-02 1.5966083e-01 8.0700885e-02 -9.6050487e-02 -2.3768453e-01 -2.4174619e-01 -1.1781079e-01 2.4058534e-02 6.3114157e-02 -3.4924911e-02 -1.8708629e-01 -2.5777811e-01 -1.7457598e-01 2.3256558e-03 1.2615984e-01 9.1298660e-02 -7.2869748e-02 -2.3064584e-01 -2.6487668e-01 -1.7896622e-01 -8.1019614e-02 -7.2160218e-02 -1.5109102e-01 -2.2270453e-01 -1.9311631e-01 -5.5949947e-02 1.0558527e-01 1.9015867e-01 1.5010510e-01 9.3491571e-03 -1.6206410e-01 -2.7872156e-01 -2.6789883e-01 -1.0908763e-01 1.3219241e-01 3.2581004e-01 3.6597785e-01 2.5860903e-01 1.1593033e-01 5.3232658e-02 8.9253999e-02 1.5038178e-01 1.6325136e-01 1.2516262e-01 8.1000365e-02 5.6249003e-02 4.1260796e-02 3.6021307e-02 7.0909773e-02 1.5431016e-01 2.1909293e-01 1.6946538e-01 1.3913978e-03 -1.5472276e-01 -1.5445369e-01 -6.5114694e-03 1.1511921e-01 5.3537688e-02 -1.4926948e-01 -2.8563000e-01 -2.0489020e-01 2.2256191e-02 1.8089745e-01 1.3686717e-01 -4.3194077e-02 -1.9185844e-01 -2.2260927e-01 -1.8688905e-01 -1.7299493e-01 -1.9552456e-01 -2.0311384e-01 -1.6521655e-01 -1.1035364e-01 -7.5596967e-02 -5.2167223e-02 -5.0648414e-03 6.7754101e-02 1.2412118e-01 1.2838133e-01 9.0308482e-02 4.0708671e-02 -1.2463102e-02 -7.6325303e-02 -1.2432208e-01 -9.0380523e-02 5.7426602e-02 2.4318485e-01 3.1839858e-01 2.0029814e-01 -2.6893656e-02 -1.7351791e-01 -1.2458940e-01 4.6580380e-02 1.5624992e-01 9.9382689e-02 -5.1882624e-02 -1.4100610e-01 -1.0040874e-01 -1.2845131e-02 -3.6737447e-03 -9.7637188e-02 -2.0172142e-01 -2.1938378e-01 -1.5223806e-01 -7.5818447e-02 -3.6932476e-02 -8.3361793e-03 4.9321106e-02 1.0828653e-01 8.6261922e-02 -5.6487106e-02 -2.4839500e-01 -3.5078033e-01 -2.7598256e-01 -6.2963150e-02 1.5901166e-01 2.7685307e-01 2.7164897e-01 2.1079033e-01 1.7714997e-01 2.0086813e-01 2.4438441e-01 2.4570310e-01 1.8078261e-01 9.0365447e-02 4.4844498e-02 7.6311118e-02 1.4103984e-01 1.5313326e-01 6.6678933e-02 -6.7720328e-02 -1.3565971e-01 -6.6316159e-02 8.3832277e-02 1.6588475e-01 7.6147385e-02 -1.3444251e-01 -2.9759248e-01 -2.8274479e-01 -1.1318459e-01 7.1421886e-02 1.5414324e-01 1.3182338e-01 8.0829372e-02 6.0814130e-02 6.6565578e-02 6.1490382e-02 3.4525574e-02 1.4709018e-02 3.9340413e-02 1.1733787e-01 2.1846966e-01 2.8684125e-01 2.6688313e-01 1.3632576e-01 -6.7370697e-02 -2.5502586e-01 -3.3949317e-01 -3.0013913e-01 -1.9871892e-01 -1.2610649e-01 -1.2941580e-01 -1.8923457e-01 -2.5813995e-01 -3.0533743e-01 -3.1970649e-01 -2.8788006e-01 -1.9500297e-01 -5.4155345e-02 8.1116905e-02 1.5269009e-01 1.4976106e-01 1.1681611e-01 1.0728712e-01 1.3670700e-01 1.8344060e-01 2.2041268e-01 2.2972773e-01 1.9334746e-01 9.8734288e-02 -2.6231283e-02 -9.9070456e-02 -4.1644202e-02 1.2360480e-01 2.5212308e-01 1.9060093e-01 -6.5066267e-02 -3.3581971e-01 -4.0871250e-01 -2.3222990e-01 4.0796545e-02 2.0553146e-01 1.9047036e-01 8.7982654e-02 2.1078714e-02 1.1947834e-02 -7.4158796e-03 -8.0649898e-02 -1.5932177e-01 -1.5963498e-01 -6.7654645e-02 3.3754864e-02 4.5488264e-02 -5.1656648e-02 -1.8439778e-01 -2.5821552e-01 -2.3168258e-01 -1.3075945e-01 -1.4319768e-02 6.0276859e-02 5.2808278e-02 -4.2009846e-02 -1.6857834e-01 -2.1862301e-01 -1.0815610e-01 1.2758494e-01 3.3007803e-01 3.4236071e-01 1.5606744e-01 -7.3906241e-02 -1.7487103e-01 -1.1779263e-01 -2.8797157e-02 -4.2649366e-02 -1.5603253e-01 -2.3465677e-01 -1.6213440e-01 3.1155521e-02 1.9455902e-01 2.0308035e-01 6.4105637e-02 -1.1373221e-01 -2.2912186e-01 -2.4930244e-01 -1.8794162e-01 -6.9023299e-02 6.6894859e-02 1.4860950e-01 1.1319286e-01 -2.1622177e-02 -1.4430675e-01 -1.4139382e-01 -1.4679189e-02 1.0606471e-01 8.3987908e-02 -8.6549724e-02 -2.6473902e-01 -2.8787546e-01 -1.1665499e-01 1.3032718e-01 2.7649250e-01 2.2886289e-01 4.1972959e-02 -1.4166947e-01 -2.1351821e-01 -1.7294568e-01 -9.5242426e-02 -3.9988034e-02 6.0215518e-04 6.4278100e-02 1.4411085e-01 1.7008073e-01 7.6346726e-02 -1.1397897e-01 -2.7942868e-01 -2.8837790e-01 -1.1356283e-01 1.2995490e-01 2.6791352e-01 2.1050936e-01 3.2758432e-02 -8.8492035e-02 -3.6187051e-02 1.3102808e-01 2.2789768e-01 1.2664599e-01 -9.9240525e-02 -2.3008477e-01 -1.1958430e-01 1.3943384e-01 2.8863442e-01 1.6130336e-01 -1.3747854e-01 -3.2522857e-01 -2.2524885e-01 5.3864511e-02 2.3305883e-01 1.5177574e-01 -7.4373920e-02 -1.8870441e-01 -6.7093573e-02 1.6495747e-01 2.8369836e-01 2.0511206e-01 5.1011236e-02 -6.5929875e-03 6.8964562e-02 1.6340844e-01 1.5740112e-01 5.4023734e-02 -4.3471011e-02 -5.1346211e-02 2.3145779e-02 1.1745308e-01 1.8212689e-01 1.9584070e-01 1.4022670e-01 5.9022790e-03 -1.6079919e-01 -2.4935419e-01 -1.7100378e-01 3.1256057e-02 1.8605482e-01 1.4297623e-01 -7.3243962e-02 -2.7593402e-01 -2.9797544e-01 -1.5307840e-01 -4.0914832e-03 2.1269662e-02 -4.1497170e-02 -5.9046655e-02 2.7976789e-02 1.2846949e-01 1.0303296e-01 -7.5938937e-02 -2.8392411e-01 -3.6123552e-01 -2.5664252e-01 -5.3262494e-02 1.2879625e-01 2.3255706e-01 2.6842403e-01 2.5122050e-01 1.7087253e-01 3.4014290e-02 -9.3227815e-02 -1.2001867e-01 -2.1139059e-02 1.2023890e-01 1.7758447e-01 9.6606085e-02 -5.2792108e-02 -1.3892628e-01 -8.4350032e-02 7.1620365e-02 2.1524576e-01 2.5910116e-01 2.0627091e-01 1.2532985e-01 7.1727643e-02 3.8319163e-02 -1.9240088e-02 -1.1662856e-01 -2.1107703e-01 -2.4258539e-01 -1.9809090e-01 -1.2271124e-01 -6.5266079e-02 -2.6001544e-02 2.6587042e-02 8.9979857e-02 1.0112134e-01 -1.6495775e-03 -1.8712095e-01 -3.2285436e-01 -2.8769737e-01 -1.0373843e-01 6.3283390e-02 6.4192144e-02 -6.9141383e-02 -1.4546154e-01 -2.2743165e-02 2.1671482e-01 3.3495240e-01 1.9730942e-01 -6.4245098e-02 -1.8430371e-01 -5.9313975e-02 1.3285821e-01 1.3988590e-01 -6.3313853e-02 -2.3781208e-01 -1.6565753e-01 7.8634007e-02 2.0643470e-01 6.3051903e-02 -1.7337120e-01 -1.9553447e-01 5.8877424e-02 3.1320739e-01 2.6455767e-01 -5.6738794e-02 -3.0614673e-01 -2.0738949e-01 1.4261991e-01 3.9321755e-01 3.3131011e-01 8.6485026e-02 -6.3943179e-02 -2.3354764e-02 5.9552949e-02 3.1845636e-02 -5.2189216e-02 -1.8514555e-02 1.7050716e-01 3.3649462e-01 2.9310084e-01 7.8582244e-02 -8.5200138e-02 -5.9242022e-02 5.3629257e-02 5.3919799e-02 -9.1290610e-02 -1.9983794e-01 -1.0236954e-01 1.3831631e-01 2.9035137e-01 -1.7703630e-01 -1.1470789e-01 -1.7257803e-02 7.3360924e-02 1.2806267e-01 1.3650217e-01 1.0539571e-01 5.4901306e-02 1.0347593e-02 -1.4210364e-02 -2.9316079e-02 -5.9818410e-02 -1.1287079e-01 -1.5651256e-01 -1.3759239e-01 -3.1325918e-02 1.2118952e-01 2.2925439e-01 2.1688928e-01 8.3280850e-02 -9.0968958e-02 -1.9863421e-01 -1.7919413e-01 -5.4874063e-02 9.1323774e-02 1.7241745e-01 1.4973591e-01 5.1202694e-02 -5.0722214e-02 -8.6474562e-02 -3.6675604e-02 5.0794719e-02 9.2852996e-02 3.5475423e-02 -9.8019853e-02 -2.1560266e-01 -2.2054921e-01 -8.4207430e-02 1.2773783e-01 2.9411889e-01 3.1432928e-01 1.7183620e-01 -5.3673166e-02 -2.3087548e-01 -2.5206313e-01 -9.9556443e-02 1.3579254e-01 3.0302360e-01 2.8345210e-01 6.9698019e-02 -2.2311064e-01 -4.2606792e-01 -4.1979542e-01 -2.0235411e-01 1.1680679e-01 3.8269042e-01 4.7499251e-01 3.6130151e-01 1.0698485e-01 -1.5666457e-01 -2.9684785e-01 -2.5130444e-01 -6.7456399e-02 1.2329504e-01 1.8968350e-01 8.9456729e-02 -1.0185072e-01 -2.4339863e-01 -2.2562726e-01 -4.5215735e-02 1.9190737e-01 3.3930982e-01 3.0360010e-01 1.0486525e-01 -1.3364785e-01 -2.6276635e-01 -2.0355127e-01 -1.0514338e-03 2.0109829e-01 2.5410141e-01 1.0538640e-01 -1.6182684e-01 -3.7724711e-01 -3.8906986e-01 -1.6075631e-01 2.0065197e-01 5.0030087e-01 5.6260189e-01 3.3306758e-01 -8.1981699e-02 -4.6637054e-01 -6.1157444e-01 -4.3578631e-01 -3.4787751e-02 3.6943357e-01 5.5331393e-01 4.1651911e-01 3.8203811e-02 -3.6624642e-01 -5.6531588e-01 -4.4111547e-01 -5.7977077e-02 3.6800859e-01 5.8749279e-01 4.6334166e-01 5.9154789e-02 -3.8817476e-01 -6.0585734e-01 -4.5438072e-01 -2.1770889e-02 4.2269933e-01 5.9388393e-01 3.7277877e-01 -1.1367643e-01 -5.6785416e-01 -7.0538273e-01 -4.3261293e-01 9.5667577e-02 5.7311674e-01 7.2849359e-01 4.8697304e-01 9.0040534e-03 -4.1643634e-01 -5.5375692e-01 -3.6053568e-01 1.0675442e-03 2.8391467e-01 3.2050851e-01 1.2014875e-01 -1.5499683e-01 -3.0636590e-01 -2.2845450e-01 3.0168597e-02 3.0447079e-01 4.1814633e-01 2.9408146e-01 3.3795396e-03 -2.8043536e-01 -3.9163122e-01 -2.7524621e-01 -1.6330862e-02 2.2338646e-01 3.1163298e-01 2.1884631e-01 2.0034460e-02 -1.6244160e-01 -2.3122765e-01 -1.5928083e-01 4.5460308e-03 1.6378113e-01 2.2566835e-01 1.5187573e-01 -1.8633628e-02 -1.8835877e-01 -2.5597784e-01 -1.7568160e-01 1.6144538e-02 2.1796548e-01 3.1334397e-01 2.3350541e-01 9.9054075e-04 -2.7139443e-01 -4.3349329e-01 -3.8409180e-01 -1.3941008e-01 1.6850242e-01 3.6865127e-01 3.5669633e-01 1.5962938e-01 -8.6421861e-02 -2.2603591e-01 -1.7879992e-01 1.5608870e-02 2.2316774e-01 2.9540664e-01 1.5777130e-01 -1.3932674e-01 -4.3707134e-01 -5.5308393e-01 -3.9056636e-01 -6.9866596e-03 4.0342788e-01 6.1470960e-01 5.0478901e-01 1.3556472e-01 -2.7661265e-01 -4.8754120e-01 -3.7410263e-01 -1.0933935e-02 3.7332700e-01 5.3265415e-01 3.5296792e-01 -7.5112937e-02 -5.0630963e-01 -6.8543131e-01 -5.0254861e-01 -6.3204556e-02 3.7616490e-01 5.6861420e-01 4.2839911e-01 7.7256895e-02 -2.4286013e-01 -3.2974149e-01 -1.4621212e-01 1.6396591e-01 3.7227253e-01 3.1398669e-01 -1.5203951e-03 -3.8826155e-01 -5.9422715e-01 -4.6290884e-01 -4.4082503e-02 4.2614489e-01 6.6944646e-01 5.4057059e-01 1.1914310e-01 -3.4186097e-01 -5.7361170e-01 -4.5144665e-01 -6.3037624e-02 3.5015696e-01 5.3940241e-01 3.9354970e-01 6.6063109e-05 -4.0735798e-01 -5.8396114e-01 -4.1610263e-01 1.0313382e-02 4.5449701e-01 6.5638620e-01 4.8903578e-01 3.8482894e-02 -4.3952337e-01 -6.6436421e-01 -4.9492372e-01 -1.7915270e-02 4.9445240e-01 7.3828446e-01 5.5772875e-01 4.3827397e-02 -5.1216643e-01 -7.8827423e-01 -6.2373284e-01 -1.1577453e-01 4.4053448e-01 7.3121649e-01 6.0691719e-01 1.6037942e-01 -3.4101558e-01 -6.1837622e-01 -5.3898039e-01 -1.7955555e-01 2.3296574e-01 4.6098842e-01 3.9204767e-01 9.4586522e-02 -2.3425494e-01 -3.9383077e-01 -2.9901136e-01 -2.1727093e-02 2.6290754e-01 3.8667642e-01 2.8641038e-01 3.4299620e-02 -2.1199530e-01 -3.0703990e-01 -2.0539827e-01 1.3733625e-02 1.9989717e-01 2.2856610e-01 8.0442398e-02 -1.4924794e-01 -3.1635143e-01 -3.2043874e-01 -1.6226330e-01 6.7449386e-02 2.5253008e-01 3.1855044e-01 2.6051993e-01 1.2699840e-01 -1.6342455e-02 -1.1750854e-01 -1.5094063e-01 -1.1699324e-01 -3.6407066e-02 5.7070826e-02 1.2470744e-01 1.3295525e-01 6.7237676e-02 -5.6199791e-02 -1.8928499e-01 -2.6860491e-01 -2.4751370e-01 -1.2546869e-01 4.7269068e-02 1.9379936e-01 2.5012057e-01 1.9757699e-01 6.9603172e-02 -6.6884197e-02 -1.4260360e-01 -1.1800895e-01 -4.5690911e-03 1.3505757e-01 2.1176910e-01 1.5667518e-01 -2.9715225e-02 -2.6058872e-01 -4.0072162e-01 -3.4636170e-01 -1.0002597e-01 2.1522385e-01 4.2116592e-01 3.9178740e-01 1.3552073e-01 -2.0194672e-01 -4.2193015e-01 -3.9351670e-01 -1.3365470e-01 2.0423921e-01 4.2544835e-01 4.1162219e-01 1.8730580e-01 -1.0283670e-01 -2.8986993e-01 -2.8756628e-01 -1.3866788e-01 2.8290398e-02 9.5513335e-02 3.5118646e-02 -8.2724881e-02 -1.5147446e-01 -1.0799938e-01 2.6949604e-02 1.6959254e-01 2.3358015e-01 1.8482066e-01 5.6424609e-02 -7.8806247e-02 -1.5583364e-01 -1.5299245e-01 -9.3729273e-02 -1.9708548e-02 3.8600307e-02 7.1469845e-02 7.8472613e-02 5.5625386e-02 -1.0621857e-03 -8.0782039e-02 -1.5057837e-01 -1.6705428e-01 -1.0304932e-01 2.9389143e-02 1.7801990e-01 2.7318425e-01 2.6234323e-01 1.3834554e-01 -5.4215912e-02 -2.3593270e-01 -3.2392000e-01 -2.6898405e-01 -8.5844039e-02 1.4215609e-01 2.9652172e-01 2.8801270e-01 1.1683545e-01 -1.1688760e-01 -2.6947626e-01 -2.4573958e-01 -6.4329645e-02 1.5353975e-01 2.6653313e-01 2.0755588e-01 2.4602079e-02 -1.5772495e-01 -2.2567844e-01 -1.4875573e-01 9.9414396e-03 1.4397851e-01 1.7486115e-01 9.6314112e-02 -3.2169687e-02 -1.2887854e-01 -1.3861783e-01 -5.9693947e-02 6.1826068e-02 1.6117670e-01 1.8758542e-01 1.2643056e-01 4.7038639e-03 -1.2089033e-01 -1.8936563e-01 -1.6676448e-01 -6.8240952e-02 4.6702545e-02 1.0911959e-01 8.7135042e-02 1.1538006e-02 -4.4789930e-02 -2.4262269e-02 6.5437901e-02 1.5116338e-01 1.4886934e-01 3.3820535e-02 -1.3097789e-01 -2.3522600e-01 -2.0099760e-01 -4.2018915e-02 1.4060900e-01 2.2430878e-01 1.4698003e-01 -4.9334401e-02 -2.4015379e-01 -2.9449301e-01 -1.5978257e-01 9.9469238e-02 3.3553927e-01 4.0432846e-01 2.5275189e-01 -4.8157255e-02 -3.4363559e-01 -4.8101858e-01 -3.9093124e-01 -1.2065446e-01 1.9561509e-01 4.0816957e-01 4.2449571e-01 2.4947873e-01 -2.2290220e-02 -2.5535821e-01 -3.3965313e-01 -2.4442241e-01 -3.2717407e-02 1.7386538e-01 2.6131002e-01 1.8344736e-01 -1.4617105e-02 -2.2004617e-01 -3.0989410e-01 -2.1648361e-01 2.9614296e-02 3.0600899e-01 4.6010027e-01 3.9585763e-01 1.3407054e-01 -1.9445050e-01 -4.2254041e-01 -4.4190341e-01 -2.6148822e-01 2.4561144e-03 1.9639531e-01 2.2058130e-01 8.8618067e-02 -8.2771773e-02 -1.5145974e-01 -4.8116921e-02 1.7081593e-01 3.5448643e-01 3.5655964e-01 1.3834184e-01 -1.9528570e-01 -4.5613811e-01 -4.9089820e-01 -2.7873232e-01 5.5837539e-02 3.2156811e-01 3.7683870e-01 2.1007687e-01 -6.1195486e-02 -2.6670692e-01 -2.8529736e-01 -1.1252984e-01 1.4069959e-01 3.1548805e-01 3.0070613e-01 1.0177110e-01 -1.6096596e-01 -3.2711612e-01 -2.9842835e-01 -9.9492033e-02 1.4305421e-01 2.8418081e-01 2.4879424e-01 7.0440776e-02 -1.3708347e-01 -2.5105923e-01 -2.1001593e-01 -4.5285982e-02 1.4155737e-01 2.4209754e-01 2.0725941e-01 7.3959838e-02 -6.6466455e-02 -1.3533231e-01 -1.1722667e-01 -5.6247689e-02 -8.2151160e-03 4.6646596e-03 -5.3013327e-05 6.4836935e-03 3.4885521e-02 7.2093769e-02 9.6085499e-02 9.0621414e-02 5.0063443e-02 -1.9216694e-02 -9.5194586e-02 -1.4177512e-01 -1.2554939e-01 -4.1561203e-02 7.4612994e-02 1.6458119e-01 1.8370169e-01 1.2694288e-01 2.5574339e-02 -7.6209464e-02 -1.4292208e-01 -1.5717793e-01 -1.2150507e-01 -5.7465582e-02 3.0433319e-03 3.8135050e-02 5.3444515e-02 7.4126764e-02 1.1232692e-01 1.4266966e-01 1.1713381e-01 1.2919877e-02 -1.3094351e-01 -2.2903887e-01 -2.1083457e-01 -7.7741149e-02 9.2251468e-02 1.9732652e-01 1.8027267e-01 6.1530912e-02 -8.1015797e-02 -1.6435623e-01 -1.4922825e-01 -5.8874212e-02 3.9408110e-02 7.8379546e-02 3.6886774e-02 -4.2241134e-02 -8.1505612e-02 -2.9557008e-02 9.2798034e-02 2.0055247e-01 2.0414883e-01 7.6944227e-02 -1.2029199e-01 -2.7519345e-01 -2.9408814e-01 -1.6081545e-01 5.1070794e-02 2.1840144e-01 2.3874816e-01 9.4335060e-02 -1.2904879e-01 -2.8774773e-01 -2.6899028e-01 -6.6408095e-02 2.1071698e-01 4.0356249e-01 3.9994180e-01 1.9633323e-01 -1.0730235e-01 -3.6601054e-01 -4.6248715e-01 -3.5922221e-01 -1.1354600e-01 1.4870456e-01 2.9521055e-01 2.5966678e-01 8.3040302e-02 -1.0914113e-01 -1.8742442e-01 -1.0478464e-01 7.3317409e-02 2.1546569e-01 2.1382067e-01 5.6531581e-02 -1.6427012e-01 -3.1183656e-01 -2.9186150e-01 -1.1383004e-01 1.1231696e-01 2.4506533e-01 2.0292544e-01 1.9811075e-02 -1.7391062e-01 -2.3677906e-01 -1.1242105e-01 1.2953875e-01 3.3467916e-01 3.5946938e-01 1.6169418e-01 -1.6880410e-01 -4.5538345e-01 -5.3000472e-01 -3.2991559e-01 5.7588162e-02 4.3386984e-01 5.9508457e-01 4.4813661e-01 6.8860243e-02 -3.3635714e-01 -5.4527976e-01 -4.4370745e-01 -8.9647493e-02 3.1753702e-01 5.4673805e-01 4.6318145e-01 1.0733728e-01 -3.1949400e-01 -5.6446899e-01 -4.7269412e-01 -8.8269356e-02 3.6150197e-01 5.9965309e-01 4.7275161e-01 5.2712510e-02 -4.0097128e-01 -6.0010920e-01 -4.1032807e-01 6.1089052e-02 5.2877389e-01 7.0388838e-01 4.7272792e-01 -3.2841140e-02 -5.1806125e-01 -7.0615746e-01 -5.0443062e-01 -5.3964611e-02 3.6781621e-01 5.2531916e-01 3.6514315e-01 3.1895267e-02 -2.4276338e-01 -2.9561167e-01 -1.2568333e-01 1.2380832e-01 2.6979551e-01 2.0920891e-01 -2.0179145e-02 -2.6980104e-01 -3.7620139e-01 -2.6519009e-01 -1.4966321e-04 2.5905182e-01 3.5875119e-01 2.4783584e-01 5.4317821e-03 -2.1770753e-01 -2.9814845e-01 -2.0810260e-01 -1.7395596e-02 1.5890290e-01 2.2758901e-01 1.6085463e-01 3.3576307e-03 -1.5297196e-01 -2.1737064e-01 -1.5023570e-01 1.2479222e-02 1.7606639e-01 2.4089523e-01 1.6216345e-01 -2.3230254e-02 -2.1504218e-01 -3.0098784e-01 -2.1779026e-01 8.8067567e-03 2.6812984e-01 4.1695437e-01 3.6159556e-01 1.2203070e-01 -1.7147580e-01 -3.5437470e-01 -3.3058973e-01 -1.3341351e-01 9.9954914e-02 2.1969740e-01 1.5589313e-01 -4.1996520e-02 -2.3771826e-01 -2.9083527e-01 -1.4002506e-01 1.5548285e-01 4.3862419e-01 5.3769302e-01 3.6811228e-01 -6.9569482e-03 -3.9769165e-01 -5.8956799e-01 -4.7193386e-01 -1.1138894e-01 2.8025332e-01 4.6943948e-01 3.4372376e-01 -1.6555081e-02 -3.8429530e-01 -5.2185674e-01 -3.2705351e-01 1.0055685e-01 5.1629500e-01 6.7570174e-01 4.8204840e-01 4.6679399e-02 -3.7892485e-01 -5.5799051e-01 -4.1189337e-01 -6.3130989e-02 2.4927425e-01 3.2624429e-01 1.3391859e-01 -1.7899014e-01 -3.7999275e-01 -3.0718591e-01 1.9919795e-02 4.0587411e-01 5.9872071e-01 4.5200311e-01 2.6827172e-02 -4.3774484e-01 -6.7014857e-01 -5.3423365e-01 -1.1312830e-01 3.4367827e-01 5.7281717e-01 4.5156693e-01 6.5481027e-02 -3.4683106e-01 -5.3783781e-01 -3.9562633e-01 -5.2304328e-03 4.0256826e-01 5.8408144e-01 4.2300297e-01 -1.8218267e-04 -4.4833216e-01 -6.5943295e-01 -5.0033881e-01 -5.1578103e-02 4.3192551e-01 6.6545648e-01 5.0237264e-01 2.6477477e-02 -4.8897549e-01 -7.3697545e-01 -5.5960739e-01 -4.7597748e-02 5.0867228e-01 7.8911527e-01 6.3269313e-01 1.3197226e-01 -4.2464681e-01 -7.2603682e-01 -6.1784801e-01 -1.8264666e-01 3.2014735e-01 6.1135123e-01 5.4895999e-01 1.9768580e-01 -2.2062099e-01 -4.6220719e-01 -4.0211731e-01 -9.9950534e-02 2.4465654e-01 4.1872319e-01 3.2500596e-01 3.2810917e-02 -2.7440750e-01 -4.1536442e-01 -3.1832701e-01 -5.5989066e-02 2.0726049e-01 3.1798239e-01 2.2484797e-01 5.1703651e-03 -1.8889751e-01 -2.2927380e-01 -9.1914974e-02 1.3314428e-01 3.0513495e-01 3.2224987e-01 1.7778028e-01 -4.7100451e-02 -2.4007922e-01 -3.2145867e-01 -2.7615883e-01 -1.4545755e-01 4.2822900e-03 1.1399372e-01 1.5138712e-01 1.1530153e-01 3.0234280e-02 -6.4234624e-02 -1.2615802e-01 -1.2407054e-01 -4.9317670e-02 7.5619816e-02 2.0015044e-01 2.6472178e-01 2.3118708e-01 1.0699863e-01 -5.5412012e-02 -1.8550876e-01 -2.3096135e-01 -1.8218227e-01 -7.2615500e-02 4.0881922e-02 1.0372451e-01 8.6362391e-02 -1.1351454e-03 -1.0889033e-01 -1.6548976e-01 -1.1405709e-01 4.6560657e-02 2.4386985e-01 3.6111476e-01 3.0662373e-01 8.1468123e-02 -2.0497551e-01 -3.9165036e-01 -3.6309524e-01 -1.2535574e-01 1.8954273e-01 3.9793935e-01 3.7486538e-01 1.3124068e-01 -1.9174474e-01 -4.0848802e-01 -4.0149539e-01 -1.8960477e-01 9.0301438e-02 2.7507284e-01 2.7972729e-01 1.4341274e-01 -1.2566755e-02 -7.8032703e-02 -2.7425697e-02 7.5351759e-02 1.3487633e-01 9.5488652e-02 -2.4590018e-02 -1.5233210e-01 -2.1189289e-01 -1.7248897e-01 -6.2455423e-02 5.4933614e-02 1.2398028e-01 1.2778044e-01 8.7386392e-02 3.4966577e-02 -1.0850501e-02 -4.6716543e-02 -6.9020828e-02 -6.3681635e-02 -1.6203206e-02 6.7394491e-02 1.5127737e-01 1.8399090e-01 1.2920707e-01 -7.0434827e-03 -1.7216342e-01 -2.8937677e-01 -2.9509198e-01 -1.7314710e-01 3.2745183e-02 2.3542177e-01 3.4097958e-01 2.9247721e-01 1.0411948e-01 -1.3495077e-01 -2.9868629e-01 -2.9240849e-01 -1.1517683e-01 1.2871323e-01 2.8803761e-01 2.6146766e-01 6.7234759e-02 -1.6729947e-01 -2.9180077e-01 -2.3297675e-01 -3.8493954e-02 1.6188055e-01 2.4607750e-01 1.7580193e-01 1.0770499e-02 -1.3917580e-01 -1.8630712e-01 -1.1496682e-01 1.8120146e-02 1.2605380e-01 1.4532251e-01 6.9056099e-02 -5.5814690e-02 -1.6001831e-01 -1.8912751e-01 -1.2778372e-01 -4.4698128e-03 1.2208903e-01 1.8963074e-01 1.6384408e-01 6.0799128e-02 -5.7339158e-02 -1.1860919e-01 -9.0086196e-02 -4.5798607e-03 6.0280807e-02 4.1676388e-02 -5.5180320e-02 -1.5518201e-01 -1.6828578e-01 -6.2049884e-02 1.0561621e-01 2.2337555e-01 2.0643187e-01 5.9839911e-02 -1.2043322e-01 -2.1083864e-01 -1.4415945e-01 4.3538937e-02 2.3203364e-01 2.9044234e-01 1.6171416e-01 -9.5674666e-02 -3.3749265e-01 -4.1795872e-01 -2.7746809e-01 2.0648626e-02 3.2603206e-01 4.8410918e-01 4.1672303e-01 1.5905611e-01 -1.6318595e-01 -3.9931562e-01 -4.4568803e-01 -2.9169291e-01 -2.0960934e-02 2.3175866e-01 3.4693819e-01 2.7877641e-01 7.7125945e-02 -1.4069530e-01 -2.5367798e-01 -2.0150506e-01 -1.6778161e-02 1.9116819e-01 2.9409556e-01 2.1593628e-01 -1.9610708e-02 -2.9401135e-01 -4.5512990e-01 -4.0311941e-01 -1.5075705e-01 1.7921653e-01 4.2153577e-01 4.6143206e-01 2.9688389e-01 3.5275834e-02 -1.7206796e-01 -2.2040717e-01 -1.1280250e-01 4.6014479e-02 1.2005000e-01 3.5297082e-02 -1.6459920e-01 -3.4121448e-01 -3.5130088e-01 -1.4787707e-01 1.7615712e-01 4.3972643e-01 4.8949447e-01 2.9899548e-01 -1.6059656e-02 -2.7414987e-01 -3.4124596e-01 -2.0476598e-01 3.1287353e-02 2.1535118e-01 2.3693813e-01 8.7039128e-02 -1.3914592e-01 -2.9731202e-01 -2.8057123e-01 -8.9244625e-02 1.6445576e-01 3.2621002e-01 2.9949560e-01 1.0678193e-01 -1.3016725e-01 -2.7225661e-01 -2.4687907e-01 -8.3173776e-02 1.1381888e-01 2.2819642e-01 1.9830143e-01 4.8505476e-02 -1.2763594e-01 -2.2560309e-01 -1.9560311e-01 -7.1212054e-02 6.0380807e-02 1.2445307e-01 1.0835168e-01 5.5609724e-02 1.7269294e-02 9.3997346e-03 1.1223045e-02 -4.3543819e-03 -4.2668837e-02 -8.5657964e-02 -1.0909342e-01 -9.7154374e-02 -4.6781850e-02 3.1101930e-02 1.0973840e-01 1.5122945e-01 1.2531404e-01 3.3620966e-02 -8.3194568e-02 -1.6716420e-01 1998. 1999. 2000. 2001. slicot-5.0+20101122/examples77/IB03BD.res000077500000000000000000000014541201767322700171270ustar00rootroot00000000000000 IB03BD EXAMPLE PROGRAM RESULTS IWARN on exit from IB03BD = 12 Final 2-norm of the residuals = 0.3048502D+00 Number of iterations = 23 Number of function evaluations = 625 Number of Jacobian evaluations = 270 Final approximate solution is 16.2674 1.2144 6.5207 -10.8207 7.7778 -5.3537 -50.6063 1291.8734 -0.3668 -73.8082 5.9979 -0.9106 0.0922 0.3366 0.9149 0.2901 1.3182 0.0179 0.0594 -0.0034 -0.3844 -0.0426 -2.0905 -0.9365 1.3176 0.8249 0.5811 0.8912 -0.3723 3.1782 -5.2780 -56.5497 -0.1040 -7.7904 0.1320 0.3895 0.0536 7.8236 -15.0550 2.4100 -68.6242 -0.8531 -0.7139 2.0029 1.4205 -0.2031 -0.9372 -0.0045 0.3742 0.1818 slicot-5.0+20101122/examples77/MB01TD.dat000077500000000000000000000005161201767322700171300ustar00rootroot00000000000000 MB01TD EXAMPLE PROGRAM DATA 5 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 0. 0. 1. 5. 1. 0. 0. 0. 0. -4. 0. 0. 0. 20. 4. 5. 5. 1. 5. 1. -2. 1. 3. 0. -4. 0. 0. 4. 20. 4. 0. 0. 0. 3. 5. 0. 0. 0. 1. -2. slicot-5.0+20101122/examples77/MB01TD.res000077500000000000000000000004431201767322700171500ustar00rootroot00000000000000 MB01TD EXAMPLE PROGRAM RESULTS The matrix product A*B is 1.0000 7.0000 31.0000 139.0000 22.0000 -8.0000 -11.0000 -9.0000 -32.0000 2.0000 0.0000 0.0000 4.0000 36.0000 27.0000 0.0000 0.0000 0.0000 -4.0000 8.0000 0.0000 0.0000 0.0000 64.0000 92.0000 slicot-5.0+20101122/examples77/MB02CD.dat000077500000000000000000000002411201767322700171030ustar00rootroot00000000000000MB02CD EXAMPLE PROGRAM DATA 3 2 A 3.0000 1.0000 0.1000 0.1000 0.2000 0.0500 1.0000 4.0000 0.4000 0.1000 0.0400 0.2000 slicot-5.0+20101122/examples77/MB02CD.res000077500000000000000000000020641201767322700171310ustar00rootroot00000000000000 MB02CD EXAMPLE PROGRAM RESULTS The generator of the inverse of block Toeplitz matrix is -0.2355 0.5231 -0.0642 0.0077 0.0187 -0.0265 -0.5568 -0.0568 0.0229 0.0060 0.0363 0.0000 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.0000 0.0000 0.0119 -0.0265 -0.0110 0.0076 The lower Cholesky factor of the inverse is 0.5774 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1741 0.5222 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0581 0.5812 0.0000 0.0000 0.0000 -0.0142 0.0080 -0.1747 0.5224 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.5825 0.0000 0.0119 -0.0265 -0.0110 0.0076 -0.1754 0.5231 The upper Cholesky factor of block Toeplitz matrix is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 0.0000 0.0000 0.0000 0.0000 1.7169 0.5759 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 slicot-5.0+20101122/examples77/MB02DD.dat000077500000000000000000000004061201767322700171070ustar00rootroot00000000000000MB02DD EXAMPLE PROGRAM DATA 3 2 2 A R 3.0000 1.0000 0.1000 0.1000 0.2000 0.0500 0.1000 0.0400 0.01 0.02 1.0000 4.0000 0.4000 0.1000 0.0400 0.2000 0.0300 0.0200 0.03 0.01 slicot-5.0+20101122/examples77/MB02DD.res000077500000000000000000000063401201767322700171330ustar00rootroot00000000000000 MB02DD EXAMPLE PROGRAM RESULTS The Cholesky factor is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 0.0000 0.0000 0.0000 0.0000 1.7169 0.5759 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 The inverse generator is -0.2355 0.5231 -0.0642 0.0077 0.0187 -0.0265 -0.5568 -0.0568 0.0229 0.0060 0.0363 0.0000 0.5825 0.0000 -0.0387 0.0052 0.0003 -0.0575 -0.1754 0.5231 0.0119 -0.0265 -0.0110 0.0076 The inverse Cholesky factor is 0.5774 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1741 0.5222 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0581 0.5812 0.0000 0.0000 0.0000 -0.0142 0.0080 -0.1747 0.5224 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.5825 0.0000 0.0119 -0.0265 -0.0110 0.0076 -0.1754 0.5231 The updated Cholesky factor is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.0577 0.0231 0.0058 0.0115 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 -0.0017 0.0035 0.0139 0.0017 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.1145 0.0279 0.0564 0.0227 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 -0.0152 0.0953 -0.0017 0.0033 0.0000 0.0000 0.0000 0.0000 1.7169 0.5759 0.0523 0.0453 0.1146 0.0273 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 0.1902 0.0357 -0.0157 0.0955 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.7159 0.5757 0.0526 0.0450 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.9118 0.1901 0.0357 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.7159 0.5757 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.9117 The updated inverse generator is -0.5599 0.3310 -0.0305 0.0098 0.0392 -0.0209 0.0191 -0.0010 -0.0045 0.0035 -0.2289 -0.4091 0.0612 -0.0012 0.0125 0.0182 0.0042 0.0017 0.0014 0.0000 0.5828 0.0000 0.0027 -0.0029 -0.0195 0.0072 -0.0393 0.0057 0.0016 -0.0580 -0.1755 0.5231 -0.0037 0.0022 0.0005 -0.0022 0.0125 -0.0266 -0.0109 0.0077 The updated inverse Cholesky factor is 0.5774 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1741 0.5222 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0581 0.5812 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0142 0.0080 -0.1747 0.5224 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0387 0.0052 0.0003 -0.0575 0.5825 0.0000 0.0000 0.0000 0.0000 0.0000 0.0119 -0.0265 -0.0110 0.0076 -0.1754 0.5231 0.0000 0.0000 0.0000 0.0000 -0.0199 0.0073 -0.0391 0.0056 0.0017 -0.0580 0.5828 0.0000 0.0000 0.0000 0.0007 -0.0023 0.0122 -0.0265 -0.0110 0.0077 -0.1755 0.5231 0.0000 0.0000 0.0027 -0.0029 -0.0195 0.0072 -0.0393 0.0057 0.0016 -0.0580 0.5828 0.0000 -0.0037 0.0022 0.0005 -0.0022 0.0125 -0.0266 -0.0109 0.0077 -0.1755 0.5231 slicot-5.0+20101122/examples77/MB02ED.dat000077500000000000000000000010041201767322700171030ustar00rootroot00000000000000MB02ED EXAMPLE PROGRAM DATA 3 3 2 C 3.0000 1.0000 0.2000 1.0000 4.0000 0.4000 0.2000 0.4000 5.0000 0.1000 0.1000 0.2000 0.2000 0.0400 0.0300 0.0500 0.2000 0.1000 0.1000 0.0300 0.1000 0.0400 0.0200 0.2000 0.0100 0.0300 0.0200 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 1.0000 2.0000 slicot-5.0+20101122/examples77/MB02ED.res000077500000000000000000000003511201767322700171300ustar00rootroot00000000000000 MB02ED EXAMPLE PROGRAM RESULTS The solution of T*X = B is 0.2408 0.4816 0.1558 0.3116 0.1534 0.3068 0.2302 0.4603 0.1467 0.2934 0.1537 0.3075 0.2349 0.4698 0.1498 0.2995 0.1653 0.3307 slicot-5.0+20101122/examples77/MB02FD.dat000077500000000000000000000002711201767322700171110ustar00rootroot00000000000000MB02FD EXAMPLE 4 2 3 0 1 1 3.0000 1.0000 0.1000 0.1000 0.2000 0.0500 0.2000 0.3000 1.0000 4.0000 0.4000 0.1000 0.0400 0.2000 0.1000 0.2000 slicot-5.0+20101122/examples77/MB02FD.res000077500000000000000000000007751201767322700171430ustar00rootroot00000000000000 MB02FD EXAMPLE PROGRAM RESULTS Incomplete Cholesky factorization rows norm(Schur complement) 0 5.5509 2 5.1590 4 4.8766 The upper ICC factor of the block Toeplitz matrix is 1.7321 0.5774 0.0577 0.0577 0.1155 0.0289 0.1155 0.1732 0.0000 1.9149 0.1915 0.0348 -0.0139 0.0957 0.0174 0.0522 0.0000 0.0000 1.7205 0.5754 0.0558 0.0465 0.1104 0.0174 0.0000 0.0000 0.0000 1.9142 0.1890 0.0357 -0.0161 0.0931 slicot-5.0+20101122/examples77/MB02GD.dat000077500000000000000000000002451201767322700171130ustar00rootroot00000000000000MB02GD EXAMPLE PROGRAM DATA 2 4 2 T 3.0000 1.0000 0.1000 0.4000 0.2000 0.0000 0.0000 4.0000 0.1000 0.1000 0.0500 0.2000 slicot-5.0+20101122/examples77/MB02GD.res000077500000000000000000000007041201767322700171340ustar00rootroot00000000000000 MB02GD EXAMPLE PROGRAM RESULTS The upper Cholesky factor in banded storage format 0.0000 0.0000 0.0000 0.0000 0.1155 0.1044 0.1156 0.1051 0.0000 0.0000 0.0000 0.2309 -0.0087 0.2290 -0.0084 0.2302 0.0000 0.0000 0.0577 -0.0174 0.0541 -0.0151 0.0544 -0.0159 0.0000 0.5774 0.0348 0.5704 0.0222 0.5725 0.0223 0.5724 1.7321 1.9149 1.7307 1.9029 1.7272 1.8996 1.7272 1.8995 slicot-5.0+20101122/examples77/MB02HD.dat000077500000000000000000000003041201767322700171100ustar00rootroot00000000000000MB02HD EXAMPLE PROGRAM DATA 2 2 6 2 5 1 N 4.0 4.0 1.0 3.0 2.0 1.0 2.0 2.0 4.0 4.0 3.0 4.0 1.0 3.0 2.0 1.0 slicot-5.0+20101122/examples77/MB02HD.res000077500000000000000000000014541201767322700171400ustar00rootroot00000000000000 MB02HD EXAMPLE PROGRAM RESULTS The lower triangular factor R in banded storage -7.0711 -2.4125 6.0822 2.9967 5.9732 2.8593 5.8497 2.7914 2.7298 1.9557 -7.4953 -0.0829 5.8986 -0.5571 5.5329 0.2059 5.6797 0.3414 0.9565 0.0000 -4.2426 0.9202 2.4747 -1.6425 2.9472 -1.0052 2.4396 -0.7785 0.0000 0.0000 -5.2326 0.6218 2.8391 -0.0820 3.2670 0.6327 2.7067 0.0000 0.0000 0.0000 -3.5355 0.8207 3.1160 -0.4451 3.5758 0.5701 0.0000 0.0000 0.0000 0.0000 -4.6669 -0.5803 3.9454 0.7682 4.5481 0.0000 0.0000 0.0000 0.0000 0.0000 -1.4142 -0.0415 1.6441 0.4848 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -2.1213 0.0000 2.4662 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/MB02ID.dat000077500000000000000000000010121201767322700171060ustar00rootroot00000000000000MB02ID EXAMPLE PROGRAM DATA 3 2 4 3 1 1 A 5.0 2.0 1.0 2.0 4.0 3.0 4.0 0.0 2.0 2.0 3.0 3.0 5.0 1.0 3.0 3.0 1.0 1.0 2.0 3.0 1.0 3.0 2.0 2.0 1.0 4.0 2.0 3.0 2.0 2.0 2.0 4.0 3.0 1.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 slicot-5.0+20101122/examples77/MB02ID.res000077500000000000000000000004601201767322700171350ustar00rootroot00000000000000 MB02ID EXAMPLE PROGRAM RESULTS The least squares solution of T * X = B is 0.0379 0.1677 0.0485 -0.0038 0.0429 0.1365 The minimum norm solution of T^T * X = C is 0.0509 0.0547 0.0218 0.0008 0.0436 0.0404 0.0031 0.0451 0.0421 0.0243 0.0556 0.0472 slicot-5.0+20101122/examples77/MB02JD.dat000077500000000000000000000005371201767322700171220ustar00rootroot00000000000000MB02JD EXAMPLE PROGRAM DATA 2 3 4 3 Q 1.0 4.0 0.0 4.0 1.0 2.0 4.0 2.0 2.0 5.0 3.0 2.0 2.0 4.0 4.0 5.0 3.0 4.0 2.0 2.0 5.0 4.0 2.0 3.0 3.0 4.0 2.0 5.0 0.0 4.0 5.0 1.0 1.0 2.0 4.0 1.0 slicot-5.0+20101122/examples77/MB02JD.res000077500000000000000000000024401201767322700171360ustar00rootroot00000000000000 MB02JD EXAMPLE PROGRAM RESULTS The factor Q is -0.0967 0.7166 -0.4651 0.1272 0.4357 0.0435 0.2201 0.0673 -0.3867 -0.3108 -0.0534 0.5251 0.0963 -0.3894 0.1466 0.5412 -0.3867 -0.0990 -0.1443 -0.7021 0.3056 -0.3367 -0.3233 0.1249 -0.4834 -0.0178 -0.3368 -0.1763 -0.5446 0.5100 0.1503 0.2054 -0.1933 0.5859 0.3214 0.1156 -0.4670 -0.3199 -0.4185 0.0842 -0.4834 -0.0178 0.1072 0.0357 -0.0575 -0.2859 0.4339 -0.6928 -0.1933 0.1623 0.7251 -0.1966 0.2736 0.3058 0.3398 0.2968 -0.3867 -0.0990 0.0777 0.3615 0.3386 0.4421 -0.5693 -0.2641 The factor R is -10.3441 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -6.3805 4.7212 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -7.3472 1.9320 4.5040 0.0000 0.0000 0.0000 0.0000 0.0000 -10.0541 2.5101 0.5065 3.6550 0.0000 0.0000 0.0000 0.0000 -6.5738 3.6127 1.2702 -1.3146 3.5202 0.0000 0.0000 0.0000 -5.2204 2.4764 2.4113 1.3890 1.2780 2.4976 0.0000 0.0000 -9.6674 3.2445 -0.5099 -0.0224 2.6548 2.9491 1.0049 0.0000 -6.3805 0.6968 1.9483 0.3050 0.7002 -2.0220 -2.8246 2.3147 -4.1570 2.4309 -0.7190 -0.1455 3.0149 0.5454 0.9394 -0.0548 slicot-5.0+20101122/examples77/MB02JX.dat000077500000000000000000000012211201767322700171350ustar00rootroot00000000000000MB02JX EXAMPLE PROGRAM DATA 3 3 4 4 -1.0D0 -1.0D0 Q 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 0.0 1.0 1.0 1.0 0.0 2.0 2.0 0.0 1.0 2.0 3.0 1.0 2.0 3.0 0.0 1.0 1.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 2.0 1.0 1.0 2.0 3.0 1.0 2.0 3.0 1.0 1.0 1.0 1.0 2.0 3.0 1.0 2.0 3.0 0.0 1.0 0.0 slicot-5.0+20101122/examples77/MB02JX.res000077500000000000000000000033001201767322700171560ustar00rootroot00000000000000 MB02JX EXAMPLE PROGRAM RESULTS Numerical rank RNK = 7 The factor Q is -0.3313 -0.0105 -0.0353 0.0000 -0.4714 -0.8165 0.0000 -0.3313 -0.0105 -0.0353 0.0000 -0.4714 0.4082 0.7071 -0.3313 -0.0105 -0.0353 0.0000 -0.4714 0.4082 -0.7071 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.3313 -0.0105 -0.0353 0.0000 0.2357 0.0000 0.0000 -0.1104 0.2824 0.9529 0.0000 0.0000 0.0000 0.0000 0.0000 0.4288 -0.1271 0.8944 0.0000 0.0000 0.0000 0.0000 0.8576 -0.2541 -0.4472 0.0000 0.0000 0.0000 The factor R is -9.0554 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.0921 2.3322 0.0000 0.0000 0.0000 0.0000 0.0000 -5.9633 1.9557 -1.2706 0.0000 0.0000 0.0000 0.0000 -9.2762 4.4238 0.7623 1.3416 0.0000 0.0000 0.0000 -6.1842 2.9492 0.5082 0.8944 0.0000 0.0000 0.0000 -3.0921 1.4746 0.2541 0.4472 0.0000 0.0000 0.0000 -9.2762 4.4238 0.7623 1.3416 0.0000 0.0000 0.0000 -6.1842 2.9492 0.5082 0.8944 0.0000 0.0000 0.0000 -3.0921 1.4746 0.2541 0.4472 0.0000 0.0000 0.0000 -7.2885 4.4866 0.9741 1.3416 2.8284 0.0000 0.0000 -2.7608 1.4851 0.2894 0.4472 0.4714 0.8165 0.0000 -5.5216 2.9701 0.5788 0.8944 0.9428 0.4082 0.7071 The column permutation is 3 1 2 6 5 4 9 8 7 12 10 11 slicot-5.0+20101122/examples77/MB02KD.dat000077500000000000000000000010471201767322700171200ustar00rootroot00000000000000MB02KD EXAMPLE PROGRAM DATA 3 2 4 5 1 C N 4.0 1.0 3.0 5.0 2.0 1.0 4.0 1.0 3.0 4.0 2.0 4.0 3.0 1.0 3.0 0.0 4.0 4.0 5.0 1.0 3.0 1.0 4.0 3.0 5.0 2.0 2.0 2.0 2.0 1.0 1.0 3.0 4.0 1.0 5.0 4.0 5.0 4.0 1.0 2.0 2.0 3.0 4.0 1.0 3.0 3.0 3.0 3.0 0.0 2.0 2.0 2.0 1.0 3.0 3.0 4.0 2.0 3.0 slicot-5.0+20101122/examples77/MB02KD.res000077500000000000000000000002641201767322700171410ustar00rootroot00000000000000 MB02KD EXAMPLE PROGRAM RESULTS The product C = T * B is 45.0000 76.0000 55.0000 44.0000 84.0000 56.0000 52.0000 70.0000 54.0000 49.0000 63.0000 59.0000 slicot-5.0+20101122/examples77/MB02MD.dat000077500000000000000000000004371201767322700171240ustar00rootroot00000000000000 MB02MD EXAMPLE PROGRAM DATA 6 3 1 B 0.0 0.80010 0.39985 0.60005 0.89999 0.29996 0.69990 0.39997 0.82997 0.49994 0.60003 0.20012 0.79011 0.90013 0.20016 0.79995 0.85002 0.39998 0.80006 0.49985 0.99016 0.20002 0.90007 0.70009 1.02994 slicot-5.0+20101122/examples77/MB02MD.res000077500000000000000000000003431201767322700171410ustar00rootroot00000000000000 MB02MD EXAMPLE PROGRAM RESULTS The computed rank of the TLS approximation = 3 The solution X to the TLS problem is 0.5003 0.8003 0.2995 The singular values of C are 3.2281 0.8716 0.3697 0.0001 slicot-5.0+20101122/examples77/MB02ND.dat000077500000000000000000000004631201767322700171240ustar00rootroot00000000000000 MB02ND EXAMPLE PROGRAM DATA 6 3 1 -1 0.001 0.0 0.0 0.80010 0.39985 0.60005 0.89999 0.29996 0.69990 0.39997 0.82997 0.49994 0.60003 0.20012 0.79011 0.90013 0.20016 0.79995 0.85002 0.39998 0.80006 0.49985 0.99016 0.20002 0.90007 0.70009 1.02994 slicot-5.0+20101122/examples77/MB02ND.res000077500000000000000000000014101201767322700171360ustar00rootroot00000000000000 MB02ND EXAMPLE PROGRAM RESULTS The computed rank of the TLS approximation = 3 The elements of the partially diagonalized bidiagonal matrix are (1,1) = 3.2280 (1,2) = -0.0287 (2,2) = 0.8714 (2,3) = 0.0168 (3,3) = 0.3698 (3,4) = 0.0000 (4,4) = 0.0001 The solution X to the TLS problem is 0.5003 0.8003 0.2995 Right singular subspace corresponds to the first 4 components of the j-th column of C for which INUL(j) = .TRUE., j = 1,..., 4 Matrix C -0.3967 -0.7096 0.4612 -0.3555 0.9150 -0.2557 0.2414 -0.5687 -0.0728 0.6526 0.5215 -0.2128 0.0000 0.0720 0.6761 0.7106 0.1809 0.3209 0.0247 -0.4139 0.0905 0.4609 -0.3528 0.5128 j INUL(j) 1 F 2 F 3 F 4 T slicot-5.0+20101122/examples77/MB02QD.dat000077500000000000000000000002761201767322700171310ustar00rootroot00000000000000 MB02QD EXAMPLE PROGRAM DATA 4 3 2 2.3D-16 0.0 L N 2.0 2.0 -3.0 3.0 3.0 -1.0 4.0 4.0 -5.0 -1.0 -1.0 -2.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/MB02QD.res000077500000000000000000000003341201767322700171450ustar00rootroot00000000000000 MB02QD EXAMPLE PROGRAM RESULTS The effective rank of A = 2 Estimates of the singular values SVAL = 7.8659 2.6698 0.0000 The least squares solution is -0.0034 -0.1054 -0.0034 -0.1054 -0.0816 -0.1973 slicot-5.0+20101122/examples77/MB02SD.dat000077500000000000000000000005031201767322700171240ustar00rootroot00000000000000 MB02SD EXAMPLE PROGRAM DATA 5 4 O N 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 0. 3. 1. 5. 1. 0. 0. 2. 0. -4. 0. 0. 0. 1. 4. 5. 5. 1. 5. -2. 1. 3. 1. 0. 0. 4. 5. 2. 1. 1. 3. -1. 3. 3. 1. slicot-5.0+20101122/examples77/MB02SD.res000077500000000000000000000004401201767322700171450ustar00rootroot00000000000000 MB02SD EXAMPLE PROGRAM RESULTS The solution matrix is 0.0435 1.2029 1.6377 1.1014 1.0870 -4.4275 -5.5580 -2.9638 0.9130 0.7609 -0.1087 0.6304 -0.8261 2.4783 4.2174 2.7391 -0.0435 0.1304 -0.3043 -0.4348 Reciprocal condition number = 0.1554D-01 slicot-5.0+20101122/examples77/MB02VD.dat000077500000000000000000000004061201767322700171310ustar00rootroot00000000000000 MB02VD EXAMPLE PROGRAM DATA 5 4 N 1. 2. 6. 3. -2. -1. -1. 0. 2. 3. 1. 5. 1. -1. 2. 0. 0. 0. 0. 1. 5. 5. 1. 5. -2. 1. 3. 1. 0. 0. 4. 5. 2. 1. 1. 3. slicot-5.0+20101122/examples77/MB02VD.res000077500000000000000000000003631201767322700171540ustar00rootroot00000000000000 MB02VD EXAMPLE PROGRAM RESULTS The solution matrix is -0.0690 0.3333 0.2414 0.2529 -0.1724 -1.6667 1.1034 -0.3678 0.9655 0.6667 -0.3793 -0.8736 0.3448 1.6667 0.7931 1.4023 -0.2069 0.0000 0.7241 0.7586 slicot-5.0+20101122/examples77/MB03BD.dat000077500000000000000000000003721201767322700171100ustar00rootroot00000000000000MB03BD EXAMPLE PROGRAM DATA S C I 3 3 2 1 3 -1 1 -1 2.0 0.0 1.0 0.0 -2.0 -1.0 0.0 0.0 3.0 1.0 2.0 0.0 4.0 -1.0 3.0 0.0 3.0 1.0 1.0 0.0 1.0 0.0 4.0 -1.0 0.0 0.0 -2.0 slicot-5.0+20101122/examples77/MB03BD.res000077500000000000000000000015711201767322700171330ustar00rootroot00000000000000MB03BD EXAMPLE PROGRAM RESULTS The matrix A on exit is The factor 1 is -2.0599 0.6251 -0.5959 0.0000 2.9774 -1.1479 0.0000 0.0000 1.9566 The factor 2 is -3.9705 -0.3216 2.9819 -2.0077 2.2246 -1.9116 0.0000 0.0000 1.8990 The factor 3 is 2.6946 -2.9508 0.5659 0.0000 1.3385 0.0097 0.0000 0.0000 -2.2180 The matrix Q on exit is The factor 1 is -0.3331 -0.7427 -0.5809 0.9394 -0.2084 -0.2723 0.0812 -0.6364 0.7671 The factor 2 is 0.2841 -0.7723 -0.5683 0.9515 0.1539 0.2664 -0.1183 -0.6164 0.7785 The factor 3 is -0.7883 -0.5567 0.2619 0.6055 -0.6263 0.4911 -0.1094 0.5457 0.8308 The vector ALPHAR is 0.3230 0.6459 -0.8752 The vector ALPHAI is 0.5694 -1.1387 0.0000 The vector BETA is 1.0000 1.0000 1.0000 The vector SCAL is 0 -1 -1 slicot-5.0+20101122/examples77/MB03KD.dat000077500000000000000000000003761201767322700171250ustar00rootroot00000000000000MB03KD EXAMPLE PROGRAM DATA S C I N 3 3 2 1 3 -1 1 -1 2.0 0.0 1.0 0.0 -2.0 -1.0 0.0 0.0 3.0 1.0 2.0 0.0 4.0 -1.0 3.0 0.0 3.0 1.0 1.0 0.0 1.0 0.0 4.0 -1.0 0.0 0.0 -2.0 slicot-5.0+20101122/examples77/MB03KD.res000077500000000000000000000015601201767322700171420ustar00rootroot00000000000000MB03KD EXAMPLE PROGRAM RESULTS The vector ALPHAR is 0.3230 0.6459 -0.8752 The vector ALPHAI is 0.5694 -1.1387 0.0000 The vector BETA is 1.0000 1.0000 1.0000 The vector SCAL is 0 -1 -1 The matrix A on exit is The factor 1 is 2.5997 -0.1320 -1.6847 0.0000 1.9725 -0.1377 0.0000 0.0000 2.3402 The factor 2 is -2.0990 -1.1625 2.5251 0.0000 3.1870 -0.3812 0.0000 -3.6737 -2.2513 The factor 3 is 1.8451 0.9652 -1.2422 0.0000 1.3270 2.1642 0.0000 0.0000 -3.2674 The matrix Q on exit is The factor 1 is 0.1648 -0.3771 -0.9114 -0.0376 -0.9258 0.3762 0.9856 0.0277 0.1668 The factor 2 is 0.5907 0.3477 0.7281 -0.7640 0.5311 0.3662 -0.2594 -0.7726 0.5794 The factor 3 is 0.6685 -0.7431 0.0303 0.4239 0.3472 -0.8365 0.6111 0.5720 0.5471 slicot-5.0+20101122/examples77/MB03LD.dat000077500000000000000000000013051201767322700171170ustar00rootroot00000000000000MB03LD EXAMPLE PROGRAM DATA C Q 8 3.1472 1.3236 4.5751 4.5717 4.0579 -4.0246 4.6489 -0.1462 -3.7301 -2.2150 -3.4239 3.0028 4.1338 0.4688 4.7059 -3.5811 0.0000 0.0000 -1.5510 -4.5974 -2.5127 3.5071 0.0000 0.0000 1.5961 2.4490 -3.1428 2.5648 0.0000 0.0000 -0.0596 3.0340 2.4892 -1.1604 0.0000 0.0000 0.6882 -3.3782 -3.3435 1.8921 -0.3061 2.9428 1.0198 2.4815 -4.8810 -1.8878 -2.3703 -0.4946 -1.6288 0.2853 1.5408 -4.1618 -2.4013 -2.7102 0.3834 -3.9335 3.1730 -3.1815 -2.3620 4.9613 4.6190 3.6869 3.6929 0.7970 0.4986 -4.9537 -4.1556 3.5303 1.2206 -1.4905 0.1325 -1.0022 slicot-5.0+20101122/examples77/MB03LD.res000077500000000000000000000022311201767322700171370ustar00rootroot00000000000000MB03LD EXAMPLE PROGRAM RESULTS The matrix A on exit is -4.7460 4.1855 3.2696 -0.2244 0.0000 6.4157 2.8287 1.4553 0.0000 0.0000 7.4626 1.5726 0.0000 0.0000 0.0000 8.8702 The matrix DE on exit is -5.4562 2.5550 -1.3137 -6.3615 -0.8940 -2.1348 -7.9616 0.0000 1.0704 -0.0659 4.9694 1.1516 4.8504 0.0000 -0.6922 -2.2744 3.4912 0.5046 4.4394 0.0000 The matrix C1 on exit is 6.9525 -4.9881 2.3661 4.2188 0.0000 8.5009 0.7182 5.5533 0.0000 0.0000 -4.6650 -2.8177 0.0000 0.0000 0.0000 1.5124 The matrix V on exit is 0.9136 4.1106 -0.0079 3.5789 -1.1553 -1.4785 -1.5155 -0.8018 -2.2167 4.8029 1.3645 2.5202 -1.0994 -0.6144 0.3970 2.0730 The vector ALPHAR is 0.8314 -1.1758 0.8131 0.0000 The vector ALPHAI is 0.4372 0.6183 0.0000 0.9164 The vector BETA is 0.7071 1.0000 1.4142 2.8284 The matrix Q is -0.1065 0.5967 -0.2995 0.2424 -0.1606 0.6881 0.4045 -0.3593 -0.1505 0.4501 -0.0188 0.0691 0.2261 -0.0852 -0.0435 0.0830 0.5528 0.3520 0.0895 -0.2247 -0.4917 -0.7055 -0.3540 0.2045 slicot-5.0+20101122/examples77/MB03MD.dat000077500000000000000000000001621201767322700171200ustar00rootroot00000000000000 MB03MD EXAMPLE PROGRAM DATA 5 -3.0 3 0.0 0.0 1.0 2.0 3.0 4.0 5.0 2.0 3.0 4.0 5.0 slicot-5.0+20101122/examples77/MB03MD.res000077500000000000000000000004521201767322700171430ustar00rootroot00000000000000 MB03MD EXAMPLE PROGRAM RESULTS The Bidiagonal Matrix J is (1,1) = 1.0000 (1,2) = 2.0000 (2,2) = 2.0000 (2,3) = 3.0000 (3,3) = 3.0000 (3,4) = 4.0000 (4,4) = 4.0000 (4,5) = 5.0000 (5,5) = 5.0000 The computed value of THETA is 4.7500 J has 3 singular values < = THETA slicot-5.0+20101122/examples77/MB03ND.dat000077500000000000000000000001531201767322700171210ustar00rootroot00000000000000 MB03ND EXAMPLE PROGRAM DATA 5 5.0 0.0 0.0 1.0 2.0 3.0 4.0 5.0 2.0 3.0 4.0 5.0 slicot-5.0+20101122/examples77/MB03ND.res000077500000000000000000000004031201767322700171400ustar00rootroot00000000000000 MB03ND EXAMPLE PROGRAM RESULTS The Bidiagonal Matrix J is (1,1) = 1.0000 (1,2) = 2.0000 (2,2) = 2.0000 (2,3) = 3.0000 (3,3) = 3.0000 (3,4) = 4.0000 (4,4) = 4.0000 (4,5) = 5.0000 (5,5) = 5.0000 J has 3 singular values < = 5.0000 slicot-5.0+20101122/examples77/MB03OD.dat000077500000000000000000000003621201767322700171240ustar00rootroot00000000000000 MB03OD EXAMPLE PROGRAM DATA 6 5 Q 5.D-16 0.0 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 5. 5. 1. 5. 1. -2. -1. -1. 0. -2. 4. 8. 4. 20. 4. -2. -1. -1. 0. -2. slicot-5.0+20101122/examples77/MB03OD.res000077500000000000000000000002311201767322700171400ustar00rootroot00000000000000 MB03OD EXAMPLE PROGRAM RESULTS The rank is 4 Column permutations are 4 3 1 5 2 SVAL vector is 22.7257 1.4330 0.0000 slicot-5.0+20101122/examples77/MB03PD.dat000077500000000000000000000003621201767322700171250ustar00rootroot00000000000000 MB03PD EXAMPLE PROGRAM DATA 6 5 R 5.D-16 0.0 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 5. 5. 1. 5. 1. -2. -1. -1. 0. -2. 4. 8. 4. 20. 4. -2. -1. -1. 0. -2. slicot-5.0+20101122/examples77/MB03PD.res000077500000000000000000000002331201767322700171430ustar00rootroot00000000000000 MB03PD EXAMPLE PROGRAM RESULTS The rank is 4 Row permutations are 2 4 6 3 1 5 SVAL vector is 24.5744 0.9580 0.0000 slicot-5.0+20101122/examples77/MB03QD.dat000077500000000000000000000002601201767322700171230ustar00rootroot00000000000000 MB03QD EXAMPLE PROGRAM DATA 4 1 4 0.0 C S U -1.0 37.0 -12.0 -12.0 -1.0 -10.0 0.0 4.0 2.0 -4.0 7.0 -6.0 2.0 2.0 7.0 -9.0 slicot-5.0+20101122/examples77/MB03QD.res000077500000000000000000000007771201767322700171610ustar00rootroot00000000000000 MB03QD EXAMPLE PROGRAM RESULTS The number of eigenvalues in the domain is 4 The ordered Schur form matrix is -3.1300 -26.5066 27.2262 -16.2009 0.9070 -3.1300 13.6254 8.9206 0.0000 0.0000 -3.3700 0.3419 0.0000 0.0000 -1.7879 -3.3700 The transformation matrix is 0.9611 0.1784 0.2064 -0.0440 -0.1468 -0.2704 0.8116 -0.4965 -0.2224 0.7675 0.4555 0.3924 -0.0733 0.5531 -0.3018 -0.7730 slicot-5.0+20101122/examples77/MB03RD.dat000077500000000000000000000007361201767322700171340ustar00rootroot00000000000000 MB03RD EXAMPLE PROGRAM DATA 8 1.D03 1.D-2 U S 1. -1. 1. 2. 3. 1. 2. 3. 1. 1. 3. 4. 2. 3. 4. 2. 0. 0. 1. -1. 1. 5. 4. 1. 0. 0. 0. 1. -1. 3. 1. 2. 0. 0. 0. 1. 1. 2. 3. -1. 0. 0. 0. 0. 0. 1. 5. 1. 0. 0. 0. 0. 0. 0. 0.99999999 -0.99999999 0. 0. 0. 0. 0. 0. 0.99999999 0.99999999 slicot-5.0+20101122/examples77/MB03RD.res000077500000000000000000000026621201767322700171550ustar00rootroot00000000000000 MB03RD EXAMPLE PROGRAM RESULTS The number of blocks is 2 The orders of blocks are 6 2 The block-diagonal matrix is 1.0000 -1.0000 -1.2247 -0.7071 -3.4186 1.4577 0.0000 0.0000 1.0000 1.0000 0.0000 1.4142 -5.1390 3.1637 0.0000 0.0000 0.0000 0.0000 1.0000 -1.7321 -0.0016 2.0701 0.0000 0.0000 0.0000 0.0000 0.5774 1.0000 0.7516 1.1379 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 -5.8606 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1706 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 -0.8850 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 The transformation matrix is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.9045 0.1957 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -0.3015 0.9755 0.0000 0.0000 0.8165 0.0000 -0.5768 -0.0156 -0.3015 0.0148 0.0000 0.0000 -0.4082 0.7071 -0.5768 -0.0156 0.0000 -0.0534 0.0000 0.0000 -0.4082 -0.7071 -0.5768 -0.0156 0.0000 0.0801 0.0000 0.0000 0.0000 0.0000 -0.0276 0.9805 0.0000 0.0267 0.0000 0.0000 0.0000 0.0000 0.0332 -0.0066 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0011 0.1948 0.0000 0.0000 slicot-5.0+20101122/examples77/MB03SD.dat000077500000000000000000000002171201767322700171270ustar00rootroot00000000000000MB03SD EXAMPLE PROGRAM DATA 3 S 2.0 0.0 0.0 0.0 1.0 2.0 0.0 -1.0 3.0 1.0 0.0 0.0 2.0 3.0 4.0 -2.0 0.0 0.0 0.0 0.0 0.0 slicot-5.0+20101122/examples77/MB03SD.res000077500000000000000000000003101201767322700171420ustar00rootroot00000000000000 MB03SD EXAMPLE PROGRAM RESULTS The eigenvalues are 2.0000 + ( 1.0000)i 2.0000 + ( -1.0000)i 1.4142 + ( 0.0000)i -1.4142 + ( 0.0000)i -2.0000 + ( 1.0000)i -2.0000 + ( -1.0000)i slicot-5.0+20101122/examples77/MB03TD.dat000077500000000000000000000016011201767322700171260ustar00rootroot00000000000000MB03TD EXAMPLE PROGRAM DATA 5 S U .F. .T. .T. .F. .F. .F. .T. .T. .F. .F. 0.9501 0.7621 0.6154 0.4057 0.0579 0 0.4565 0.7919 0.9355 0.3529 0 -0.6822 0.4565 0.9169 0.8132 0 0 0 0.4103 0.0099 0 0 0 0 0.1389 0 -0.1834 -0.1851 0.5659 0.3040 0 0 0.4011 -0.9122 0.2435 0 0 0 0.4786 -0.2432 0 0 0 0 -0.5272 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 slicot-5.0+20101122/examples77/MB03TD.res000077500000000000000000000032311201767322700171500ustar00rootroot00000000000000MB03TD EXAMPLE PROGRAM RESULTS The orthogonal symplectic factor U is 0.0407 0.4847 0.8737 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1245 -0.3866 0.2087 0.4509 -0.1047 0.3229 0.1248 -0.0843 0.1967 0.6415 -0.0933 0.4089 -0.2225 -0.4085 0.0709 -0.2171 0.2156 -0.1095 0.4348 0.5551 -0.1059 -0.5250 0.2962 -0.0295 0.2207 -0.6789 0.1133 -0.0312 0.2979 -0.1112 0.3937 0.3071 -0.1887 0.5332 -0.4351 -0.4423 0.0600 -0.0127 0.1679 -0.1179 0.0000 0.0000 0.0000 0.0000 0.0000 0.0407 0.4847 0.8737 0.0000 0.0000 -0.3229 -0.1248 0.0843 -0.1967 -0.6415 0.1245 -0.3866 0.2087 0.4509 -0.1047 0.2171 -0.2156 0.1095 -0.4348 -0.5551 -0.0933 0.4089 -0.2225 -0.4085 0.0709 0.6789 -0.1133 0.0312 -0.2979 0.1112 -0.1059 -0.5250 0.2962 -0.0295 0.2207 0.4423 -0.0600 0.0127 -0.1679 0.1179 0.3937 0.3071 -0.1887 0.5332 -0.4351 Orthogonality of U: || U'*U - I ||_F = .21E-14 The matrix A in reordered Schur canonical form is 0.4565 -0.4554 0.2756 -0.8651 -1.2050 1.1863 0.4565 0.2186 -0.0233 0.8293 0.0000 0.0000 0.9501 0.0625 -0.0064 0.0000 0.0000 0.0000 0.4103 0.5597 0.0000 0.0000 0.0000 0.0000 0.1389 The matrix G is 0.0000 0.3298 -0.0292 -0.1571 0.1751 -0.3298 0.0000 -0.0633 -0.2951 0.2396 0.0292 0.0633 0.0000 0.9567 0.7485 0.1571 0.2951 -0.9567 0.0000 0.2960 -0.1751 -0.2396 -0.7485 -0.2960 0.0000 slicot-5.0+20101122/examples77/MB03UD.dat000077500000000000000000000002231201767322700171260ustar00rootroot00000000000000 MB03UD EXAMPLE PROGRAM DATA 4 V V -1.0 37.0 -12.0 -12.0 0.0 -10.0 0.0 4.0 0.0 0.0 7.0 -6.0 0.0 0.0 0.0 -9.0 slicot-5.0+20101122/examples77/MB03UD.res000077500000000000000000000010541201767322700171520ustar00rootroot00000000000000 MB03UD EXAMPLE PROGRAM RESULTS Singular values are 42.0909 11.7764 5.4420 0.2336 The transpose of the right singular vectors matrix is 0.0230 -0.9084 0.2759 0.3132 0.0075 -0.1272 0.5312 -0.8376 0.0092 0.3978 0.8009 0.4476 0.9997 0.0182 -0.0177 -0.0050 The left singular vectors matrix is -0.9671 -0.0882 -0.0501 -0.2335 0.2456 -0.1765 -0.4020 -0.8643 0.0012 0.7425 0.5367 -0.4008 -0.0670 0.6401 -0.7402 0.1945 slicot-5.0+20101122/examples77/MB03VD.dat000077500000000000000000000002501201767322700171270ustar00rootroot00000000000000MB03VD EXAMPLE PROGRAM DATA 4 2 1 4 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. slicot-5.0+20101122/examples77/MB03VD.res000077500000000000000000000012631201767322700171550ustar00rootroot00000000000000 MB03VD EXAMPLE PROGRAM RESULTS Reduced matrices K = 1 -2.3926 2.7042 -0.9598 -1.2335 4.1417 -1.7046 1.3001 -1.3120 0.0000 -1.6247 -0.2534 1.6453 0.0000 0.0000 -0.0169 -0.4451 K = 2 -2.5495 2.3402 4.7021 0.2329 0.0000 1.9725 -0.2483 -2.3493 0.0000 0.0000 -0.6290 -0.5975 0.0000 0.0000 0.0000 -0.4426 Transformation matrices K = 1 1.0000 0.0000 0.0000 0.0000 0.0000 -0.7103 0.5504 -0.4388 0.0000 -0.4735 -0.8349 -0.2807 0.0000 -0.5209 0.0084 0.8536 K = 2 -0.5883 0.2947 0.7528 -0.0145 -0.3922 -0.8070 0.0009 -0.4415 -0.5883 0.4292 -0.6329 -0.2630 -0.3922 -0.2788 -0.1809 0.8577 NORM (Q'*A*Q - Aout) = 2.93760D-15 slicot-5.0+20101122/examples77/MB03WD.dat000077500000000000000000000002601201767322700171310ustar00rootroot00000000000000MB03WD EXAMPLE PROGRAM DATA 4 2 1 4 1 4 S V 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. 1.5 -.7 3.5 -.7 1. 0. 2. 3. 1.5 -.7 2.5 -.3 1. 0. 2. 1. slicot-5.0+20101122/examples77/MB03WD.res000077500000000000000000000015771201767322700171660ustar00rootroot00000000000000 MB03WD EXAMPLE PROGRAM RESULTS Computed eigenvalues ( 6.449861 , 7.817717 ) ( 6.449861 , -7.817717 ) ( 0.091315 , 0.000000 ) ( 0.208964 , 0.000000 ) Reduced matrices K = 1 2.2112 4.3718 -2.3362 0.8907 -0.9179 2.7688 -0.6570 -2.2426 0.0000 0.0000 0.3022 0.1932 0.0000 0.0000 0.0000 -0.4571 K = 2 2.9169 3.4539 2.2016 1.2367 0.0000 3.4745 1.0209 -2.0720 0.0000 0.0000 0.3022 -0.1932 0.0000 0.0000 0.0000 -0.4571 Transformation matrices K = 1 0.3493 0.6751 -0.6490 0.0327 0.7483 -0.4863 -0.1249 -0.4336 0.2939 0.5504 0.7148 -0.3158 0.4813 -0.0700 0.2286 0.8433 K = 2 0.2372 0.7221 0.6490 0.0327 0.8163 -0.3608 0.1249 -0.4336 0.2025 0.5902 -0.7148 -0.3158 0.4863 0.0076 -0.2286 0.8433 NORM (Z'*A*Z - Aout) = 7.10254D-15 slicot-5.0+20101122/examples77/MB03XD.dat000077500000000000000000000026201201767322700171340ustar00rootroot00000000000000MB03XD EXAMPLE PROGRAM DATA 5 N G U V 3.7588548168313685e-001 9.1995720669587144e-001 1.9389317998466821e-001 5.4878212553858818e-001 6.2731478808399666e-001 9.8764628987858052e-003 8.4472150190817474e-001 9.0481233416635698e-001 9.3158335257969060e-001 6.9908013774533750e-001 4.1985780631021896e-001 3.6775288246828447e-001 5.6920574967174709e-001 3.3519743020639464e-001 3.9718395379261456e-001 7.5366962581358721e-001 6.2080133182114383e-001 6.3178992922175603e-001 6.5553105501201447e-001 4.1362889533818031e-001 7.9387177473231862e-001 7.3127726446634478e-001 2.3441295540825388e-001 3.9190420688900335e-001 6.5521294635567051e-001 1.8015558545989005e-001 4.1879254941592853e-001 2.7203760737317784e-001 2.8147214090719214e-001 1.7731904815580199e-001 3.4718672159409536e-001 2.7989257702981651e-001 3.5042861661866559e-001 2.5565572408444881e-001 4.3977750345993827e-001 2.8855026075967616e-001 2.1496327083014577e-001 1.7341073886969158e-001 3.9913855375815932e-001 4.0151317011596516e-001 4.0331887464437133e-001 2.6723538667317948e-001 3.7110275606849241e-001 3.7832182695699140e-001 3.3812641389556752e-001 8.4360396433341395e-002 4.3672540277019672e-001 7.0022228267365608e-002 3.8210230186291916e-001 1.9548216143135175e-001 2.9055490787446736e-001 4.7670819669167425e-001 1.4636498713707141e-001 2.7670398401519275e-001 2.9431082727794898e-002 slicot-5.0+20101122/examples77/MB03XD.res000077500000000000000000000137241201767322700171640ustar00rootroot00000000000000 MB03XD EXAMPLE PROGRAM RESULTS The stable eigenvalues are i WR(i) WI(i) 1 -3.1941 0.0000 2 -0.1350 0.3179 3 -0.1350 -0.3179 4 -0.0595 0.2793 5 -0.0595 -0.2793 The matrix S of the reduced matrix is -3.1844761777714705 0.1612357243439340 -0.0628592203751098 0.2449004200921959 0.1974400149992626 0.0000000000000000 -0.1510667773167789 0.4260444411622883 -0.1775026035208666 0.3447278421198391 0.0000000000000000 -0.1386140422054271 -0.3006779624777444 0.2944143257134114 0.3456440339120371 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.2710128384740574 0.0933189808067095 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.4844146572359634 0.2004347508746742 The matrix T of the reduced matrix is 3.2038208121776348 0.1805955192510640 0.2466389119377566 -0.2539149302433392 -0.0359238844381156 0.0000000000000000 -0.7196686433290816 0.0000000000000000 0.2428659121580376 -0.0594190100670782 0.0000000000000000 0.0000000000000000 -0.1891741194498114 -0.3309578443491296 -0.0303520731950499 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.4361574461961528 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.1530894573304223 The matrix G of the reduced matrix is -0.0370982242678457 0.0917788436945731 -0.0560402416315241 0.1345152517579191 0.0256668227276677 0.0652183678916931 -0.0700457231988316 0.0350041175858833 -0.2233868768749274 -0.1171980260782826 -0.0626428681377085 0.2327575351902817 -0.1251515732208144 -0.0177816046663199 0.3696921118421150 0.0746042309265577 -0.0828007611045206 0.0217427473546019 -0.1157775118548848 -0.3161183681200569 0.1374372236164831 0.1002727885506978 0.4021556774753979 -0.0431072263235601 0.1067394572547818 Residual: || H*V - U*R ||_F = .46E-14 The orthogonal symplectic factor U is 0.3806883009357248 -0.0347810363019652 -0.5014665065895682 0.5389691288472414 0.2685446895251484 -0.1795922007470743 0.1908329820840928 0.0868799433942036 0.3114741142062438 -0.2579907627915120 0.4642712665555325 -0.5942766860716391 0.4781179763952650 0.2334370556238112 0.0166790369048892 -0.2447897730222851 -0.1028403314750051 -0.1157840914576275 -0.1873268885694416 0.1700708002861561 0.2772789197782786 -0.0130145392695875 -0.2123817030594140 -0.2550292626960040 -0.5049268366774471 -0.2243335325285328 0.3180998613802515 0.3315380214794929 0.1977859924739848 0.5072476567310018 0.4209268575081796 0.1499593172661209 -0.1925590746592153 -0.5472292877802430 0.4543329704184027 -0.2128397588651423 -0.2740560593051887 0.1941418870268840 -0.3096684962457376 -0.0581576193198811 0.3969669479129447 0.6321903535930841 0.3329156356041933 0.0163533225344418 -0.2638879466190077 -0.2002027567371932 -0.0040094115506849 -0.3979373387545270 0.1520881534833964 -0.2010804514091296 0.1795922007470743 -0.1908329820840928 -0.0868799433942036 -0.3114741142062438 0.2579907627915120 0.3806883009357248 -0.0347810363019652 -0.5014665065895682 0.5389691288472414 0.2685446895251484 0.2447897730222851 0.1028403314750051 0.1157840914576275 0.1873268885694416 -0.1700708002861561 0.4642712665555325 -0.5942766860716391 0.4781179763952650 0.2334370556238112 0.0166790369048892 0.2243335325285328 -0.3180998613802515 -0.3315380214794929 -0.1977859924739848 -0.5072476567310018 0.2772789197782786 -0.0130145392695875 -0.2123817030594140 -0.2550292626960040 -0.5049268366774471 0.2128397588651423 0.2740560593051887 -0.1941418870268840 0.3096684962457376 0.0581576193198811 0.4209268575081796 0.1499593172661209 -0.1925590746592153 -0.5472292877802430 0.4543329704184027 0.2002027567371932 0.0040094115506849 0.3979373387545270 -0.1520881534833964 0.2010804514091296 0.3969669479129447 0.6321903535930841 0.3329156356041933 0.0163533225344418 -0.2638879466190077 Orthogonality of U: || U^T U - I ||_F = .44E-14 The orthogonal symplectic factor V is 0.4447147692018326 -0.6830166755147431 -0.0002576861753472 0.5781954611783312 -0.0375091627893765 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.5121756358795811 0.0297197140254803 0.4332229148788684 -0.3240527006890551 0.5330850295256574 0.0299719306696789 -0.2322624725320721 -0.0280846899680319 -0.3044255686880006 -0.1077641482535489 0.3664711365265599 0.3288511296455133 0.0588396016404453 0.1134221597062261 0.1047567336850063 -0.0069083614679702 0.3351358347080118 -0.4922707032978923 0.4293545450291748 0.4372821269061881 0.4535357098437906 0.1062866148880800 -0.3964092656837794 -0.2211800890450660 0.0350667323996171 0.0167847133528844 0.2843629278945297 0.5958979805231186 0.3097336757510848 -0.2086733033047147 0.4450432900616095 0.2950206358263791 -0.1617837757183793 -0.0376369332204956 -0.6746752660482674 0.0248567764822071 -0.2810759958040470 -0.1653113624869855 -0.3528780198620398 -0.0254898556119232 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.4447147692018326 -0.6830166755147431 -0.0002576861753472 0.5781954611783312 -0.0375091627893765 -0.0299719306696789 0.2322624725320721 0.0280846899680319 0.3044255686880006 0.1077641482535489 0.5121756358795811 0.0297197140254803 0.4332229148788684 -0.3240527006890551 0.5330850295256574 0.0069083614679702 -0.3351358347080118 0.4922707032978923 -0.4293545450291748 -0.4372821269061881 0.3664711365265599 0.3288511296455133 0.0588396016404453 0.1134221597062261 0.1047567336850063 -0.0167847133528844 -0.2843629278945297 -0.5958979805231186 -0.3097336757510848 0.2086733033047147 0.4535357098437906 0.1062866148880800 -0.3964092656837794 -0.2211800890450660 0.0350667323996171 -0.0248567764822071 0.2810759958040470 0.1653113624869855 0.3528780198620398 0.0254898556119232 0.4450432900616095 0.2950206358263791 -0.1617837757183793 -0.0376369332204956 -0.6746752660482674 Orthogonality of V: || V^T V - I ||_F = .28E-14 slicot-5.0+20101122/examples77/MB03XP.dat000077500000000000000000000025061201767322700171530ustar00rootroot00000000000000MB03XP EXAMPLE PROGRAM DATA 8 1 8 0.9708 -1.1156 -0.0884 -0.2684 0.2152 0.0402 0.0333 0.5141 -1.6142 2.8635 1.0420 -0.2295 -0.3560 0.4885 0.1026 -0.0164 0 1.1138 0.3509 -0.0963 0.0875 0.2158 0.2444 -0.2838 0 0 -0.5975 0.1021 -0.1026 -0.0062 -0.2646 -0.0745 0 0 0 0.6181 0.1986 0.3612 -0.1750 0.3332 0 0 0 0 -0.7387 -0.5201 0.0713 0.0501 0 0 0 0 0 -0.2677 -0.4918 -0.2838 0 0 0 0 0 0 0.3011 0.3389 0.9084 0.1739 0.5915 0.8729 0.8188 0.1911 0.4122 0.5527 0 0.1708 0.1197 0.2379 0.4302 0.4225 0.9016 0.4001 0 0 0.0381 0.6458 0.8903 0.8560 0.0056 0.1988 0 0 0 0.9669 0.7349 0.4902 0.2974 0.6252 0 0 0 0 0.6873 0.8159 0.0492 0.7334 0 0 0 0 0 0.4608 0.6932 0.3759 0 0 0 0 0 0 0.6501 0.0099 0 0 0 0 0 0 0 0.4199 slicot-5.0+20101122/examples77/MB03XP.res000077500000000000000000000061721201767322700171770ustar00rootroot00000000000000 MB03XP EXAMPLE PROGRAM RESULTS The reduced matrix A is -0.6290 -0.1397 -0.0509 0.1603 -0.3248 0.2381 0.0694 0.0103 1.5112 -3.4273 -0.4485 -0.4357 -0.3456 0.4619 0.5998 0.5654 0.0000 0.0000 0.0547 -0.4360 0.1714 -0.2103 -0.0900 -0.4011 0.0000 0.0000 0.6623 0.2038 0.2796 -0.2629 0.3837 0.2382 0.0000 0.0000 0.0000 0.0000 -0.6315 0.2071 -0.0174 -0.3538 0.0000 0.0000 0.0000 0.0000 0.0000 -0.5850 -0.1813 0.2435 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.7884 0.1535 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.2832 Residual: || A*Z - Q*S ||_F = .46E-14 The reduced matrix B is -0.9231 0.0000 -0.9834 0.1805 0.4428 0.3655 -0.4300 0.8498 0.0000 -0.1837 -0.1873 0.0681 0.8412 -0.0556 0.0538 0.6113 0.0000 0.0000 -1.8997 0.0000 0.5651 -0.2785 0.2882 1.0458 0.0000 0.0000 0.0000 -0.2602 0.3527 -0.0020 -0.3396 0.2739 0.0000 0.0000 0.0000 0.0000 0.8521 -0.0164 0.2115 0.5446 0.0000 0.0000 0.0000 0.0000 0.0000 0.0283 -0.5128 0.0153 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.4153 0.4587 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.5894 Residual: || B*Q - Z*T ||_F = .39E-14 The orthogonal factor Q is -0.5333 0.3661 -0.1179 0.0264 0.0026 0.7527 0.0018 0.0189 0.0583 -0.8833 -0.0666 -0.0007 0.0017 0.4603 0.0050 0.0092 -0.8414 -0.2927 0.0347 0.0452 -0.0005 -0.4498 -0.0269 0.0001 0.0077 0.0046 -0.5687 -0.4810 0.0227 -0.0708 -0.6500 0.1312 0.0598 0.0059 -0.6128 0.7656 0.1348 -0.0863 0.0038 0.0954 -0.0242 -0.0016 -0.4295 -0.4163 0.3871 -0.0709 0.6964 -0.0417 0.0027 0.0001 0.3109 0.0620 0.8615 0.0378 -0.2267 0.3231 0.0012 0.0000 0.0188 -0.0514 -0.2987 -0.0172 0.2010 0.9312 Orthogonality of Q: || Q'*Q - I ||_F = .52E-14 The orthogonal factor Z is 0.9957 -0.0786 0.0397 -0.0032 0.0006 0.0227 0.0104 0.0123 0.0764 0.9956 0.0200 0.0073 -0.0009 0.0389 0.0263 0.0193 -0.0062 0.0235 0.6714 -0.0229 0.0271 -0.4461 -0.5354 -0.2486 -0.0445 -0.0437 0.6098 0.4197 -0.0656 0.6125 0.1248 0.2302 -0.0242 -0.0148 0.4049 -0.6041 0.2808 -0.1328 0.5972 0.1311 0.0096 0.0037 -0.0183 0.6539 0.5114 -0.4136 0.3620 -0.0913 -0.0019 -0.0004 -0.1055 -0.1544 0.7891 0.2944 -0.4436 0.2426 -0.0005 0.0000 -0.0039 0.0826 -0.1786 -0.3853 -0.1119 0.8946 Orthogonality of Z: || Z'*Z - I ||_F = .55E-14 ALPHAR ALPHAI BETA 0.4723 0.1464 1.2811 0.4723 -0.1464 1.2811 -0.0295 0.1416 2.6621 -0.0295 -0.1416 2.6621 -0.6315 0.0000 0.8521 -0.5850 0.0000 0.0283 -0.7884 0.0000 0.4153 0.2832 0.0000 0.5894 slicot-5.0+20101122/examples77/MB03ZD.dat000077500000000000000000000067721201767322700171520ustar00rootroot00000000000000MB03ZD EXAMPLE PROGRAM DATA 5 1 A L B N B -3.1844761777714732 0.1612357243439331 -0.0628592203751138 0.2449004200921981 0.1974400149992579 0.0000000000000000 -0.1510667773167784 0.4260444411622838 -0.1775026035208615 0.3447278421198472 0.0000000000000000 -0.1386140422054264 -0.3006779624777515 0.2944143257134196 0.3456440339120323 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.2710128384740570 0.0933189808067138 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.4844146572359603 0.2004347508746697 3.2038208121776366 0.1805955192510651 0.2466389119377561 -0.2539149302433368 -0.0359238844381195 0.0000000000000000 -0.7196686433290816 0.0000000000000000 0.2428659121580384 -0.0594190100670832 0.0000000000000000 0.0000000000000000 -0.1891741194498107 -0.3309578443491266 -0.0303520731950515 0.0000000000000000 0.0000000000000000 0.0000000000000000 -0.4361574461961550 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.1530894573304220 -0.0370982242678464 0.0917788436945724 -0.0560402416315252 0.1345152517579192 0.0256668227276700 0.0652183678916931 -0.0700457231988297 0.0350041175858839 -0.2233868768749268 -0.1171980260782843 -0.0626428681377119 0.2327575351902772 -0.1251515732208170 -0.0177816046663201 0.3696921118421182 0.0746042309265599 -0.0828007611045140 0.0217427473546043 -0.1157775118548851 -0.3161183681200527 0.1374372236164812 0.1002727885506992 0.4021556774753973 -0.0431072263235579 0.1067394572547867 0.3806883009357247 -0.0347810363019649 -0.5014665065895758 0.5389691288472394 0.2685446895251367 0.4642712665555326 -0.5942766860716395 0.4781179763952615 0.2334370556238151 0.0166790369048933 0.2772789197782788 -0.0130145392695876 -0.2123817030594055 -0.2550292626960107 -0.5049268366774490 0.4209268575081796 0.1499593172661228 -0.1925590746592156 -0.5472292877802402 0.4543329704184054 0.3969669479129449 0.6321903535930828 0.3329156356041961 0.0163533225344433 -0.2638879466190024 -0.1795922007470742 0.1908329820840911 0.0868799433942070 0.3114741142062388 -0.2579907627915167 -0.2447897730222852 -0.1028403314750045 -0.1157840914576285 -0.1873268885694406 0.1700708002861580 -0.2243335325285328 0.3180998613802520 0.3315380214794822 0.1977859924739963 0.5072476567310013 -0.2128397588651423 -0.2740560593051881 0.1941418870268881 -0.3096684962457369 -0.0581576193198714 -0.2002027567371932 -0.0040094115506855 -0.3979373387545264 0.1520881534833910 -0.2010804514091372 0.4447147692018334 -0.6830166755147440 -0.0002576861753487 0.5781954611783305 -0.0375091627893805 0.5121756358795817 0.0297197140254773 0.4332229148788766 -0.3240527006890552 0.5330850295256511 0.3664711365265602 0.3288511296455119 0.0588396016404451 0.1134221597062257 0.1047567336850078 0.4535357098437908 0.1062866148880792 -0.3964092656837774 -0.2211800890450674 0.0350667323996222 0.4450432900616097 0.2950206358263853 -0.1617837757183893 -0.0376369332204927 -0.6746752660482623 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0299719306696789 -0.2322624725320701 -0.0280846899680325 -0.3044255686880000 -0.1077641482535519 -0.0069083614679702 0.3351358347080056 -0.4922707032978891 0.4293545450291714 0.4372821269062001 0.0167847133528843 0.2843629278945327 0.5958979805231146 0.3097336757510886 -0.2086733033047188 0.0248567764822071 -0.2810759958040470 -0.1653113624869834 -0.3528780198620412 -0.0254898556119252 slicot-5.0+20101122/examples77/MB03ZD.res000077500000000000000000000027531201767322700171660ustar00rootroot00000000000000MB03ZD EXAMPLE PROGRAM RESULTS The stable eigenvalues are i WR(i) WI(i) 1 -3.1941 0.0000 2 -0.1350 0.3179 3 -0.1350 -0.3179 4 -0.0595 0.2793 5 -0.0595 -0.2793 A basis for the stable invariant subspace is -0.102 -0.116 0.627 0.118 -0.605 -0.100 -0.510 -0.266 0.504 0.124 -0.179 0.015 -0.112 -0.142 0.413 -0.055 0.252 0.182 -0.134 0.100 -0.078 0.576 -0.271 -0.252 -0.177 0.340 -0.135 0.053 -0.234 -0.110 0.528 0.108 -0.205 0.219 -0.096 0.397 -0.429 0.161 -0.598 0.199 0.444 0.342 0.447 0.406 0.440 0.434 0.014 -0.383 0.072 -0.391 Orthogonality of US: || US'*US - I ||_F = .62E-15 Symplecticity of US: || US'*J*US ||_F = .23E-14 A basis for the unstable invariant subspace is -0.428 0.383 0.048 0.105 0.187 -0.506 -0.100 0.541 0.245 0.223 -0.334 -0.524 -0.044 -0.153 0.126 -0.453 0.076 0.103 -0.525 -0.268 -0.436 0.098 -0.752 0.209 -0.251 -0.093 -0.089 0.258 -0.114 -0.725 -0.112 -0.196 -0.186 -0.302 0.394 -0.120 -0.286 0.027 0.680 -0.119 -0.102 0.630 0.079 0.040 0.127 -0.091 -0.171 -0.136 -0.136 0.231 Orthogonality of UU: || UU'*UU - I ||_F = .69E-15 Symplecticity of UU: || UU'*J*UU ||_F = .10E-13 slicot-5.0+20101122/examples77/MB04AD.dat000077500000000000000000000024651201767322700171150ustar00rootroot00000000000000MB04AD EXAMPLE PROGRAM DATA T C C C C 8 3.1472 4.5751 -0.7824 1.7874 -2.2308 -0.6126 2.0936 4.5974 4.0579 4.6489 4.1574 2.5774 -4.5383 -1.1844 2.5469 -1.5961 -3.7301 -3.4239 2.9221 2.4313 -4.0287 2.6552 -2.2397 0.8527 4.1338 4.7059 4.5949 -1.0777 3.2346 2.9520 1.7970 -2.7619 1.3236 4.5717 1.5574 1.5548 1.9483 -3.1313 1.5510 2.5127 -4.0246 -0.1462 -4.6429 -3.2881 -1.8290 -0.1024 -3.3739 -2.4490 -2.2150 3.0028 3.4913 2.0605 4.5022 -0.5441 -3.8100 0.0596 0.4688 -3.5811 4.3399 -4.6817 -4.6555 1.4631 -0.0164 1.9908 3.9090 -3.5071 3.1428 -3.0340 -1.4834 3.7401 -0.1715 0.4026 4.5929 -2.4249 -2.5648 -2.4892 3.7401 -2.1416 1.6251 2.6645 0.4722 3.4072 4.2926 1.1604 -0.1715 1.6251 -4.2415 -0.0602 -3.6138 -2.4572 -1.5002 -0.2671 0.4026 2.6645 -0.0602 -3.7009 0.6882 -1.8421 -4.1122 0.1317 -3.9090 -4.5929 -0.4722 3.6138 -1.8421 2.9428 -0.4340 1.3834 3.5071 2.4249 -3.4072 2.4572 -4.1122 -0.4340 -2.3703 0.5231 -3.1428 2.5648 -4.2926 1.5002 0.1317 1.3834 0.5231 -4.1618 3.0340 2.4892 -1.1604 0.2671 slicot-5.0+20101122/examples77/MB04AD.res000077500000000000000000000076271201767322700171430ustar00rootroot00000000000000MB04AD EXAMPLE PROGRAM RESULTS The matrix T on exit is -3.9699 3.7658 5.5815 -1.7750 -0.8818 -0.0511 -4.2158 1.9054 0.0000 5.3686 -5.9166 4.9163 1.3839 0.8870 3.9458 -4.9167 0.0000 0.0000 5.9641 1.9432 -2.0680 2.4402 -1.4091 5.8512 0.0000 0.0000 0.0000 5.9983 -3.8172 4.0147 -2.0739 -1.2570 0.0000 0.0000 0.0000 0.0000 8.2005 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5732 8.0098 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.6017 2.4397 5.9751 0.0000 0.0000 0.0000 0.0000 0.0000 -2.5869 0.5598 0.2544 5.2129 The matrix Z on exit is -6.4705 -2.5511 -4.0551 -1.9895 -2.7642 0.7532 -4.1047 -2.2046 0.0000 7.3589 -4.4480 -2.7491 -1.5465 -1.4345 -0.9272 1.3121 0.0000 0.0000 4.9125 -0.4968 5.3574 3.8579 5.2547 -1.7324 0.0000 0.0000 0.0000 9.0822 0.0460 -0.3382 3.9302 3.1084 0.0000 0.0000 0.0000 0.0000 6.1869 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 5.5573 6.6549 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 2.7456 -3.5789 4.3432 0.0000 0.0000 0.0000 0.0000 0.0000 0.1549 3.5335 3.1346 4.1062 The matrix H is -7.4834 0.4404 2.3558 1.6724 -0.4630 1.9533 1.5724 -2.7254 0.0000 -7.3500 3.7414 3.7466 0.2837 0.6849 0.7727 -4.2140 0.0000 0.0000 -2.3493 -3.7994 -0.6872 1.1773 -2.6901 -5.1494 0.0000 0.0000 0.0000 -3.4719 5.3322 0.4182 1.9779 1.5175 0.0000 0.0000 0.0000 0.0000 -6.1880 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -3.3324 9.0833 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8703 0.0799 -2.8180 0.0000 0.0000 0.0000 0.0000 0.0000 -2.3477 3.3110 0.6561 0.7281 The matrix Q1 is -0.2489 -0.1409 0.3615 0.6458 0.0113 0.6063 -0.0470 0.0238 -0.2436 0.1294 -0.0874 -0.4103 0.3408 0.3628 -0.3267 0.6272 -0.4316 -0.2352 0.5553 -0.2811 -0.2198 -0.2880 -0.4564 -0.1773 0.1992 -0.2176 -0.5198 0.1561 -0.1523 0.1299 -0.7281 -0.2197 0.0161 0.7390 0.1125 -0.2226 -0.1003 0.3608 -0.1118 -0.4886 -0.5824 0.0984 -0.3052 0.1996 0.5889 -0.2442 0.0060 -0.3341 -0.3246 0.4661 -0.1835 0.3523 -0.5153 -0.3034 -0.0865 0.3931 -0.4559 -0.2961 -0.3790 -0.3127 -0.4356 0.3452 0.3642 -0.1467 The matrix Q2 is 0.0288 -0.1842 -0.6791 -0.2115 -0.4790 0.4212 -0.0417 -0.2253 -0.0666 -0.0787 -0.3711 0.1737 -0.0482 -0.5770 -0.6785 0.1607 0.1506 0.6328 0.0518 -0.6266 0.0652 -0.0790 -0.2854 -0.2994 -0.2900 -0.2737 -0.0076 -0.3671 -0.2017 -0.6241 0.4521 -0.2675 0.3353 0.4107 0.0326 0.1400 -0.6447 -0.2043 0.2561 0.4187 0.0905 -0.1648 -0.2363 -0.5323 0.3180 0.0286 0.1252 0.7126 -0.7246 0.0468 0.3328 -0.1794 -0.3639 0.2257 -0.2623 0.2786 0.4922 -0.5353 0.4803 -0.2501 -0.2723 0.0199 -0.3194 -0.0371 The upper left block of the matrix U1 is 0.4144 0.2249 0.6015 -0.1964 -0.0198 0.5131 -0.2823 -0.3058 -0.6620 0.1508 0.2237 0.0240 -0.0743 -0.4323 -0.0332 -0.7263 The upper right block of the matrix U1 is -0.3474 0.1306 -0.3391 -0.3530 -0.3760 0.1550 0.6087 -0.1646 0.1707 0.6553 -0.1262 -0.1177 0.3048 -0.0773 0.0767 -0.4173 The upper left block of the matrix U2 is 0.1403 -0.6447 -0.6536 -0.3707 0.7069 0.2609 -0.0091 -0.1702 -0.1218 -0.1120 0.3766 -0.5154 0.0773 0.6349 -0.5070 -0.1810 The upper right block of the matrix U2 is 0.0000 0.0000 0.0000 0.0000 0.1182 0.1587 0.1930 -0.5716 0.6051 -0.2720 0.3364 0.1089 0.2823 -0.0386 -0.1529 0.4434 The vector ALPHAR is 0.0000 0.7122 0.0000 0.7450 The vector ALPHAI is 0.7540 0.0000 0.7465 0.0000 The vector BETA is 4.0000 4.0000 8.0000 16.0000 slicot-5.0+20101122/examples77/MB04BD.dat000077500000000000000000000013111201767322700171030ustar00rootroot00000000000000MB04BD EXAMPLE PROGRAM DATA T I I 8 3.1472 1.3236 4.5751 4.5717 4.0579 -4.0246 4.6489 -0.1462 -3.7301 -2.2150 -3.4239 3.0028 4.1338 0.4688 4.7059 -3.5811 0.0000 0.0000 -1.5510 -4.5974 -2.5127 3.5071 0.0000 0.0000 1.5961 2.4490 -3.1428 2.5648 0.0000 0.0000 -0.0596 3.0340 2.4892 -1.1604 0.0000 0.0000 0.6882 -3.3782 -3.3435 1.8921 -0.3061 2.9428 1.0198 2.4815 -4.8810 -1.8878 -2.3703 -0.4946 -1.6288 0.2853 1.5408 -4.1618 -2.4013 -2.7102 0.3834 -3.9335 3.1730 -3.1815 -2.3620 4.9613 4.6190 3.6869 3.6929 0.7970 0.4986 -4.9537 -4.1556 3.5303 1.2206 -1.4905 0.1325 -1.0022 slicot-5.0+20101122/examples77/MB04BD.res000077500000000000000000000050771201767322700171410ustar00rootroot00000000000000MB04BD EXAMPLE PROGRAM RESULTS The matrix A on exit is -4.7460 4.1855 3.2696 -0.2244 0.0000 6.4157 2.8287 1.4553 0.0000 0.0000 7.4626 1.5726 0.0000 0.0000 0.0000 8.8702 The matrix D on exit is 0.0000 -1.3137 -6.3615 -0.8940 0.0000 0.0000 1.0704 -0.0659 4.4324 0.0000 0.0000 -0.6922 0.5254 1.6653 0.0000 0.0000 The matrix B on exit is -6.4937 -2.1982 -1.3881 1.3477 0.0000 4.6929 0.6650 -4.1191 0.0000 0.0000 9.1725 3.4721 0.0000 0.0000 0.0000 7.2106 The matrix F on exit is 0.0000 -1.1367 2.2966 -1.0744 0.0000 0.0000 3.7875 0.9427 0.0000 0.0000 0.0000 -4.7136 0.0000 0.0000 0.0000 0.0000 The matrix C1 on exit is 6.9525 -4.9881 2.3661 4.2188 0.0000 8.5009 0.7182 5.5533 0.0000 0.0000 -4.6650 -2.8177 0.0000 0.0000 0.0000 1.5124 The matrix C2 on exit is -5.4562 -2.1348 4.9694 -2.2744 2.5550 -7.9616 1.1516 3.4912 0.0000 0.0000 4.8504 0.5046 0.0000 0.0000 0.0000 4.4394 The matrix V on exit is 0.9136 4.1106 -0.0079 3.5789 -1.1553 -1.4785 -1.5155 -0.8018 -2.2167 4.8029 1.3645 2.5202 -1.0994 -0.6144 0.3970 2.0730 The vector ALPHAR is 0.8314 -1.1758 0.8131 0.0000 The vector ALPHAI is 0.4372 0.6183 0.0000 0.9164 The vector BETA is 0.7071 1.0000 1.4142 2.8284 The matrix Q1 is -0.0098 0.1978 0.2402 0.5274 0.1105 -0.0149 -0.1028 0.7759 -0.6398 0.2356 0.2765 -0.1301 -0.5351 -0.3078 0.2435 0.0373 0.1766 -0.4781 0.2657 -0.5415 0.0968 -0.4663 -0.0983 0.3741 0.3207 -0.1980 0.1141 0.0240 -0.1712 0.2630 0.8513 0.1451 -0.6551 -0.2956 -0.0288 -0.1169 0.5593 0.3381 0.1753 0.1055 -0.0246 -0.2759 0.2470 -0.1408 -0.4837 0.6567 -0.4042 0.1172 -0.0772 -0.0121 -0.8394 -0.1852 -0.2673 0.0046 0.0159 0.4282 0.1442 0.6884 0.1257 -0.5860 0.2110 0.2699 0.0363 0.1657 The matrix Q2 is -0.2891 0.3096 0.6312 0.6498 0.0000 0.0000 0.0000 0.0000 0.1887 0.1936 -0.3857 0.3664 0.5660 0.1238 -0.2080 -0.5148 -0.2492 -0.2877 -0.0874 0.1110 -0.1081 -0.2999 0.6800 -0.5207 -0.7430 -0.0646 -0.4689 0.1556 -0.2401 0.0181 -0.3724 0.0562 -0.0999 -0.2026 -0.0355 0.0866 0.5587 -0.6625 -0.0114 0.4349 -0.4357 0.1209 0.0489 -0.2990 0.5094 0.5191 0.3837 0.1661 -0.2429 0.4131 0.2549 -0.5525 0.0749 -0.3829 -0.2690 -0.4190 0.0889 0.7439 -0.3960 0.0697 -0.1821 -0.1988 0.3687 0.2616 slicot-5.0+20101122/examples77/MB04DD.dat000077500000000000000000000015051201767322700171120ustar00rootroot00000000000000MB04DD EXAMPLE PROGRAM DATA 6 B 0 0 0 0 0 0 0.0994 0 0 0 0 0.9696 0.3248 0 0 0 0.4372 0.8308 0 0 0 0.0717 0 0 0 0 0 0 0 0.1976 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0.0651 0 0 0 0 0 0 0 0 0 0 0 0.0444 0 0 0.1957 0 0.8144 0 0 0 0.3652 0 0.9121 0.9023 0 0 0 0 0 1.0945 slicot-5.0+20101122/examples77/MB04DD.res000077500000000000000000000022161201767322700171330ustar00rootroot00000000000000 MB04DD EXAMPLE PROGRAM RESULTS The balanced matrix A is 0.0000 0.0000 0.0000 0.0000 0.0000 0.9696 0.0000 0.0000 0.0000 0.0000 -0.8144 -0.9023 0.0000 0.0000 0.0000 0.0000 0.1093 0.2077 0.0000 0.0000 0.0000 0.0717 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1976 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The balanced matrix QG is 0.0000 0.0000 0.0994 0.0000 0.0651 0.0000 0.0000 0.0000 0.0000 0.0000 0.0812 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1776 0.0000 0.0000 0.1957 0.0000 0.0000 0.0000 0.0000 0.0000 0.3652 0.0000 0.9121 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0945 ILO = 3 Norm of subdiagonal blocks: 0.0 slicot-5.0+20101122/examples77/MB04DS.dat000077500000000000000000000015051201767322700171310ustar00rootroot00000000000000MB04DS EXAMPLE PROGRAM DATA 6 B 0.0576 0 0.5208 0 0.7275 -0.7839 0.1901 0.0439 0.1663 0.0928 0.6756 -0.5030 0.5962 0 0.4418 0 -0.5955 0.7176 0.5869 0 0.3939 0.0353 0.6992 -0.0147 0.2222 0 -0.3663 0 0.5548 -0.4608 0 0 0 0 0 0.1338 0 0 -0.9862 -0.4544 -0.4733 0.4435 0 0 0 0 -0.6927 0.6641 0.4453 0 -0.3676 0 0 0 0.0841 0.3533 0 0 0 0 0 0 0.0877 0 0.9561 0 0.4784 0 0 0 0 -0.0164 -0.4514 -0.8289 -0.6831 -0.1536 0 0 slicot-5.0+20101122/examples77/MB04DS.res000077500000000000000000000016441201767322700171560ustar00rootroot00000000000000 MB04DS EXAMPLE PROGRAM RESULTS The balanced matrix A is 0.1338 0.4514 0.6831 0.8289 0.1536 0.0164 0.0000 0.0439 0.0928 0.1663 0.6756 0.1901 0.0000 0.0000 0.0353 0.3939 0.6992 0.5869 0.0000 0.0000 0.0000 0.4418 -0.5955 0.5962 0.0000 0.0000 0.0000 -0.3663 0.5548 0.2222 0.0000 0.0000 0.0000 0.5208 0.7275 0.0576 The balanced matrix QG is 0.0000 0.0000 0.5030 0.0147 -0.7176 0.4608 0.7839 0.0000 0.0000 0.0000 0.6641 -0.6927 0.4453 0.9862 0.0000 0.0000 0.0000 0.0000 -0.0841 0.0877 0.4733 0.0000 0.0000 0.0000 0.0000 0.0000 0.3533 0.4544 0.0000 0.0000 0.0000 0.4784 0.0000 0.0000 -0.4435 0.0000 0.0000 0.0000 0.3676 -0.9561 0.0000 0.0000 ILO = 4 Norm of subdiagonal blocks: 0.0 slicot-5.0+20101122/examples77/MB04DY.dat000077500000000000000000000002731201767322700171400ustar00rootroot00000000000000MB04DY EXAMPLE PROGRAM DATA 3 S -0.4 0.05 0.0007 -4.7 0.8 0.025 81.0 29.0 -0.9 0.0034 0.0014 0.00077 -0.005 0.0004 0.003 -18.0 -12.0 43.0 99.0 420.0 -200.0 slicot-5.0+20101122/examples77/MB04DY.res000077500000000000000000000007551201767322700171660ustar00rootroot00000000000000 MB04DY EXAMPLE PROGRAM RESULTS The scaled Hamiltonian is -0.4000 0.4000 0.3584 418.4403 21.5374 0.1851 -0.5875 0.8000 1.6000 21.5374 -9.6149 0.0120 0.1582 0.4531 -0.9000 0.1851 0.0120 0.0014 -0.0001 -0.0008 0.1789 0.4000 0.5875 -0.1582 -0.0008 0.0515 13.9783 -0.4000 -0.8000 -0.4531 0.1789 13.9783 -426.0056 -0.3584 -1.6000 0.9000 The scaling factors are 0.0029 0.0228 1.4595 slicot-5.0+20101122/examples77/MB04GD.dat000077500000000000000000000004001201767322700171060ustar00rootroot00000000000000 MB04GD EXAMPLE PROGRAM DATA 6 5 1. 2. 6. 3. 5. -2. -1. -1. 0. -2. 5. 5. 1. 5. 1. -2. -1. -1. 0. -2. 4. 8. 4. 20. 4. -2. -1. -1. 0. -2. 0 0 0 0 0 0 slicot-5.0+20101122/examples77/MB04GD.res000077500000000000000000000005741201767322700171430ustar00rootroot00000000000000 MB04GD EXAMPLE PROGRAM RESULTS Row permutations are 2 4 6 3 1 5 The matrix A is 0.0000 -1.0517 -1.8646 -1.9712 1.2374 0.0000 -1.0517 -1.8646 -1.9712 1.2374 0.0000 -1.0517 -1.8646 -1.9712 1.2374 0.0000 0.0000 4.6768 0.0466 -7.4246 0.0000 0.0000 0.0000 6.7059 -5.4801 0.0000 0.0000 0.0000 0.0000 -22.6274 slicot-5.0+20101122/examples77/MB04MD.dat000077500000000000000000000002151201767322700171200ustar00rootroot00000000000000 MB04MD EXAMPLE PROGRAM DATA 4 0.0 1.0 0.0 0.0 0.0 300.0 400.0 500.0 600.0 1.0 2.0 0.0 0.0 1.0 1.0 1.0 1.0 slicot-5.0+20101122/examples77/MB04MD.res000077500000000000000000000004471201767322700171500ustar00rootroot00000000000000 MB04MD EXAMPLE PROGRAM RESULTS The balanced matrix is 1.0000 0.0000 0.0000 0.0000 30.0000 400.0000 50.0000 60.0000 1.0000 20.0000 0.0000 0.0000 1.0000 10.0000 1.0000 1.0000 SCALE is 1.0000 10.0000 1.0000 1.0000 slicot-5.0+20101122/examples77/MB04OD.dat000077500000000000000000000003121201767322700171200ustar00rootroot00000000000000 MB04OD EXAMPLE PROGRAM DATA 3 2 2 F 3. 2. 1. 0. 2. 1. 0. 0. 1. 2. 3. 1. 4. 6. 5. 3. 2. 1. 3. 3. 2. 1. 3. 3. 2. slicot-5.0+20101122/examples77/MB04OD.res000077500000000000000000000005101201767322700171410ustar00rootroot00000000000000 MB04OD EXAMPLE PROGRAM RESULTS The updated matrix R is -5.3852 -6.6850 -4.6424 0.0000 -2.8828 -2.0694 0.0000 0.0000 -1.7793 The updated matrix B is -4.2710 -3.7139 -0.1555 -2.1411 -1.6021 0.9398 The updated matrix C is 0.5850 1.0141 -2.7974 -3.1162 slicot-5.0+20101122/examples77/MB04PB.dat000077500000000000000000000011261201767322700171230ustar00rootroot00000000000000MB04PB EXAMPLE PROGRAM DATA 5 0.9501 0.7621 0.6154 0.4057 0.0579 0.2311 0.4565 0.7919 0.9355 0.3529 0.6068 0.0185 0.9218 0.9169 0.8132 0.4860 0.8214 0.7382 0.4103 0.0099 0.8913 0.4447 0.1763 0.8936 0.1389 0.3869 0.4055 0.2140 1.0224 1.1103 0.7016 1.3801 0.7567 1.4936 1.2913 0.9515 1.1755 0.7993 1.7598 1.6433 1.0503 0.8839 1.1010 1.2019 1.1956 0.9346 0.6824 0.7590 1.1364 0.8780 0.9029 1.6565 1.1022 0.7408 0.3793 slicot-5.0+20101122/examples77/MB04PB.res000077500000000000000000000033751201767322700171540ustar00rootroot00000000000000 TMB04PB EXAMPLE PROGRAM RESULTS The symplectic orthogonal factor U is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0927 0.2098 0.5594 -0.0226 0.0000 0.5538 0.3184 0.2519 -0.4031 0.0000 -0.2435 0.4745 -0.6362 -0.2542 0.0000 0.3207 -0.2455 0.0595 -0.2819 0.0000 -0.1950 -0.1770 -0.1519 -0.2857 0.0000 0.4823 0.4122 -0.2060 0.6173 0.0000 -0.3576 -0.0480 0.2302 0.4512 0.0000 0.3523 -0.6047 -0.3110 0.1635 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.5538 -0.3184 -0.2519 0.4031 0.0000 -0.0927 0.2098 0.5594 -0.0226 0.0000 -0.3207 0.2455 -0.0595 0.2819 0.0000 -0.2435 0.4745 -0.6362 -0.2542 0.0000 -0.4823 -0.4122 0.2060 -0.6173 0.0000 -0.1950 -0.1770 -0.1519 -0.2857 0.0000 -0.3523 0.6047 0.3110 -0.1635 0.0000 -0.3576 -0.0480 0.2302 0.4512 Orthogonality of U: || U'*U - I ||_F = .77E-15 The reduced matrix A is 0.9501 -1.5494 0.5268 0.3187 -0.6890 -2.4922 2.0907 -1.3598 0.5682 0.5618 0.0000 -1.7723 0.3960 -0.2624 -0.3709 0.0000 0.0000 -0.2648 0.2136 -0.3226 0.0000 0.0000 0.0000 -0.2308 0.2319 The reduced matrix QG is 0.3869 0.4055 0.0992 0.5237 -0.4110 -0.4861 0.0000 -3.7784 -4.1609 0.3614 0.3606 -0.0696 0.0000 0.0000 1.2192 -0.0848 0.2007 0.3735 0.0000 0.0000 0.0000 -0.8646 0.1538 -0.1970 0.0000 0.0000 0.0000 0.0000 -0.4527 0.0743 Residual: || H - U*R*U' ||_F = .33E-14 slicot-5.0+20101122/examples77/MB04PU.dat000077500000000000000000000011261201767322700171460ustar00rootroot00000000000000MB04PU EXAMPLE PROGRAM DATA 5 0.9501 0.7621 0.6154 0.4057 0.0579 0.2311 0.4565 0.7919 0.9355 0.3529 0.6068 0.0185 0.9218 0.9169 0.8132 0.4860 0.8214 0.7382 0.4103 0.0099 0.8913 0.4447 0.1763 0.8936 0.1389 0.4055 0.3869 1.3801 0.7993 1.2019 0.8780 0.2140 1.4936 0.7567 1.7598 1.1956 0.9029 1.0224 1.2913 1.0503 1.6433 0.9346 1.6565 1.1103 0.9515 0.8839 0.7590 0.6824 1.1022 0.7016 1.1755 1.1010 1.1364 0.3793 0.7408 slicot-5.0+20101122/examples77/MB04PU.res000077500000000000000000000033751201767322700171770ustar00rootroot00000000000000 TMB04PU EXAMPLE PROGRAM RESULTS The symplectic orthogonal factor U is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1119 0.7763 -0.2005 -0.0001 0.0000 0.1036 -0.2783 -0.2583 0.4356 0.0000 -0.2937 0.2320 0.4014 0.5541 0.0000 0.4949 0.1187 -0.0294 -0.3632 0.0000 -0.2352 -0.2243 -0.7056 -0.0500 0.0000 0.5374 0.3102 -0.0893 0.0318 0.0000 -0.4314 -0.0354 0.2658 -0.6061 0.0000 0.3396 -0.3230 0.3931 0.0207 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1036 0.2783 0.2583 -0.4356 0.0000 -0.1119 0.7763 -0.2005 -0.0001 0.0000 -0.4949 -0.1187 0.0294 0.3632 0.0000 -0.2937 0.2320 0.4014 0.5541 0.0000 -0.5374 -0.3102 0.0893 -0.0318 0.0000 -0.2352 -0.2243 -0.7056 -0.0500 0.0000 -0.3396 0.3230 -0.3931 -0.0207 0.0000 -0.4314 -0.0354 0.2658 -0.6061 Orthogonality of U: || U'*U - I ||_F = .16E-14 The reduced matrix A is 0.9501 -1.8690 0.8413 -0.0344 -0.0817 -2.0660 2.7118 -1.6646 0.7606 -0.0285 0.0000 -2.4884 0.4115 -0.4021 0.3964 0.0000 0.0000 -0.5222 0.1767 -0.3081 0.0000 0.0000 0.0000 0.1915 -0.3426 The reduced matrix QG is 0.4055 0.3869 -0.4295 0.9242 -0.7990 -0.0268 0.0000 -3.0834 -2.5926 0.0804 0.1386 -0.1630 0.0000 0.0000 1.3375 0.9618 -0.0263 0.1829 0.0000 0.0000 0.0000 -0.3556 0.6662 0.2123 0.0000 0.0000 0.0000 0.0000 0.1337 -0.8622 Residual: || H - U*R*U' ||_F = .60E-14 slicot-5.0+20101122/examples77/MB04TB.dat000077500000000000000000000020621201767322700171270ustar00rootroot00000000000000MB04TB EXAMPLE PROGRAM DATA 5 N N 0.4643 0.3655 0.6853 0.5090 0.3718 0.3688 0.6460 0.4227 0.6798 0.5135 0.7458 0.5043 0.9419 0.9717 0.9990 0.7140 0.4941 0.7802 0.5272 0.1220 0.7418 0.0339 0.7441 0.0436 0.6564 -0.4643 -0.3688 -0.7458 -0.7140 -0.7418 -0.3655 -0.6460 -0.5043 -0.4941 -0.0339 -0.6853 -0.4227 -0.9419 -0.7802 -0.7441 -0.5090 -0.6798 -0.9717 -0.5272 -0.0436 -0.3718 -0.5135 -0.9990 -0.1220 -0.6564 0.7933 1.5765 1.0711 1.0794 0.8481 1.5765 0.1167 1.5685 0.8756 0.5037 1.0711 1.5685 0.9902 0.3858 0.2109 1.0794 0.8756 0.3858 1.8834 1.4338 0.8481 0.5037 0.2109 1.4338 0.1439 1.0786 1.5264 1.1721 1.5343 0.4756 1.5264 0.8644 0.6872 1.1379 0.6499 1.1721 0.6872 1.5194 1.1197 1.0158 1.5343 1.1379 1.1197 0.6612 0.2004 0.4756 0.6499 1.0158 0.2004 1.2188 slicot-5.0+20101122/examples77/MB04TB.res000077500000000000000000000063471201767322700171620ustar00rootroot00000000000000 MB04TB EXAMPLE PROGRAM RESULTS The orthogonal symplectic factor U is -0.1513 0.0756 -0.0027 0.1694 -0.2999 0.3515 -0.4843 0.6545 -0.1995 -0.1627 -0.1202 0.2320 0.1662 -0.2835 -0.0508 0.4975 0.3319 -0.2686 -0.4186 -0.4649 -0.2431 0.2724 0.3439 0.3954 0.0236 0.3820 -0.2863 -0.4324 0.3706 0.1984 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 0.5000 0.3659 0.1429 0.0493 0.6015 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 0.1550 -0.4441 -0.0396 0.2376 -0.1702 -0.3515 0.4843 -0.6545 0.1995 0.1627 -0.1513 0.0756 -0.0027 0.1694 -0.2999 -0.4975 -0.3319 0.2686 0.4186 0.4649 -0.1202 0.2320 0.1662 -0.2835 -0.0508 -0.3820 0.2863 0.4324 -0.3706 -0.1984 -0.2431 0.2724 0.3439 0.3954 0.0236 -0.5000 -0.3659 -0.1429 -0.0493 -0.6015 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 -0.1550 0.4441 0.0396 -0.2376 0.1702 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 Orthogonality of U: || U^T U - I ||_F = .24E-14 The factor R is -3.0684 4.6724 -0.2613 -0.1996 0.0208 -0.1071 -0.1355 -0.1400 0.4652 -0.5032 0.0000 -1.8037 -0.0301 -0.1137 0.1771 0.0277 0.3929 0.5424 0.5220 -0.4843 0.0000 0.0000 -0.7617 -0.1874 0.2557 0.1244 -0.0012 0.4091 0.5123 -0.3522 0.0000 0.0000 0.0000 -0.6931 -0.4293 -0.3718 0.1542 -0.3635 0.0336 -0.9832 0.0000 0.0000 0.0000 0.0000 0.6469 0.2074 0.0266 0.2028 0.1995 0.2517 0.0000 0.0000 0.0000 0.0000 0.0000 2.6325 -4.7377 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.2702 0.9347 -1.1210 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.3219 -0.5394 0.1748 -0.4788 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1431 -0.1021 0.4974 -0.3565 -0.6402 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1622 -0.2368 0.6126 -0.7369 0.6915 Residual: || H*V - U*R ||_F = .87E-14 The orthogonal symplectic factor V is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0061 -0.1732 0.3134 0.2220 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 -0.0382 0.2453 -0.1662 0.0509 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 -0.0665 -0.4132 -0.3100 -0.4457 0.0000 -0.3872 -0.4022 -0.4194 0.3541 0.0000 -0.0406 0.3820 0.3006 0.3861 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0061 0.1732 -0.3134 -0.2220 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0382 -0.2453 0.1662 -0.0509 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 0.0665 0.4132 0.3100 0.4457 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 0.0406 -0.3820 -0.3006 -0.3861 0.0000 -0.3872 -0.4022 -0.4194 0.3541 Orthogonality of V: || V^T V - I ||_F = .14E-14 slicot-5.0+20101122/examples77/MB04TS.dat000077500000000000000000000020621201767322700171500ustar00rootroot00000000000000MB04TB EXAMPLE PROGRAM DATA 5 N N 0.4643 0.3655 0.6853 0.5090 0.3718 0.3688 0.6460 0.4227 0.6798 0.5135 0.7458 0.5043 0.9419 0.9717 0.9990 0.7140 0.4941 0.7802 0.5272 0.1220 0.7418 0.0339 0.7441 0.0436 0.6564 -0.4643 -0.3688 -0.7458 -0.7140 -0.7418 -0.3655 -0.6460 -0.5043 -0.4941 -0.0339 -0.6853 -0.4227 -0.9419 -0.7802 -0.7441 -0.5090 -0.6798 -0.9717 -0.5272 -0.0436 -0.3718 -0.5135 -0.9990 -0.1220 -0.6564 0.7933 1.5765 1.0711 1.0794 0.8481 1.5765 0.1167 1.5685 0.8756 0.5037 1.0711 1.5685 0.9902 0.3858 0.2109 1.0794 0.8756 0.3858 1.8834 1.4338 0.8481 0.5037 0.2109 1.4338 0.1439 1.0786 1.5264 1.1721 1.5343 0.4756 1.5264 0.8644 0.6872 1.1379 0.6499 1.1721 0.6872 1.5194 1.1197 1.0158 1.5343 1.1379 1.1197 0.6612 0.2004 0.4756 0.6499 1.0158 0.2004 1.2188 slicot-5.0+20101122/examples77/MB04TS.res000077500000000000000000000063471201767322700172030ustar00rootroot00000000000000 MB04TS EXAMPLE PROGRAM RESULTS The orthogonal symplectic factor U is -0.1513 0.0756 -0.0027 0.1694 -0.2999 0.3515 -0.4843 0.6545 -0.1995 -0.1627 -0.1202 0.2320 0.1662 -0.2835 -0.0508 0.4975 0.3319 -0.2686 -0.4186 -0.4649 -0.2431 0.2724 0.3439 0.3954 0.0236 0.3820 -0.2863 -0.4324 0.3706 0.1984 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 0.5000 0.3659 0.1429 0.0493 0.6015 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 0.1550 -0.4441 -0.0396 0.2376 -0.1702 -0.3515 0.4843 -0.6545 0.1995 0.1627 -0.1513 0.0756 -0.0027 0.1694 -0.2999 -0.4975 -0.3319 0.2686 0.4186 0.4649 -0.1202 0.2320 0.1662 -0.2835 -0.0508 -0.3820 0.2863 0.4324 -0.3706 -0.1984 -0.2431 0.2724 0.3439 0.3954 0.0236 -0.5000 -0.3659 -0.1429 -0.0493 -0.6015 -0.2327 -0.1509 -0.3710 -0.1240 -0.0393 -0.1550 0.4441 0.0396 -0.2376 0.1702 -0.2418 -0.2928 -0.0836 -0.5549 0.4824 Orthogonality of U: || U^T U - I ||_F = .24E-14 The factor R is -3.0684 4.6724 -0.2613 -0.1996 0.0208 -0.1071 -0.1355 -0.1400 0.4652 -0.5032 0.0000 -1.8037 -0.0301 -0.1137 0.1771 0.0277 0.3929 0.5424 0.5220 -0.4843 0.0000 0.0000 -0.7617 -0.1874 0.2557 0.1244 -0.0012 0.4091 0.5123 -0.3522 0.0000 0.0000 0.0000 -0.6931 -0.4293 -0.3718 0.1542 -0.3635 0.0336 -0.9832 0.0000 0.0000 0.0000 0.0000 0.6469 0.2074 0.0266 0.2028 0.1995 0.2517 0.0000 0.0000 0.0000 0.0000 0.0000 2.6325 -4.7377 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.2702 0.9347 -1.1210 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.3219 -0.5394 0.1748 -0.4788 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1431 -0.1021 0.4974 -0.3565 -0.6402 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1622 -0.2368 0.6126 -0.7369 0.6915 Residual: || H*V - U*R ||_F = .87E-14 The orthogonal symplectic factor V is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0061 -0.1732 0.3134 0.2220 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 -0.0382 0.2453 -0.1662 0.0509 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 -0.0665 -0.4132 -0.3100 -0.4457 0.0000 -0.3872 -0.4022 -0.4194 0.3541 0.0000 -0.0406 0.3820 0.3006 0.3861 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.0061 0.1732 -0.3134 -0.2220 0.0000 -0.4740 0.6013 -0.2299 -0.4282 0.0000 0.0382 -0.2453 0.1662 -0.0509 0.0000 -0.5553 -0.2623 0.6622 -0.3042 0.0000 0.0665 0.4132 0.3100 0.4457 0.0000 -0.5563 0.0322 -0.1431 0.4461 0.0000 0.0406 -0.3820 -0.3006 -0.3861 0.0000 -0.3872 -0.4022 -0.4194 0.3541 Orthogonality of V: || V^T V - I ||_F = .14E-14 slicot-5.0+20101122/examples77/MB04UD.dat000077500000000000000000000003401201767322700171270ustar00rootroot00000000000000 MB04UD EXAMPLE PROGRAM DATA 4 4 0.0 2.0 0.0 2.0 -2.0 0.0 -2.0 0.0 2.0 2.0 0.0 -2.0 0.0 2.0 -2.0 0.0 2.0 1.0 0.0 1.0 -1.0 0.0 -1.0 0.0 1.0 1.0 0.0 -1.0 0.0 1.0 -1.0 0.0 1.0 slicot-5.0+20101122/examples77/MB04UD.res000077500000000000000000000007111201767322700171520ustar00rootroot00000000000000 MB04UD EXAMPLE PROGRAM RESULTS The transformed matrix A is 0.5164 1.0328 1.1547 -2.3094 0.0000 -2.5820 0.0000 -1.1547 0.0000 0.0000 -3.4641 0.0000 0.0000 0.0000 0.0000 -3.4641 The transformed matrix E is 0.2582 0.5164 0.5774 -1.1547 0.0000 -1.2910 0.0000 -0.5774 0.0000 0.0000 -1.7321 0.0000 0.0000 0.0000 0.0000 -1.7321 The computed rank of E = 4 ISTAIR is 1 2 3 4 slicot-5.0+20101122/examples77/MB04VD.dat000077500000000000000000000002161201767322700171320ustar00rootroot00000000000000 MB04VD EXAMPLE PROGRAM DATA 2 4 0.0 S 1.0 0.0 -1.0 0.0 1.0 1.0 0.0 -1.0 0.0 -1.0 0.0 0.0 0.0 -1.0 0.0 0.0 slicot-5.0+20101122/examples77/MB04VD.res000077500000000000000000000015651201767322700171630ustar00rootroot00000000000000 MB04VD EXAMPLE PROGRAM RESULTS The unitary transformed pencil is Q'*(s*E-A)*Z, where Matrix Q 0.7071 -0.7071 0.7071 0.7071 Matrix E 0.0000 0.0000 -1.1547 0.8165 0.0000 0.0000 0.0000 0.0000 Matrix A 0.0000 1.7321 0.5774 -0.4082 0.0000 0.0000 0.0000 -1.2247 Matrix Z 0.5774 0.8165 0.0000 0.0000 0.0000 0.0000 0.8165 -0.5774 0.5774 -0.4082 -0.4082 -0.5774 0.5774 -0.4082 0.4082 0.5774 The number of submatrices having full row rank detected in matrix A = 2 The column dimensions of the submatrices having full column rank in the pencil sE(eps) - A(eps) are 2 1 The row dimensions of the submatrices having full row rank in the pencil sE(eps) - A(eps) are 1 0 The orders of the diagonal submatrices in the pencil sE(inf) - A(inf) are 1 MNEI is 1 3 1 slicot-5.0+20101122/examples77/MB04XD.dat000077500000000000000000000004711201767322700171370ustar00rootroot00000000000000 MB04XD EXAMPLE PROGRAM DATA 6 4 -1 0.001 0.0 0.0 A A 0.80010 0.39985 0.60005 0.89999 0.29996 0.69990 0.39997 0.82997 0.49994 0.60003 0.20012 0.79011 0.90013 0.20016 0.79995 0.85002 0.39998 0.80006 0.49985 0.99016 0.20002 0.90007 0.70009 1.02994 slicot-5.0+20101122/examples77/MB04XD.res000077500000000000000000000021511201767322700171550ustar00rootroot00000000000000 MB04XD EXAMPLE PROGRAM RESULTS The computed rank of matrix A = 3 The elements of the partially diagonalized bidiagonal matrix are (1,1) = 3.2280 (1,2) = -0.0287 (2,2) = 0.8714 (2,3) = 0.0168 (3,3) = 0.3698 (3,4) = 0.0000 (4,4) = 0.0001 Matrix U 0.8933 0.4328 -0.1209 0.2499 -0.5812 0.4913 -0.4493 0.8555 -0.2572 0.1617 -0.4608 -0.7379 -0.0079 0.2841 0.9588 -0.5352 0.1892 0.0525 0.0000 0.0000 0.0003 -0.1741 0.3389 -0.3397 0.0000 0.0000 0.0000 0.6482 0.5428 0.1284 0.0000 0.0000 0.0000 -0.4176 -0.0674 0.2819 Left singular subspace corresponds to the i-th column(s) of U for which INUL(i) = .TRUE., i = 1,...,6 i INUL(i) 1 F 2 F 3 F 4 T 5 T 6 T Matrix V -0.3967 -0.7096 0.4612 -0.3555 0.9150 -0.2557 0.2414 -0.5687 -0.0728 0.6526 0.5215 -0.2128 0.0000 0.0720 0.6761 0.7106 Right singular subspace corresponds to the j-th column(s) of V for which INUL(j) = .TRUE., j = 1,...,4 j INUL(j) 1 F 2 F 3 F 4 T slicot-5.0+20101122/examples77/MB04YD.dat000077500000000000000000000002041201767322700171320ustar00rootroot00000000000000 MB04YD EXAMPLE PROGRAM DATA 5 5 2.0 -1 0.0 0.0 N N 1.0 2.0 3.0 4.0 5.0 2.0 3.0 4.0 5.0 slicot-5.0+20101122/examples77/MB04YD.res000077500000000000000000000004141201767322700171560ustar00rootroot00000000000000 MB04YD EXAMPLE PROGRAM RESULTS The transformed bidiagonal matrix J is (1,1) = 0.4045 (1,2) = 0.0000 (2,2) = 1.9839 (2,3) = 0.0000 (3,3) = 3.4815 (3,4) = 0.0128 (4,4) = 5.3723 (4,5) = 0.0273 (5,5) = 7.9948 J has 3 singular values > 2.0000 slicot-5.0+20101122/examples77/MB04ZD.dat000077500000000000000000000001651201767322700171410ustar00rootroot00000000000000MB04ZD EXAMPLE PROGRAM DATA 3 N 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 1.0 1.0 1.0 2.0 2.0 3.0 7.0 6.0 5.0 8.0 4.0 9.0 slicot-5.0+20101122/examples77/MB04ZD.res000077500000000000000000000015411201767322700171610ustar00rootroot00000000000000 MB04ZD EXAMPLE PROGRAM RESULTS The square-reduced Hamiltonian is 1.0000 3.3485 0.3436 1.0000 1.9126 -0.1072 6.7566 11.0750 -0.3014 1.9126 8.4479 -1.0790 2.3478 1.6899 -2.3868 -0.1072 -1.0790 -2.9871 7.0000 8.6275 -0.6352 -1.0000 -6.7566 -2.3478 8.6275 16.2238 -0.1403 -3.3485 -11.0750 -1.6899 -0.6352 -0.1403 1.2371 -0.3436 0.3014 2.3868 The square of the square-reduced Hamiltonian is 48.0000 80.6858 -2.5217 0.0000 1.8590 -10.5824 167.8362 298.4815 -4.0310 -1.8590 0.0000 -33.1160 0.0000 4.5325 2.5185 10.5824 33.1160 0.0000 0.0000 0.0000 0.0000 48.0000 167.8362 0.0000 0.0000 0.0000 0.0000 80.6858 298.4815 4.5325 0.0000 0.0000 0.0000 -2.5217 -4.0310 2.5185 slicot-5.0+20101122/examples77/MB05MD.dat000077500000000000000000000002161201767322700171220ustar00rootroot00000000000000 MB05MD EXAMPLE PROGRAM DATA 4 1.0 0.5 0.0 2.3 -2.6 0.0 0.5 -1.4 -0.7 2.3 -1.4 0.5 0.0 -2.6 -0.7 0.0 0.5 slicot-5.0+20101122/examples77/MB05MD.res000077500000000000000000000013131201767322700171420ustar00rootroot00000000000000 MB05MD EXAMPLE PROGRAM RESULTS The solution matrix exp(A*DELTA) is 26.8551 -3.2824 18.7409 -19.4430 -3.2824 4.3474 -5.1848 0.2700 18.7409 -5.1848 15.6012 -11.7228 -19.4430 0.2700 -11.7228 15.6012 The eigenvalues of A are -3.0 0.0*j 4.0 0.0*j -1.0 0.0*j 2.0 0.0*j The eigenvector matrix for A is -0.7000 0.7000 0.1000 -0.1000 0.1000 -0.1000 0.7000 -0.7000 0.5000 0.5000 0.5000 0.5000 -0.5000 -0.5000 0.5000 0.5000 The inverse eigenvector matrix for A (premultiplied by exp(Lambda*DELTA)) is -0.0349 0.0050 0.0249 -0.0249 38.2187 -5.4598 27.2991 -27.2991 0.0368 0.2575 0.1839 0.1839 -0.7389 -5.1723 3.6945 3.6945 slicot-5.0+20101122/examples77/MB05ND.dat000077500000000000000000000003201201767322700171170ustar00rootroot00000000000000 MB05ND EXAMPLE PROGRAM DATA 5 0.1 0.0001 5.0 4.0 3.0 2.0 1.0 1.0 6.0 0.0 4.0 3.0 2.0 0.0 7.0 6.0 5.0 1.0 3.0 1.0 8.0 7.0 2.0 5.0 7.0 1.0 9.0 slicot-5.0+20101122/examples77/MB05ND.res000077500000000000000000000010521201767322700171430ustar00rootroot00000000000000 MB05ND EXAMPLE PROGRAM RESULTS The solution matrix exp(A*DELTA) is 1.8391 0.9476 0.7920 0.8216 0.7811 0.3359 2.2262 0.4013 1.0078 1.0957 0.6335 0.6776 2.6933 1.6155 1.8502 0.4804 1.1561 0.9110 2.7461 2.0854 0.7105 1.4244 1.8835 1.0966 3.4134 and its integral is 0.1347 0.0352 0.0284 0.0272 0.0231 0.0114 0.1477 0.0104 0.0369 0.0368 0.0218 0.0178 0.1624 0.0580 0.0619 0.0152 0.0385 0.0267 0.1660 0.0732 0.0240 0.0503 0.0679 0.0317 0.1863 slicot-5.0+20101122/examples77/MB05OD.dat000077500000000000000000000001511201767322700171220ustar00rootroot00000000000000 MB05OD EXAMPLE PROGRAM DATA 3 1.0 S 2.0 1.0 1.0 0.0 3.0 2.0 1.0 0.0 4.0 slicot-5.0+20101122/examples77/MB05OD.res000077500000000000000000000005001201767322700171410ustar00rootroot00000000000000 MB05OD EXAMPLE PROGRAM RESULTS The solution matrix E = exp(A*DELTA) is 22.5984 17.2073 53.8144 24.4047 27.6033 83.2241 29.4097 12.2024 81.4177 Minimal number of accurate digits in the norm of E = 13 Number of accurate digits in the norm of E at 95 per cent confidence interval = 15 slicot-5.0+20101122/examples77/MC01MD.dat000077500000000000000000000001201201767322700171110ustar00rootroot00000000000000 MC01MD EXAMPLE PROGRAM DATA 5 2.0 6 6.0 5.0 4.0 3.0 2.0 1.0 slicot-5.0+20101122/examples77/MC01MD.res000077500000000000000000000005351201767322700171440ustar00rootroot00000000000000 MC01MD EXAMPLE PROGRAM RESULTS ALPHA = 2.0000 The coefficients of the shifted polynomial are power of (x-ALPHA) coefficient 0 120.0000 1 201.0000 2 150.0000 3 59.0000 4 12.0000 5 1.0000 slicot-5.0+20101122/examples77/MC01ND.dat000077500000000000000000000001211201767322700171130ustar00rootroot00000000000000 MC01ND EXAMPLE PROGRAM DATA 4 -1.56 0.29 5.0 3.0 -1.0 2.0 1.0 slicot-5.0+20101122/examples77/MC01ND.res000077500000000000000000000002041201767322700171360ustar00rootroot00000000000000 MC01ND EXAMPLE PROGRAM RESULTS Real part of P( -1.56 +0.29*j ) = -4.1337 Imaginary part of P( -1.56 +0.29*j ) = 1.7088 slicot-5.0+20101122/examples77/MC01OD.dat000077500000000000000000000001431201767322700171200ustar00rootroot00000000000000 MC01OD EXAMPLE PROGRAM DATA 5 1.1 0.9 0.6 -0.7 -2.0 0.3 -0.8 2.5 -0.3 -0.4 slicot-5.0+20101122/examples77/MC01OD.res000077500000000000000000000005431201767322700171450ustar00rootroot00000000000000 MC01OD EXAMPLE PROGRAM RESULTS The coefficients of the polynomial P(x) are power of x real part imag part 0 2.7494 -2.1300 1 -1.7590 -5.4205 2 0.0290 2.8290 3 -1.6500 -1.7300 4 1.4000 -2.6000 5 1.0000 0.0000 slicot-5.0+20101122/examples77/MC01PD.dat000077500000000000000000000001431201767322700171210ustar00rootroot00000000000000 MC01PD EXAMPLE PROGRAM DATA 5 0.0 1.0 0.0 -1.0 2.0 0.0 1.0 3.0 1.0 -3.0 slicot-5.0+20101122/examples77/MC01PD.res000077500000000000000000000004111201767322700171400ustar00rootroot00000000000000 MC01PD EXAMPLE PROGRAM RESULTS The coefficients of the polynomial P(x) are power of x coefficient 0 -20.0000 1 14.0000 2 -24.0000 3 15.0000 4 -4.0000 5 1.0000 slicot-5.0+20101122/examples77/MC01QD.dat000077500000000000000000000001251201767322700171220ustar00rootroot00000000000000 MC01QD EXAMPLE PROGRAM DATA 4 2.0 2.0 -1.0 2.0 1.0 2 1.0 -1.0 1.0 slicot-5.0+20101122/examples77/MC01QD.res000077500000000000000000000004371201767322700171510ustar00rootroot00000000000000 MC01QD EXAMPLE PROGRAM RESULTS The coefficients of the polynomials Q(x) and R(x) are Q(x) R(x) power of x coefficient coefficient 0 1.0000 1.0000 1 3.0000 0.0000 2 1.0000 slicot-5.0+20101122/examples77/MC01RD.dat000077500000000000000000000001451201767322700171250ustar00rootroot00000000000000 MC01RD EXAMPLE PROGRAM DATA 1 1.00 2.50 2 1.00 0.10 -0.40 1 1.15 1.50 -2.20 slicot-5.0+20101122/examples77/MC01RD.res000077500000000000000000000003651201767322700171520ustar00rootroot00000000000000 MC01RD EXAMPLE PROGRAM RESULTS Degree of the resulting polynomial P(x) = 3 The coefficients of P(x) are power of x coefficient 0 -1.5300 1 -0.7000 2 -0.1500 3 -1.0000 slicot-5.0+20101122/examples77/MC01SD.dat000077500000000000000000000001161201767322700171240ustar00rootroot00000000000000 MC01SD EXAMPLE PROGRAM DATA 5 10.0 -40.5 159.5 0.0 2560.0 -10236.5 slicot-5.0+20101122/examples77/MC01SD.res000077500000000000000000000005761201767322700171570ustar00rootroot00000000000000 MC01SD EXAMPLE PROGRAM RESULTS The base of the machine (BETA) = 2 The scaling factors are s = BETA**( -3) and t = BETA**( -2) The coefficients of the scaled polynomial Q(x) = s*P(tx) are power of x coefficient 0 1.2500 1 -1.2656 2 1.2461 3 0.0000 4 1.2500 5 -1.2496 slicot-5.0+20101122/examples77/MC01TD.dat000077500000000000000000000001041201767322700171220ustar00rootroot00000000000000 MC01TD EXAMPLE PROGRAM DATA 4 C 2.0 0.0 1.0 -1.0 1.0 slicot-5.0+20101122/examples77/MC01TD.res000077500000000000000000000001761201767322700171540ustar00rootroot00000000000000 MC01TD EXAMPLE PROGRAM RESULTS The polynomial P(x) is unstable The number of zeros of P(x) in the right half-plane = 2 slicot-5.0+20101122/examples77/MC01VD.dat000077500000000000000000000000571201767322700171330ustar00rootroot00000000000000 MC01VD EXAMPLE PROGRAM DATA 0.5 -1.0 2.0 slicot-5.0+20101122/examples77/MC01VD.res000077500000000000000000000002001201767322700171420ustar00rootroot00000000000000 MC01VD EXAMPLE PROGRAM RESULTS The roots of the quadratic equation are x = 1.0000 +1.7321*j x = 1.0000 -1.7321*j slicot-5.0+20101122/examples77/MC01WD.dat000077500000000000000000000001341201767322700171300ustar00rootroot00000000000000 MC01WD EXAMPLE PROGRAM DATA 6 0.62 1.10 1.64 1.88 2.12 1.70 1.00 0.60 0.80 slicot-5.0+20101122/examples77/MC01WD.res000077500000000000000000000006031201767322700171520ustar00rootroot00000000000000 MC01WD EXAMPLE PROGRAM RESULTS The coefficients of the quotient polynomial Q(x) are power of x coefficient 0 0.6000 1 0.7000 2 0.8000 3 0.9000 4 1.0000 The coefficients of the remainder polynomial R(x) are power of x coefficient 0 0.2600 1 0.2000 slicot-5.0+20101122/examples77/MC03MD.dat000077500000000000000000000004661201767322700171300ustar00rootroot00000000000000 MC03MD EXAMPLE PROGRAM DATA 3 2 2 2 1.0 0.0 3.0 2.0 -1.0 2.0 -2.0 4.0 9.0 3.0 7.0 -2.0 6.0 2.0 -3.0 1.0 2.0 4.0 1 6.0 1.0 1.0 7.0 -9.0 -6.0 7.0 8.0 1 1.0 1.0 0.0 0.0 1.0 1.0 -1.0 1.0 1.0 -1.0 -1.0 1.0 1.0 slicot-5.0+20101122/examples77/MC03MD.res000077500000000000000000000007121201767322700171430ustar00rootroot00000000000000 MC03MD EXAMPLE PROGRAM RESULTS The polynomial matrix P(x) (of degree 3) is power of x 0 1 2 3 element ( 1, 1) is 9.00 -31.00 37.00 -60.00 element ( 1, 2) is 15.00 41.00 23.00 50.00 element ( 2, 1) is 0.00 38.00 -64.00 -30.00 element ( 2, 2) is -6.00 44.00 100.00 30.00 element ( 3, 1) is 20.00 14.00 -83.00 3.00 element ( 3, 2) is 18.00 33.00 72.00 11.00 slicot-5.0+20101122/examples77/MC03ND.dat000077500000000000000000000006551201767322700171310ustar00rootroot00000000000000 MC03ND EXAMPLE PROGRAM DATA 5 4 2 0.0 2.0 2.0 0.0 3.0 0.0 4.0 0.0 6.0 8.0 8.0 0.0 12.0 0.0 0.0 0.0 0.0 2.0 2.0 0.0 3.0 1.0 0.0 1.0 0.0 0.0 0.0 2.0 0.0 4.0 0.0 4.0 0.0 2.0 2.0 0.0 3.0 3.0 2.0 1.0 3.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0 slicot-5.0+20101122/examples77/MC03ND.res000077500000000000000000000011401201767322700171400ustar00rootroot00000000000000 MC03ND EXAMPLE PROGRAM RESULTS The right nullspace vectors of P(s) are 0.0000 0.0000 0.0000 -0.8321 0.0000 0.1538 0.0000 -1.0000 0.0000 0.5547 0.0000 0.2308 The minimal polynomial basis K(s) (of degree 1) for the right nullspace is power of s 0 1 element ( 1, 1) is 0.00 0.00 element ( 1, 2) is 0.00 0.00 element ( 2, 1) is -0.83 0.00 element ( 2, 2) is 0.00 0.15 element ( 3, 1) is 0.00 0.00 element ( 3, 2) is -1.00 0.00 element ( 4, 1) is 0.55 0.00 element ( 4, 2) is 0.00 0.23 slicot-5.0+20101122/examples77/MD03AD.dat000077500000000000000000000001501201767322700171030ustar00rootroot00000000000000 MD03AD EXAMPLE PROGRAM DATA 15 3 100 0 -1. -1. G D F U 1.0 1.0 1.0 slicot-5.0+20101122/examples77/MD03AD.res000077500000000000000000000003231201767322700171260ustar00rootroot00000000000000 MD03AD EXAMPLE PROGRAM RESULTS Final 2-norm of the residuals = 0.9063596D-01 The number of function and Jacobian evaluations = 13 12 Final approximate solution is 0.0824 1.1330 2.3437 slicot-5.0+20101122/examples77/MD03BD.dat000077500000000000000000000002111201767322700171020ustar00rootroot00000000000000 MD03BD EXAMPLE PROGRAM DATA 15 3 100 5 0 0 1.D2 0 -1. -1. -1. -1. G I E 1.0 1.0 1.0 slicot-5.0+20101122/examples77/MD03BD.res000077500000000000000000000003631201767322700171330ustar00rootroot00000000000000 MD03BD EXAMPLE PROGRAM RESULTS IWARN on exit from MD03BD = 1 Final 2-norm of the residuals = 0.9063596D-01 The number of function and Jacobian evaluations = 6 5 Final approximate solution is 0.0824 1.1330 2.3437 slicot-5.0+20101122/examples77/SB01BD.dat000077500000000000000000000005571201767322700171210ustar00rootroot00000000000000 SB01BD EXAMPLE PROGRAM DATA 4 2 2 -.4 1.E-8 C -6.8000 0.0000 -207.0000 0.0000 1.0000 0.0000 0.0000 0.0000 43.2000 0.0000 0.0000 -4.2000 0.0000 0.0000 1.0000 0.0000 5.6400 0.0000 0.0000 0.0000 0.0000 1.1800 0.0000 0.0000 -0.5000 0.1500 -0.5000 -0.1500 -2.0000 0.0000 -0.4000 0.0000 slicot-5.0+20101122/examples77/SB01BD.res000077500000000000000000000007151201767322700171360ustar00rootroot00000000000000 SB01BD EXAMPLE PROGRAM RESULTS Number of assigned eigenvalues: NAP = 2 Number of fixed eigenvalues: NFP = 2 Number of uncontrollable poles: NUP = 0 The state feedback matrix F is -0.0876 -4.2138 0.0837 -18.1412 -0.0233 18.2483 -0.4259 -4.8120 The eigenvalues of closed-loop matrix A+B*F ( -3.3984, 94.5253 ) ( -3.3984,-94.5253 ) ( -0.5000, 0.1500 ) ( -0.5000, -0.1500 ) NORM(A+B*F - Z*Aout*Z') / (eps*NORM(A)) = 1.03505D+01 slicot-5.0+20101122/examples77/SB01DD.dat000077500000000000000000000004221201767322700171120ustar00rootroot00000000000000 SB01DD EXAMPLE PROGRAM DATA 4 2 0.0 I -1.0 0.0 2.0 -3.0 1.0 -4.0 3.0 -1.0 0.0 2.0 4.0 -5.0 0.0 0.0 -1.0 -2.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 -1.0 -1.0 -1.0 -1.0 0.0 0.0 0.0 0.0 1.0 2.0 2.0 1.0 -1.0 -2.0 3.0 1.0 slicot-5.0+20101122/examples77/SB01DD.res000077500000000000000000000002131201767322700171310ustar00rootroot00000000000000 SB01DD EXAMPLE PROGRAM RESULTS The state feedback matrix G is -5.2339 3.1725 -15.7885 21.7043 -1.6022 0.8504 -5.1914 6.2339 slicot-5.0+20101122/examples77/SB01MD.dat000077500000000000000000000003121201767322700171210ustar00rootroot00000000000000 SB01MD EXAMPLE PROGRAM DATA 4 0.0 I -1.0 0.0 2.0 -3.0 1.0 -4.0 3.0 -1.0 0.0 2.0 4.0 -5.0 0.0 0.0 -1.0 -2.0 1.0 0.0 0.0 0.0 -1.0 -1.0 -1.0 -1.0 0.0 0.0 0.0 0.0 slicot-5.0+20101122/examples77/SB01MD.res000077500000000000000000000001661201767322700171510ustar00rootroot00000000000000 SB01MD EXAMPLE PROGRAM RESULTS The one-dimensional state feedback matrix G is 1.0000 29.0000 93.0000 -76.0000 slicot-5.0+20101122/examples77/SB02MD.dat000077500000000000000000000002161201767322700171250ustar00rootroot00000000000000 SB02MD EXAMPLE PROGRAM DATA 2 C D U N S 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/SB02MD.res000077500000000000000000000001611201767322700171450ustar00rootroot00000000000000 SB02MD EXAMPLE PROGRAM RESULTS RCOND = 0.31 The solution matrix X is 2.0000 1.0000 1.0000 2.0000 slicot-5.0+20101122/examples77/SB02ND.dat000077500000000000000000000002551201767322700171310ustar00rootroot00000000000000 SB02ND EXAMPLE PROGRAM DATA 2 1 3 0.0 D N Z U 2.0 -1.0 1.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 slicot-5.0+20101122/examples77/SB02ND.res000077500000000000000000000002311201767322700171440ustar00rootroot00000000000000 SB02ND EXAMPLE PROGRAM RESULTS The solution matrix X is 1.0000 0.0000 0.0000 1.0000 The optimal feedback matrix F is 2.0000 -1.0000 slicot-5.0+20101122/examples77/SB02OD.dat000077500000000000000000000002711201767322700171300ustar00rootroot00000000000000 SB02OD EXAMPLE PROGRAM DATA 2 1 3 0.0 C B B U Z S 0.0 1.0 0.0 0.0 0.0 1.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/SB02OD.res000077500000000000000000000001421201767322700171460ustar00rootroot00000000000000 SB02OD EXAMPLE PROGRAM RESULTS The solution matrix X is 1.7321 1.0000 1.0000 1.7321 slicot-5.0+20101122/examples77/SB02PD.dat000077500000000000000000000002031201767322700171240ustar00rootroot00000000000000 SB02PD EXAMPLE PROGRAM DATA 2 A N U 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/SB02PD.res000077500000000000000000000003041201767322700171470ustar00rootroot00000000000000 SB02PD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 2.0000 Estimated reciprocal condition number = 0.1333 Estimated error bound = 0.0000000000000063 slicot-5.0+20101122/examples77/SB02QD.dat000077500000000000000000000002161201767322700171310ustar00rootroot00000000000000 SB02QD EXAMPLE PROGRAM DATA 2 B N N U O 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/SB02QD.res000077500000000000000000000003311201767322700171500ustar00rootroot00000000000000 SB02QD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 2.0000 Estimated separation = 0.4000 Estimated reciprocal condition number = 0.1333 Estimated error bound = 0.0000 slicot-5.0+20101122/examples77/SB02RD.dat000077500000000000000000000002461201767322700171350ustar00rootroot00000000000000 SB02RD EXAMPLE PROGRAM DATA 2 A C D N U N S N O 0.0 1.0 0.0 0.0 1.0 0.0 0.0 2.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/SB02RD.res000077500000000000000000000003321201767322700171520ustar00rootroot00000000000000 SB02RD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 2.0000 Estimated separation = 0.4000 Estimated reciprocal condition number = 0.1333 Estimated error bound = 0.0000 slicot-5.0+20101122/examples77/SB02SD.dat000077500000000000000000000002101201767322700171250ustar00rootroot00000000000000 SB02SD EXAMPLE PROGRAM DATA 2 B N N U O 2.0 -1.0 1.0 0.0 0.0 0.0 0.0 1.0 1.0 0.0 0.0 0.0 slicot-5.0+20101122/examples77/SB02SD.res000077500000000000000000000003311201767322700171520ustar00rootroot00000000000000 SB02SD EXAMPLE PROGRAM RESULTS The solution matrix X is -0.7691 1.2496 1.2496 -2.3306 Estimated separation = 0.4456 Estimated reciprocal condition number = 0.1445 Estimated error bound = 0.0000 slicot-5.0+20101122/examples77/SB03MD.dat000077500000000000000000000002541201767322700171300ustar00rootroot00000000000000 SB03MD EXAMPLE PROGRAM DATA 3 D N X N 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples77/SB03MD.res000077500000000000000000000002541201767322700171510ustar00rootroot00000000000000 SB03MD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 1.0000 3.0000 0.0000 1.0000 0.0000 4.0000 Scaling factor = 1.0000 slicot-5.0+20101122/examples77/SB03OD.dat000077500000000000000000000004361201767322700171340ustar00rootroot00000000000000 SB03OD EXAMPLE PROGRAM DATA 4 5 C N N -1.0 37.0 -12.0 -12.0 -1.0 -10.0 0.0 4.0 2.0 -4.0 7.0 -6.0 2.0 2.0 7.0 -9.0 1.0 2.5 1.0 3.5 0.0 1.0 0.0 1.0 -1.0 -2.5 -1.0 -1.5 1.0 2.5 4.0 -5.5 -1.0 -2.5 -4.0 3.5 slicot-5.0+20101122/examples77/SB03OD.res000077500000000000000000000006061201767322700171540ustar00rootroot00000000000000 SB03OD EXAMPLE PROGRAM RESULTS The transpose of the Cholesky factor U is 1.0000 3.0000 1.0000 2.0000 -1.0000 1.0000 -1.0000 1.0000 -2.0000 1.0000 The solution matrix X = op(U)'*op(U) is 1.0000 3.0000 2.0000 -1.0000 3.0000 10.0000 5.0000 -2.0000 2.0000 5.0000 6.0000 -5.0000 -1.0000 -2.0000 -5.0000 7.0000 Scaling factor = 1.0000 slicot-5.0+20101122/examples77/SB03QD.dat000077500000000000000000000002621201767322700171330ustar00rootroot00000000000000 SB03QD EXAMPLE PROGRAM DATA 3 B N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples77/SB03QD.res000077500000000000000000000004431201767322700171550ustar00rootroot00000000000000 SB03QD EXAMPLE PROGRAM RESULTS The solution matrix X is 3.2604 2.7187 1.8616 2.7187 4.4271 0.5699 1.8616 0.5699 6.0461 Scaling factor = 1.0000 Estimated separation = 4.9068 Estimated reciprocal condition number = 0.3611 Estimated error bound = 0.0000 slicot-5.0+20101122/examples77/SB03SD.dat000077500000000000000000000002621201767322700171350ustar00rootroot00000000000000 SB03SD EXAMPLE PROGRAM DATA 3 B N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples77/SB03SD.res000077500000000000000000000004431201767322700171570ustar00rootroot00000000000000 SB03SD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 1.0000 3.0000 0.0000 1.0000 0.0000 4.0000 Scaling factor = 1.0000 Estimated separation = 5.2302 Estimated reciprocal condition number = 0.1832 Estimated error bound = 0.0000 slicot-5.0+20101122/examples77/SB03TD.dat000077500000000000000000000002621201767322700171360ustar00rootroot00000000000000 SB03TD EXAMPLE PROGRAM DATA 3 A N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples77/SB03TD.res000077500000000000000000000004431201767322700171600ustar00rootroot00000000000000 SB03TD EXAMPLE PROGRAM RESULTS The solution matrix X is 3.2604 2.7187 1.8616 2.7187 4.4271 0.5699 1.8616 0.5699 6.0461 Scaling factor = 1.0000 Estimated separation = 4.9068 Estimated reciprocal condition number = 0.3611 Estimated error bound = 0.0000 slicot-5.0+20101122/examples77/SB03UD.dat000077500000000000000000000002621201767322700171370ustar00rootroot00000000000000 SB03UD EXAMPLE PROGRAM DATA 3 A N N U O 3.0 1.0 1.0 1.0 3.0 0.0 0.0 0.0 3.0 25.0 24.0 15.0 24.0 32.0 8.0 15.0 8.0 40.0 slicot-5.0+20101122/examples77/SB03UD.res000077500000000000000000000004431201767322700171610ustar00rootroot00000000000000 SB03UD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 1.0000 1.0000 1.0000 3.0000 0.0000 1.0000 0.0000 4.0000 Scaling factor = 1.0000 Estimated separation = 5.2302 Estimated reciprocal condition number = 0.1832 Estimated error bound = 0.0000 slicot-5.0+20101122/examples77/SB04MD.dat000077500000000000000000000002421201767322700171260ustar00rootroot00000000000000 SB04MD EXAMPLE PROGRAM DATA 3 2 2.0 1.0 3.0 0.0 2.0 1.0 6.0 1.0 2.0 2.0 1.0 1.0 6.0 2.0 1.0 1.0 4.0 0.0 5.0 slicot-5.0+20101122/examples77/SB04MD.res000077500000000000000000000002711201767322700171510ustar00rootroot00000000000000 SB04MD EXAMPLE PROGRAM RESULTS The solution matrix X is -2.7685 0.5498 -1.0531 0.6865 4.5257 -0.4389 The orthogonal matrix Z is -0.9732 -0.2298 0.2298 -0.9732 slicot-5.0+20101122/examples77/SB04ND.dat000077500000000000000000000005651201767322700171370ustar00rootroot00000000000000 SB04ND EXAMPLE PROGRAM DATA 5 3 0.0 U U B 17.0 24.0 1.0 8.0 15.0 23.0 5.0 7.0 14.0 16.0 0.0 6.0 13.0 20.0 22.0 0.0 0.0 19.0 21.0 3.0 0.0 0.0 0.0 2.0 9.0 8.0 1.0 6.0 0.0 5.0 7.0 0.0 9.0 2.0 62.0 -12.0 26.0 59.0 -10.0 31.0 70.0 -6.0 9.0 35.0 31.0 -7.0 36.0 -15.0 7.0 slicot-5.0+20101122/examples77/SB04ND.res000077500000000000000000000003101201767322700171440ustar00rootroot00000000000000 SB04ND EXAMPLE PROGRAM RESULTS The solution matrix X is 0.0000 0.0000 1.0000 1.0000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 2.0000 -2.0000 1.0000 slicot-5.0+20101122/examples77/SB04OD.dat000077500000000000000000000005241201767322700171330ustar00rootroot00000000000000 SB04OD EXAMPLE PROGRAM DATA 3 2 R N D 1.6 -3.1 1.9 -3.8 4.2 2.4 0.5 2.2 -4.5 1.1 0.1 -1.3 -3.1 -2.0 28.9 -5.7 -11.8 12.9 -31.7 2.5 0.1 1.7 -2.5 0.0 0.9 0.1 5.1 -7.3 6.0 2.4 -3.6 2.5 0.5 23.8 -11.0 -10.4 39.5 -74.8 slicot-5.0+20101122/examples77/SB04OD.res000077500000000000000000000011551201767322700171550ustar00rootroot00000000000000 SB04OD EXAMPLE PROGRAM RESULTS The solution matrix L is -0.7538 -1.6210 2.1778 1.7005 -3.5029 2.7961 The solution matrix R is 1.3064 2.7989 0.3698 -5.3376 -0.8767 6.7500 The left transformation matrix P is -0.3093 -0.9502 0.0383 0.9366 -0.2974 0.1851 -0.1645 0.0932 0.9820 The right transformation matrix Q is -0.6097 -0.7920 -0.0314 0.6310 -0.5090 0.5854 0.4796 -0.3371 -0.8102 The left transformation matrix U is -0.8121 0.5835 0.5835 0.8121 The right transformation matrix V is -0.9861 0.1660 0.1660 0.9861 DIF = 0.1147 slicot-5.0+20101122/examples77/SB04PD.dat000077500000000000000000000003061201767322700171320ustar00rootroot00000000000000 SB04PD EXAMPLE PROGRAM DATA 3 2 1 D N N N N 2.0 1.0 3.0 0.0 2.0 1.0 6.0 1.0 2.0 2.0 1.0 1.0 6.0 2.0 1.0 1.0 4.0 0.0 5.0 slicot-5.0+20101122/examples77/SB04PD.res000077500000000000000000000005071201767322700171560ustar00rootroot00000000000000 SB04PD EXAMPLE PROGRAM RESULTS The solution matrix X is -0.3430 0.1995 -0.1856 0.4192 0.6922 -0.2952 Scaling factor = 1.0000 The orthogonal matrix U is 0.5396 -0.7797 0.3178 0.1954 -0.2512 -0.9480 -0.8190 -0.5736 -0.0168 The orthogonal matrix V is -0.9732 -0.2298 0.2298 -0.9732 slicot-5.0+20101122/examples77/SB04QD.dat000077500000000000000000000003531201767322700171350ustar00rootroot00000000000000 SB04QD EXAMPLE PROGRAM DATA 3 3 1.0 2.0 3.0 6.0 7.0 8.0 9.0 2.0 3.0 7.0 2.0 3.0 2.0 1.0 2.0 3.0 4.0 1.0 271.0 135.0 147.0 923.0 494.0 482.0 578.0 383.0 287.0 slicot-5.0+20101122/examples77/SB04QD.res000077500000000000000000000004021201767322700171510ustar00rootroot00000000000000 SB04QD EXAMPLE PROGRAM RESULTS The solution matrix X is 2.0000 3.0000 6.0000 4.0000 7.0000 1.0000 5.0000 3.0000 2.0000 The orthogonal matrix Z is 0.8337 0.5204 -0.1845 0.3881 -0.7900 -0.4746 0.3928 -0.3241 0.8606 slicot-5.0+20101122/examples77/SB04RD.dat000077500000000000000000000010231201767322700171310ustar00rootroot00000000000000 SB04RD EXAMPLE PROGRAM DATA 5 5 0.0 U U B 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 1.0 0.0 2.0 3.0 4.0 5.0 0.0 0.0 6.0 7.0 8.0 0.0 0.0 0.0 9.0 1.0 1.0 2.0 3.0 4.0 5.0 0.0 1.0 2.0 3.0 4.0 0.0 0.0 1.0 2.0 3.0 0.0 0.0 0.0 1.0 -5.0 0.0 0.0 0.0 4.0 1.0 2.0 4.0 10.0 40.0 7.0 6.0 20.0 40.0 74.0 38.0 0.0 2.0 8.0 36.0 2.0 0.0 0.0 6.0 52.0 -9.0 0.0 0.0 0.0 13.0 -43.0 slicot-5.0+20101122/examples77/SB04RD.res000077500000000000000000000004421201767322700171560ustar00rootroot00000000000000 SB04RD EXAMPLE PROGRAM RESULTS The solution matrix X is 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/SB06ND.dat000077500000000000000000000004731201767322700171370ustar00rootroot00000000000000 SB06ND EXAMPLE PROGRAM DATA 5 2 0.0 N N -17.0 24.0 41.0 68.0 15.0 23.0 -35.0 27.0 14.0 16.0 34.0 26.0 -13.0 20.0 22.0 10.0 12.0 19.0 -21.0 63.0 11.0 18.0 25.0 52.0 -29.0 -31.0 14.0 74.0 -69.0 -59.0 16.0 16.0 -25.0 -25.0 36.0 slicot-5.0+20101122/examples77/SB06ND.res000077500000000000000000000002411201767322700171510ustar00rootroot00000000000000 SB06ND EXAMPLE PROGRAM RESULTS The deadbeat feedback matrix F is -0.4819 -0.5782 -2.7595 -3.1093 0.0000 0.2121 -0.4462 0.7698 -1.5421 -0.5773 slicot-5.0+20101122/examples77/SB08CD.dat000077500000000000000000000015251201767322700171250ustar00rootroot00000000000000 SB08CD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/SB08CD.res000077500000000000000000000026541201767322700171520ustar00rootroot00000000000000 SB08CD EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -0.1605 0.0523 0.9423 2.0193 0.4166 0.2518 1.6140 -0.4489 -0.1605 1.7955 3.8719 -0.2394 0.0491 -0.8740 0.0000 0.0000 -12.4245 3.5463 -0.0057 0.0254 -0.0053 0.0000 0.0000 0.0000 -3.5957 -0.0153 -0.0290 -0.0616 0.0000 0.0000 0.0000 0.0000 -13.1627 -1.9835 -3.6182 0.0000 0.0000 0.0000 0.0000 0.0000 -1.4178 5.6218 0.0000 0.0000 0.0000 0.0000 0.0000 -0.8374 -1.4178 The numerator input/state matrix BQ is -1.0157 0.2554 0.5523 0.4443 0.0056 -11.6989 0.0490 4.3728 11.7198 -0.0038 -2.8173 0.0308 3.1018 -0.0009 The numerator state/output matrix CQ is 0.1975 -0.1063 -0.0006 -0.0083 0.1279 0.8797 0.3994 0.8541 -0.4513 -0.0007 -0.0041 0.0305 -0.2562 0.0122 0.4668 0.8826 0.0248 -0.0506 0.0000 0.0022 -0.0017 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -0.1605 0.0523 -0.4489 -0.1605 The denominator input/state matrix BR is -0.0158 -0.0692 -0.1688 0.0306 0.1281 -0.4984 The denominator state/output matrix CR is 0.1975 -0.1063 0.8541 -0.4513 0.4668 0.8826 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/SB08DD.dat000077500000000000000000000015251201767322700171260ustar00rootroot00000000000000 SB08DD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/SB08DD.res000077500000000000000000000025311201767322700171450ustar00rootroot00000000000000 SB08DD EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -1.4178 -5.1682 3.2450 -0.2173 0.0564 -4.1066 -0.2336 0.9109 -1.4178 -2.1262 0.1231 0.0805 -0.4816 0.2196 0.0000 0.0000 -13.1627 0.0608 -0.0218 3.8320 0.3429 0.0000 0.0000 0.0000 -3.5957 -3.3373 0.0816 -4.1237 0.0000 0.0000 0.0000 0.0000 -12.4245 -0.3133 4.4255 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1605 -0.0772 0.0000 0.0000 0.0000 0.0000 0.0000 0.3040 -0.1605 The numerator input/state matrix BQ is 5.0302 -0.0063 0.7078 -0.0409 -11.3663 0.0051 0.1760 0.5879 -0.0265 12.2119 1.1050 0.3215 0.0066 -2.5822 The numerator state/output matrix CQ is -0.8659 0.2787 -0.3432 0.0020 0.0000 0.2325 0.0265 0.0797 -0.3951 0.0976 -0.0292 0.0062 0.8985 0.1406 -0.0165 -0.0645 0.0097 0.8032 -0.1602 0.0874 -0.5630 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -0.1605 -0.0772 0.3040 -0.1605 The denominator input/state matrix BR is 1.1050 0.3215 0.0066 -2.5822 The denominator state/output matrix CR is -0.2288 -0.0259 -0.0070 0.1497 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/SB08ED.dat000077500000000000000000000015321201767322700171250ustar00rootroot00000000000000 SB08ED EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 -1.0 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/SB08ED.res000077500000000000000000000026541201767322700171540ustar00rootroot00000000000000 SB08ED EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -1.0000 0.0526 -0.1408 -0.3060 0.4199 0.2408 1.7274 -0.4463 -1.0000 2.0067 4.3895 0.0062 0.1813 0.0895 0.0000 0.0000 -12.4245 3.5463 -0.0057 0.0254 -0.0053 0.0000 0.0000 0.0000 -3.5957 -0.0153 -0.0290 -0.0616 0.0000 0.0000 0.0000 0.0000 -13.1627 -1.9835 -3.6182 0.0000 0.0000 0.0000 0.0000 0.0000 -1.4178 5.6218 0.0000 0.0000 0.0000 0.0000 0.0000 -0.8374 -1.4178 The numerator input/state matrix BQ is -1.1544 -0.0159 -0.0631 0.5122 0.0056 -11.6989 0.0490 4.3728 11.7198 -0.0038 -2.8173 0.0308 3.1018 -0.0009 The numerator state/output matrix CQ is 0.2238 0.0132 -0.0006 -0.0083 0.1279 0.8797 0.3994 0.9639 0.0643 -0.0007 -0.0041 0.0305 -0.2562 0.0122 -0.0660 0.9962 0.0248 -0.0506 0.0000 0.0022 -0.0017 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -1.0000 0.0526 -0.4463 -1.0000 The denominator input/state matrix BR is -0.2623 -1.1297 0.0764 -0.0155 -0.0752 -1.1676 The denominator state/output matrix CR is 0.2238 0.0132 0.9639 0.0643 -0.0660 0.9962 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/SB08FD.dat000077500000000000000000000015321201767322700171260ustar00rootroot00000000000000 SB08FD EXAMPLE PROGRAM DATA (Continuous system) 7 2 3 -1.0 1.E-10 C -0.04165 0.0000 4.9200 0.4920 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 0.5450 0.0000 0.0000 0.0000 0.0545 0.0000 0.0000 0.0000 0.0000 0.0000 -0.49200 0.004165 0.0000 4.9200 0.0000 0.0000 0.0000 0.0000 0.5210 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 0.0000 0.0000 12.500 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 12.500 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/SB08FD.res000077500000000000000000000025311201767322700171470ustar00rootroot00000000000000 SB08FD EXAMPLE PROGRAM RESULTS The numerator state dynamics matrix AQ is -1.4178 -5.1682 3.2450 -0.2173 0.0564 -3.2129 -3.6183 0.9109 -1.4178 -2.1262 0.1231 0.0805 -0.4392 -0.2528 0.0000 0.0000 -13.1627 0.0608 -0.0218 2.3461 5.8272 0.0000 0.0000 0.0000 -3.5957 -3.3373 1.3622 -3.6083 0.0000 0.0000 0.0000 0.0000 -12.4245 -9.8634 8.1191 0.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 -0.0135 0.0000 0.0000 0.0000 0.0000 0.0000 1.7393 -1.0000 The numerator input/state matrix BQ is 5.0302 -0.0063 0.7078 -0.0409 -11.3663 0.0051 0.1760 0.5879 -0.0265 12.2119 1.0104 1.3262 0.4474 -2.2388 The numerator state/output matrix CQ is -0.8659 0.2787 -0.3432 0.0020 0.0000 0.2026 0.1172 0.0797 -0.3951 0.0976 -0.0292 0.0062 0.7676 0.4879 -0.0165 -0.0645 0.0097 0.8032 -0.1602 0.3050 -0.4812 The numerator input/output matrix DQ is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The denominator state dynamics matrix AR is -1.0000 -0.0135 1.7393 -1.0000 The denominator input/state matrix BR is 1.0104 1.3262 0.4474 -2.2388 The denominator state/output matrix CR is -0.1091 -0.4653 -0.7055 0.4766 The denominator input/output matrix DR is 1.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/SB08MD.dat000077500000000000000000000001001201767322700171230ustar00rootroot00000000000000 SB08MD EXAMPLE PROGRAM DATA 3 A 8.0 -6.0 -3.0 1.0 slicot-5.0+20101122/examples77/SB08MD.res000077500000000000000000000006411201767322700171560ustar00rootroot00000000000000 SB08MD EXAMPLE PROGRAM RESULTS The coefficients of the polynomial B(s) are power of s coefficient 0 64.0000 2 -84.0000 4 21.0000 6 -1.0000 The coefficients of the spectral factor E(s) are power of s coefficient 0 8.0000 1 14.0000 2 7.0000 3 1.0000 RES = 2.7E-15 slicot-5.0+20101122/examples77/SB08ND.dat000077500000000000000000000000711201767322700171330ustar00rootroot00000000000000 SB08ND EXAMPLE PROGRAM DATA 2 A 2.0 4.5 1.0 slicot-5.0+20101122/examples77/SB08ND.res000077500000000000000000000005551201767322700171630ustar00rootroot00000000000000 SB08ND EXAMPLE PROGRAM RESULTS The coefficients of the polynomial B(z) are power of z coefficient 0 25.2500 1 13.5000 2 2.0000 The coefficients of the spectral factor E(z) are power of z coefficient 0 0.5000 1 3.0000 2 4.0000 RES = 4.4E-16 slicot-5.0+20101122/examples77/SB09MD.dat000077500000000000000000000002761201767322700171420ustar00rootroot00000000000000 SB09MD EXAMPLE PROGRAM DATA 2 2 2 0.0 1.3373 0.1205 0.6618 -0.3372 -0.4062 1.6120 0.9299 0.7429 1.1480 -0.1837 0.8843 -0.4947 -0.4616 1.4674 0.6028 0.9524 slicot-5.0+20101122/examples77/SB09MD.res000077500000000000000000000004101201767322700171510ustar00rootroot00000000000000 SB09MD EXAMPLE PROGRAM RESULTS The sum-of-squares matrix SS is 1.9534 1.3027 2.6131 0.6656 The quadratic error matrix SE is 0.0389 0.1565 0.1134 0.0687 The percentage relative error matrix PRE is 14.1125 34.6607 20.8363 32.1262 slicot-5.0+20101122/examples77/SB10DD.dat000077500000000000000000000013311201767322700171120ustar00rootroot00000000000000 SB10DD EXAMPLE PROGRAM DATA 6 5 5 2 2 -0.7 0.0 0.3 0.0 -0.5 -0.1 -0.6 0.2 -0.4 -0.3 0.0 0.0 -0.5 0.7 -0.1 0.0 0.0 -0.8 -0.7 0.0 0.0 -0.5 -1.0 0.0 0.0 0.3 0.6 -0.9 0.1 -0.4 0.5 -0.8 0.0 0.0 0.2 -0.9 -1.0 -2.0 -2.0 1.0 0.0 1.0 0.0 1.0 -2.0 1.0 -3.0 -4.0 0.0 2.0 -2.0 1.0 -2.0 1.0 0.0 -1.0 0.0 1.0 -2.0 0.0 3.0 1.0 0.0 3.0 -1.0 -2.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 0.0 0.0 2.0 0.0 -4.0 0.0 -2.0 1.0 -3.0 0.0 0.0 3.0 1.0 0.0 1.0 -2.0 1.0 0.0 -2.0 1.0 -1.0 -2.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 2.0 -1.0 -3.0 0.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 2.0 1.0 111.294 0.00000001 slicot-5.0+20101122/examples77/SB10DD.res000077500000000000000000000016211201767322700171350ustar00rootroot00000000000000 SB10DD EXAMPLE PROGRAM RESULTS The controller state matrix AK is -18.0030 52.0376 26.0831 -0.4271 -40.9022 18.0857 18.8203 -57.6244 -29.0938 0.5870 45.3309 -19.8644 -26.5994 77.9693 39.0368 -1.4020 -60.1129 26.6910 -21.4163 62.1719 30.7507 -0.9201 -48.6221 21.8351 -0.8911 4.2787 2.3286 -0.2424 -3.0376 1.2169 -5.3286 16.1955 8.4824 -0.2489 -12.2348 5.1590 The controller input matrix BK is 16.9788 14.1648 -18.9215 -15.6726 25.2046 21.2848 20.1122 16.8322 1.4104 1.2040 5.3181 4.5149 The controller output matrix CK is -9.1941 27.5165 13.7364 -0.3639 -21.5983 9.6025 3.6490 -10.6194 -5.2772 0.2432 8.1108 -3.6293 The controller matrix DK is 9.0317 7.5348 -3.4006 -2.8219 The estimated condition numbers are 0.24960D+00 0.98548D+00 0.99186D+00 0.63733D-05 0.48625D+00 0.29430D-01 0.56942D-02 0.12470D-01 slicot-5.0+20101122/examples77/SB10ED.dat000077500000000000000000000013211201767322700171120ustar00rootroot00000000000000 SB10ED EXAMPLE PROGRAM DATA 6 5 5 2 2 -0.7 0.0 0.3 0.0 -0.5 -0.1 -0.6 0.2 -0.4 -0.3 0.0 0.0 -0.5 0.7 -0.1 0.0 0.0 -0.8 -0.7 0.0 0.0 -0.5 -1.0 0.0 0.0 0.3 0.6 -0.9 0.1 -0.4 0.5 -0.8 0.0 0.0 0.2 -0.9 -1.0 -2.0 -2.0 1.0 0.0 1.0 0.0 1.0 -2.0 1.0 -3.0 -4.0 0.0 2.0 -2.0 1.0 -2.0 1.0 0.0 -1.0 0.0 1.0 -2.0 0.0 3.0 1.0 0.0 3.0 -1.0 -2.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 0.0 0.0 2.0 0.0 -4.0 0.0 -2.0 1.0 -3.0 0.0 0.0 3.0 1.0 0.0 1.0 -2.0 1.0 0.0 -2.0 1.0 -1.0 -2.0 0.0 0.0 0.0 1.0 0.0 1.0 0.0 2.0 -1.0 -3.0 0.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 2.0 1.0 0.00000001 slicot-5.0+20101122/examples77/SB10ED.res000077500000000000000000000016031201767322700171360ustar00rootroot00000000000000 SB10ED EXAMPLE PROGRAM RESULTS The controller state matrix AK is -0.0551 -2.1891 -0.6607 -0.2532 0.6674 -1.0044 -1.0379 2.3804 0.5031 0.3960 -0.6605 1.2673 -0.0876 -2.1320 -0.4701 -1.1461 1.2927 -1.5116 -0.1358 -2.1237 -0.9560 -0.7144 0.6673 -0.7957 0.4900 0.0895 0.2634 -0.2354 0.1623 -0.2663 0.1672 -0.4163 0.2871 -0.1983 0.4944 -0.6967 The controller input matrix BK is -0.5985 -0.5464 0.5285 0.6087 -0.7600 -0.4472 -0.7288 -0.6090 0.0532 0.0658 -0.0663 0.0059 The controller output matrix CK is 0.2500 -1.0200 -0.3371 -0.2733 0.2747 -0.4444 0.0654 0.2095 0.0632 0.2089 -0.1895 0.1834 The controller matrix DK is -0.2181 -0.2070 0.1094 0.1159 The estimated condition numbers are 0.10000D+01 0.10000D+01 0.25207D+00 0.83985D-01 0.48628D-02 0.55015D-03 0.49886D+00 slicot-5.0+20101122/examples77/SB10FD.dat000077500000000000000000000013261201767322700171200ustar00rootroot00000000000000 SB10FD EXAMPLE PROGRAM DATA 6 5 5 2 2 -1.0 0.0 4.0 5.0 -3.0 -2.0 -2.0 4.0 -7.0 -2.0 0.0 3.0 -6.0 9.0 -5.0 0.0 2.0 -1.0 -8.0 4.0 7.0 -1.0 -3.0 0.0 2.0 5.0 8.0 -9.0 1.0 -4.0 3.0 -5.0 8.0 0.0 2.0 -6.0 -3.0 -4.0 -2.0 1.0 0.0 2.0 0.0 1.0 -5.0 2.0 -5.0 -7.0 0.0 7.0 -2.0 4.0 -6.0 1.0 1.0 -2.0 -3.0 9.0 -8.0 0.0 5.0 1.0 -2.0 3.0 -6.0 -2.0 1.0 -1.0 2.0 -4.0 0.0 -3.0 -3.0 0.0 5.0 -1.0 1.0 1.0 -7.0 5.0 0.0 -8.0 2.0 -2.0 9.0 -3.0 4.0 0.0 3.0 7.0 0.0 1.0 -2.0 1.0 -6.0 -2.0 1.0 -2.0 -3.0 0.0 0.0 0.0 4.0 0.0 1.0 0.0 5.0 -3.0 -4.0 0.0 1.0 0.0 1.0 0.0 1.0 -3.0 0.0 0.0 1.0 7.0 1.0 15.0 0.00000001 slicot-5.0+20101122/examples77/SB10FD.res000077500000000000000000000024121201767322700171360ustar00rootroot00000000000000 SB10FD EXAMPLE PROGRAM RESULTS The controller state matrix AK is -2.8043 14.7367 4.6658 8.1596 0.0848 2.5290 4.6609 3.2756 -3.5754 -2.8941 0.2393 8.2920 -15.3127 23.5592 -7.1229 2.7599 5.9775 -2.0285 -22.0691 16.4758 12.5523 -16.3602 4.4300 -3.3168 30.6789 -3.9026 -1.3868 26.2357 -8.8267 10.4860 -5.7429 0.0577 10.8216 -11.2275 1.5074 -10.7244 The controller input matrix BK is -0.1581 -0.0793 -0.9237 -0.5718 0.7984 0.6627 0.1145 0.1496 -0.6743 -0.2376 0.0196 -0.7598 The controller output matrix CK is -0.2480 -0.1713 -0.0880 0.1534 0.5016 -0.0730 2.8810 -0.3658 1.3007 0.3945 1.2244 2.5690 The controller matrix DK is 0.0554 0.1334 -0.3195 0.0333 The estimated condition numbers are 0.10000D+01 0.10000D+01 0.11241D-01 0.80492D-03 The real parts of the closed-loop system poles are -0.10731D+03 -0.66556D+02 -0.38269D+02 -0.38269D+02 -0.20089D+02 -0.62557D+01 -0.62557D+01 -0.32405D+01 -0.32405D+01 -0.17178D+01 -0.41466D+01 -0.76437D+01 The imaginary parts of the closed-loop system poles are 0.00000D+00 0.00000D+00 0.13114D+02 -0.13114D+02 0.00000D+00 0.12961D+02 -0.12961D+02 0.67998D+01 -0.67998D+01 0.00000D+00 0.00000D+00 0.00000D+00 slicot-5.0+20101122/examples77/SB10HD.dat000077500000000000000000000013211201767322700171150ustar00rootroot00000000000000 SB10HD EXAMPLE PROGRAM DATA 6 5 5 2 2 -1.0 0.0 4.0 5.0 -3.0 -2.0 -2.0 4.0 -7.0 -2.0 0.0 3.0 -6.0 9.0 -5.0 0.0 2.0 -1.0 -8.0 4.0 7.0 -1.0 -3.0 0.0 2.0 5.0 8.0 -9.0 1.0 -4.0 3.0 -5.0 8.0 0.0 2.0 -6.0 -3.0 -4.0 -2.0 1.0 0.0 2.0 0.0 1.0 -5.0 2.0 -5.0 -7.0 0.0 7.0 -2.0 4.0 -6.0 1.0 1.0 -2.0 -3.0 9.0 -8.0 0.0 5.0 1.0 -2.0 3.0 -6.0 -2.0 1.0 -1.0 2.0 -4.0 0.0 -3.0 -3.0 0.0 5.0 -1.0 1.0 1.0 -7.0 5.0 0.0 -8.0 2.0 -2.0 9.0 -3.0 4.0 0.0 3.0 7.0 0.0 1.0 -2.0 1.0 -6.0 -2.0 0.0 0.0 0.0 -4.0 -1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 1.0 3.0 1.0 0.0 1.0 -3.0 -2.0 0.0 1.0 7.0 1.0 0.00000001 slicot-5.0+20101122/examples77/SB10HD.res000077500000000000000000000017331201767322700171450ustar00rootroot00000000000000 SB10HD EXAMPLE PROGRAM RESULTS The controller state matrix AK is 88.0015 -145.7298 -46.2424 82.2168 -45.2996 -31.1407 25.7489 -31.4642 -12.4198 9.4625 -3.5182 2.7056 54.3008 -102.4013 -41.4968 50.8412 -20.1286 -26.7191 108.1006 -198.0785 -45.4333 70.3962 -25.8591 -37.2741 -115.8900 226.1843 47.2549 -47.8435 -12.5004 34.7474 59.0362 -101.8471 -20.1052 36.7834 -16.1063 -26.4309 The controller input matrix BK is 3.7345 3.4758 -0.3020 0.6530 3.4735 4.0499 4.3198 7.2755 -3.9424 -10.5942 2.1784 2.5048 The controller output matrix CK is -2.3346 3.2556 0.7150 -0.9724 0.6962 0.4074 7.6899 -8.4558 -2.9642 7.0365 -4.2844 0.1390 The controller matrix DK is 0.0000 0.0000 0.0000 0.0000 The estimated condition numbers are 0.23570D+00 0.26726D+00 0.22747D-01 0.21130D-02 slicot-5.0+20101122/examples77/SB10ID.dat000077500000000000000000000007041201767322700171220ustar00rootroot00000000000000 SB10ID EXAMPLE PROGRAM DATA 6 2 3 -1.0 0.0 4.0 5.0 -3.0 -2.0 -2.0 4.0 -7.0 -2.0 0.0 3.0 -6.0 9.0 -5.0 0.0 2.0 -1.0 -8.0 4.0 7.0 -1.0 -3.0 0.0 2.0 5.0 8.0 -9.0 1.0 -4.0 3.0 -5.0 8.0 0.0 2.0 -6.0 -3.0 -4.0 2.0 0.0 -5.0 -7.0 4.0 -6.0 -3.0 9.0 1.0 -2.0 1.0 -1.0 2.0 -4.0 0.0 -3.0 -3.0 0.0 5.0 -1.0 1.0 1.0 -7.0 5.0 0.0 -8.0 2.0 -2.0 1.0 -2.0 0.0 4.0 5.0 -3.0 1.0 slicot-5.0+20101122/examples77/SB10ID.res000077500000000000000000000014601201767322700171430ustar00rootroot00000000000000 SB10ID EXAMPLE PROGRAM RESULTS The controller state matrix AK is -39.0671 9.9293 22.2322 -27.4113 43.8655 -6.6117 3.0006 11.0878 -11.4130 15.4269 33.6805 -6.6934 -23.9953 14.1438 -33.4358 -32.3191 9.7316 25.4033 -24.0473 42.0517 -44.1655 18.7767 34.8873 -42.4369 50.8437 The controller input matrix BK is -10.2905 -16.5382 -10.9782 -4.3598 -8.7525 -5.1447 6.5962 1.8975 6.2316 -9.8770 -14.7041 -11.8778 -9.6726 -22.7309 -18.2692 The controller output matrix CK is -0.6647 -0.0599 -1.0376 0.5619 1.7297 -8.4202 3.9573 7.3094 -7.6283 10.6768 The controller matrix DK is 0.8466 0.4979 -0.6993 -1.2226 -4.8689 -4.5056 The estimated condition numbers are 0.13861D-01 0.90541D-02 slicot-5.0+20101122/examples77/SB10KD.dat000077500000000000000000000006051201767322700171240ustar00rootroot00000000000000 SB10KD EXAMPLE PROGRAM DATA 6 2 2 0.2 0.0 0.3 0.0 -0.3 -0.1 -0.3 0.2 -0.4 -0.3 0.0 0.0 -0.1 0.1 -0.1 0.0 0.0 -0.3 0.1 0.0 0.0 -0.1 -0.1 0.0 0.0 0.3 0.6 0.2 0.1 -0.4 0.2 -0.4 0.0 0.0 0.2 -0.2 -1.0 -2.0 1.0 3.0 -3.0 -4.0 1.0 -2.0 0.0 1.0 1.0 5.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 -1.0 1.1 slicot-5.0+20101122/examples77/SB10KD.res000077500000000000000000000015341201767322700171470ustar00rootroot00000000000000 SB10KD EXAMPLE PROGRAM RESULTS The controller state matrix AK is 0.0337 0.0222 0.0858 0.1264 -0.1872 0.1547 0.4457 0.0668 -0.2255 -0.3204 -0.4548 -0.0691 -0.2419 -0.2506 -0.0982 -0.1321 -0.0130 -0.0838 -0.4402 0.3654 -0.0335 -0.2444 0.6366 -0.6469 -0.3623 0.3854 0.4162 0.4502 0.0065 0.1261 -0.0121 -0.4377 0.0604 0.2265 -0.3389 0.4542 The controller input matrix BK is 0.0931 -0.0269 -0.0872 0.1599 0.0956 -0.1469 -0.1728 0.0129 0.2022 -0.1154 0.2419 -0.1737 The controller output matrix CK is -0.3677 0.2188 0.0403 -0.0854 0.3564 -0.3535 0.1624 -0.0708 0.0058 0.0606 -0.2163 0.1802 The controller matrix DK is -0.0857 -0.0246 0.0460 0.0074 The estimated condition numbers are 0.11269D-01 0.17596D-01 0.18225D+00 0.75968D-03 slicot-5.0+20101122/examples77/SB10ZD.dat000077500000000000000000000007161201767322700171460ustar00rootroot00000000000000 SB10LD EXAMPLE PROGRAM DATA 6 2 3 0.2 0.0 3.0 0.0 -0.3 -0.1 -3.0 0.2 -0.4 -0.3 0.0 0.0 -0.1 0.1 -1.0 0.0 0.0 -3.0 1.0 0.0 0.0 -1.0 -1.0 0.0 0.0 0.3 0.6 2.0 0.1 -0.4 0.2 -4.0 0.0 0.0 0.2 -2.0 -1.0 -2.0 1.0 3.0 -3.0 -4.0 1.0 -2.0 0.0 1.0 1.0 5.0 1.0 -1.0 2.0 -2.0 0.0 -3.0 -3.0 0.0 1.0 -1.0 1.0 -1.0 2.0 4.0 -3.0 0.0 5.0 1.0 10.0 -6.0 -7.0 8.0 2.0 -4.0 1.1 0.0 slicot-5.0+20101122/examples77/SB10ZD.res000077500000000000000000000016771201767322700171760ustar00rootroot00000000000000 SB10ZD EXAMPLE PROGRAM RESULTS The controller state matrix AK is 1.0128 0.5101 -0.1546 1.1300 3.3759 0.4911 -2.1257 -1.4517 -0.4486 0.3493 -1.5506 -1.4296 -1.0930 -0.6026 -0.1344 0.2253 -1.5625 -0.6762 0.3207 0.1698 0.2376 -1.1781 -0.8705 0.2896 0.5017 0.9006 0.0668 2.3613 0.2049 0.3703 1.0787 0.6703 0.2783 -0.7213 0.4918 0.7435 The controller input matrix BK is 0.4132 0.3112 -0.8077 0.2140 0.4253 0.1811 -0.0710 0.0807 0.3558 -0.0121 -0.2019 0.0249 0.1047 0.1399 -0.0457 -0.2542 -0.3472 0.0523 The controller output matrix CK is -0.0372 -0.0456 -0.0040 0.0962 -0.2059 -0.0571 0.1999 0.2994 0.1335 -0.0251 -0.3108 0.2048 The controller matrix DK is 0.0629 -0.0022 0.0363 -0.0228 0.0195 0.0600 The estimated condition numbers are 0.27949D-03 0.66679D-03 0.45677D-01 0.23433D-07 0.68495D-01 0.76854D-01 slicot-5.0+20101122/examples77/SB16AD.dat000077500000000000000000000005351201767322700171220ustar00rootroot00000000000000 SB16AD EXAMPLE PROGRAM DATA (Continuous system) 3 1 1 3 2 0.0 0.1E0 0.0 C S S F I N F -1. 0. 4. 0. 2. 0. 0. 0. -3. 1. 1. 1. 1. 1. 1. 0. -26.4000 6.4023 4.3868 32.0000 0 0 0 8.0000 0 -16 0 0 9.2994 1.1624 0.1090 0 slicot-5.0+20101122/examples77/SB16AD.res000077500000000000000000000007021201767322700171370ustar00rootroot00000000000000 SB16AD EXAMPLE PROGRAM RESULTS The order of reduced controller = 2 The Hankel singular values of weighted ALPHA-stable part are 3.8253 0.2005 The reduced controller state dynamics matrix Ac is 9.1900 0.0000 0.0000 -34.5297 The reduced controller input/state matrix Bc is -11.9593 86.3137 The reduced controller state/output matrix Cc is 2.8955 -1.3566 The reduced controller input/output matrix Dc is 0.0000 slicot-5.0+20101122/examples77/SB16BD.dat000077500000000000000000000021111201767322700171130ustar00rootroot00000000000000 SB16BD EXAMPLE PROGRAM DATA (Continuous system) 8 1 1 4 0.1E0 0.0 C D F L S F 0 1.0000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 -0.0150 0.7650 0 0 0 0 0 0 -0.7650 -0.0150 0 0 0 0 0 0 0 0 -0.0280 1.4100 0 0 0 0 0 0 -1.4100 -0.0280 0 0 0 0 0 0 0 0 -0.0400 1.850 0 0 0 0 0 0 -1.8500 -0.040 0.0260 -0.2510 0.0330 -0.8860 -4.0170 0.1450 3.6040 0.2800 -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026 0.0 4.4721e-002 6.6105e-001 4.6986e-003 3.6014e-001 1.0325e-001 -3.7541e-002 -4.2685e-002 3.2873e-002 4.1089e-001 8.6846e-002 3.8523e-004 -3.6194e-003 -8.8037e-003 8.4205e-003 1.2349e-003 4.2632e-003 slicot-5.0+20101122/examples77/SB16BD.res000077500000000000000000000012011201767322700171330ustar00rootroot00000000000000 SB16BD EXAMPLE PROGRAM RESULTS The order of reduced controller = 4 The Hankel singular values of extended system are: 4.9078 4.8745 3.8455 3.7811 1.2289 1.1785 0.5176 0.1148 The reduced controller state dynamics matrix Ac is 0.5946 -0.7336 0.1914 -0.3368 0.5960 -0.0184 -0.1088 0.0207 1.2253 0.2043 0.1009 -1.4948 -0.0330 -0.0243 1.3440 0.0035 The reduced controller input/state matrix Bc is 0.0015 -0.0202 0.0159 -0.0544 The reduced controller state/output matrix Cc is 0.3534 0.0274 0.0337 -0.0320 The reduced controller input/output matrix Dc is 0.0000 slicot-5.0+20101122/examples77/SB16CD.dat000077500000000000000000000024111201767322700171170ustar00rootroot00000000000000 SB16CD EXAMPLE PROGRAM DATA (Continuous system) 8 1 1 2 0.1E0 C D F R F 0 1.0000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 -0.0150 0.7650 0 0 0 0 0 0 -0.7650 -0.0150 0 0 0 0 0 0 0 0 -0.0280 1.4100 0 0 0 0 0 0 -1.4100 -0.0280 0 0 0 0 0 0 0 0 -0.0400 1.850 0 0 0 0 0 0 -1.8500 -0.040 0.0260 -0.2510 0.0330 -0.8860 -4.0170 0.1450 3.6040 0.2800 -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026 0.0 4.472135954999638e-002 6.610515358414598e-001 4.698598960657579e-003 3.601363251422058e-001 1.032530880771415e-001 -3.754055214487997e-002 -4.268536964759344e-002 3.287284547842979e-002 4.108939884667451e-001 8.684600000000012e-002 3.852317308197148e-004 -3.619366874815911e-003 -8.803722876359955e-003 8.420521094001852e-003 1.234944428038507e-003 4.263205617645322e-003 slicot-5.0+20101122/examples77/SB16CD.res000077500000000000000000000006571201767322700171520ustar00rootroot00000000000000 SB16CD EXAMPLE PROGRAM RESULTS The order of reduced controller = 2 The frequency-weighted Hankel singular values are: 3.3073 0.7274 0.1124 0.0784 0.0242 0.0182 0.0101 0.0094 The reduced controller state dynamics matrix Ac is -0.4334 0.4884 -0.1950 -0.1093 The reduced controller input/state matrix Bc is -0.4231 -0.1785 The reduced controller state/output matrix Cc is -0.0326 -0.2307 slicot-5.0+20101122/examples77/SG02AD.dat000077500000000000000000000003351201767322700171200ustar00rootroot00000000000000 SG02AD EXAMPLE PROGRAM DATA 2 1 3 0.0 C B B U Z N S N 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 1.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/SG02AD.res000077500000000000000000000001421201767322700171350ustar00rootroot00000000000000 SG02AD EXAMPLE PROGRAM RESULTS The solution matrix X is 1.7321 1.0000 1.0000 1.7321 slicot-5.0+20101122/examples77/SG03AD.dat000077500000000000000000000004201201767322700171140ustar00rootroot00000000000000 SG03AD EXAMPLE PROGRAM DATA 3 B C N N U 3.0 1.0 1.0 1.0 3.0 0.0 1.0 0.0 2.0 1.0 3.0 0.0 3.0 2.0 1.0 1.0 0.0 1.0 -64.0 -73.0 -28.0 0.0 -70.0 -25.0 0.0 0.0 -18.0 slicot-5.0+20101122/examples77/SG03AD.res000077500000000000000000000003071201767322700171410ustar00rootroot00000000000000 SG03AD EXAMPLE PROGRAM RESULTS SEP = 0.29D+00 FERR = 0.40D-13 SCALE = 0.10D+01 The solution matrix X is -2.0000 -1.0000 0.0000 -1.0000 -3.0000 -1.0000 0.0000 -1.0000 -3.0000 slicot-5.0+20101122/examples77/SG03BD.dat000077500000000000000000000003211201767322700171150ustar00rootroot00000000000000 SG03BD EXAMPLE PROGRAM DATA 3 1 C N N -1.0 3.0 -4.0 0.0 5.0 -2.0 -4.0 4.0 1.0 2.0 1.0 3.0 2.0 0.0 1.0 4.0 5.0 1.0 2.0 -1.0 7.0 slicot-5.0+20101122/examples77/SG03BD.res000077500000000000000000000002711201767322700171420ustar00rootroot00000000000000 SG03BD EXAMPLE PROGRAM RESULTS SCALE = 1.0000 The Cholesky factor U of the solution matrix is 1.6003 -0.4418 -0.1523 0.0000 0.6795 -0.2499 0.0000 0.0000 0.2041 slicot-5.0+20101122/examples77/TAB01MD.f000077500000000000000000000051341201767322700167070ustar00rootroot00000000000000* AB01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDZ PARAMETER ( LDA = NMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), TAU(NMAX), $ Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB01MD, DORGQR * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( B(I), I = 1,N ) * Find a controllable realization for the given system. CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT ) IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' AB01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01MD = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2,//' The state dynamics matrix A of a controlla', $ 'ble realization is ') 99996 FORMAT (/' The input/state vector B of a controllable realizatio', $ 'n is ',/(1X,F8.4)) 99995 FORMAT (/' The similarity transformation matrix Z is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TAB01ND.f000077500000000000000000000070731201767322700167140ustar00rootroot00000000000000* AB01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX + 3*MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, INDCON, J, M, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK), $ TAU(NMAX), Z(LDZ,NMAX) INTEGER IWORK(LIWORK), NBLK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB01ND, DORGQR * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) * Find a controllable ssr for the given system. CALL AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) ( NBLK(I), I = 1,INDCON ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) INDCON IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, $ INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01ND = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2) 99996 FORMAT (/' The transformed state dynamics matrix of a controllab', $ 'le realization is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' and the dimensions of its diagonal blocks are ', $ /20(1X,I2)) 99993 FORMAT (/' The transformed input/state matrix B of a controllabl', $ 'e realization is ') 99992 FORMAT (/' The controllability index of the transformed system r', $ 'epresentation = ',I2) 99991 FORMAT (/' The similarity transformation matrix Z is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TAB01OD.f000077500000000000000000000054521201767322700167140ustar00rootroot00000000000000* AB01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDU, LDV PARAMETER ( LDA = NMAX, LDB = NMAX, LDU = NMAX, $ LDV = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX + ( NMAX + 3*MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INDCON, INFO, J, M, N, NCONT CHARACTER*1 JOBU, JOBV, STAGES * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK), $ U(LDU,NMAX), V(LDV,MMAX) INTEGER IWORK(LIWORK), KSTAIR(NMAX) * .. External Subroutines .. EXTERNAL AB01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, STAGES, JOBU, JOBV IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) * Reduce the matrices A and B to upper "staircase" form. CALL AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U, $ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) INDCON WRITE ( NOUT, FMT = 99993 ) ( KSTAIR(I), I = 1,INDCON ) END IF END IF END IF STOP * 99999 FORMAT (' AB01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01OD = ',I2) 99997 FORMAT (' The transformed state transition matrix is ') 99996 FORMAT (/' The transformed input matrix is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The number of stairs in the staircase form = ',I3,/) 99993 FORMAT (' The dimensions of the stairs are ',/(20(I3,2X))) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TAB04MD.f000077500000000000000000000062421201767322700167130ustar00rootroot00000000000000* AB04MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA INTEGER I, INFO, J, M, N, P CHARACTER*1 TYPE * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL AB04MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TYPE, ALPHA, BETA IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N ) READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M ) * Transform the parameters (A,B,C,D). CALL AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB04MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB04MD = ',I2) 99997 FORMAT (' The transformed state matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed input matrix is ') 99994 FORMAT (/' The transformed output matrix is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) 99990 FORMAT (/' The transformed input/output matrix is ') END slicot-5.0+20101122/examples77/TAB05MD.f000077500000000000000000000117431201767322700167160ustar00rootroot00000000000000* AB05MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, P1MAX, P2MAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, P1MAX = 20, P2MAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2, LDWORK PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX,LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = P2MAX, LDC1 = P1MAX, LDC2 = P2MAX, $ LDD = P2MAX, LDD1 = P1MAX, LDD2 = P2MAX, $ LDWORK = P1MAX*N1MAX ) * .. Local Scalars .. CHARACTER*1 OVER, UPLO INTEGER I, INFO, J, M1, N, N1, N2, P1, P2 * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,M1MAX), B1(LDB1,M1MAX), B2(LDB2,P1MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,M1MAX), D1(LDD1,M1MAX), D2(LDD2,P1MAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB05MD * .. Executable Statements .. * UPLO = 'Lower' OVER = 'N' WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2, P2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99990 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,P1 ) IF ( P2.LE.0 .OR. P2.GT.P2MAX ) THEN WRITE ( NOUT, FMT = 99988 ) P2 ELSE READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P2 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,P1 ), I = 1,P2 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M1 ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P2 WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P2 WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M1 ) 80 CONTINUE END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05MD = ',I2) 99997 FORMAT (' The state transition matrix of the cascaded system is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the cascaded system is ') 99994 FORMAT (/' The state/output matrix of the cascaded system is ') 99993 FORMAT (/' The input/output matrix of the cascaded system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) 99988 FORMAT (/' P2 is out of range.',/' P2 = ',I5) END slicot-5.0+20101122/examples77/TAB05ND.f000077500000000000000000000112621201767322700167130ustar00rootroot00000000000000* AB05ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, P1MAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, P1MAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = P1MAX, LDC1 = P1MAX, LDC2 = M1MAX, $ LDD = P1MAX, LDD1 = P1MAX, LDD2 = M1MAX ) INTEGER LDWORK PARAMETER ( LDWORK = P1MAX*P1MAX ) DOUBLE PRECISION ONE PARAMETER ( ONE=1.0D0 ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M1, N, N1, N2, P1 DOUBLE PRECISION ALPHA * .. Local Arrays .. INTEGER IWORK(P1MAX) DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,M1MAX), B1(LDB1,M1MAX), B2(LDB2,P1MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,M1MAX), D1(LDD1,M1MAX), D2(LDD2,P1MAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB05ND * .. Executable Statements .. * OVER = 'N' ALPHA = ONE WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99990 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,P1 ) READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,M1 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,P1 ), I = 1,M1 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M1 ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M1 ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05ND = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) END slicot-5.0+20101122/examples77/TAB05OD.f000077500000000000000000000117321201767322700167160ustar00rootroot00000000000000* AB05OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, M2MAX, MMAX, P1MAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, M2MAX = 20, MMAX = M1MAX+M2MAX, $ P1MAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = P1MAX, LDC1 = P1MAX, LDC2 = P1MAX, $ LDD = P1MAX, LDD1 = P1MAX, LDD2 = P1MAX ) DOUBLE PRECISION ONE PARAMETER ( ONE=1.0D0 ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M, M1, M2, N, N1, N2, P1 DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,MMAX), B1(LDB1,M1MAX), B2(LDB2,M2MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,MMAX), D1(LDD1,M1MAX), D2(LDD2,M2MAX) * .. External Subroutines .. EXTERNAL AB05OD * .. Executable Statements .. * OVER = 'N' ALPHA = ONE WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2, M2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99993 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99990 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) IF ( M2.LE.0 .OR. M2.GT.M2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) M2 ELSE READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,M2 ) READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P1 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,M2 ), I = 1,P1 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P1 WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05OD = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) END slicot-5.0+20101122/examples77/TAB05PD.f000077500000000000000000000107511201767322700167170ustar00rootroot00000000000000* AB05PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, MMAX, PMAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ MMAX = 20, PMAX = 20 ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = PMAX, LDC1 = PMAX, LDC2 = PMAX, $ LDD = PMAX, LDD1 = PMAX, LDD2 = PMAX ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M, N, N1, N2, P DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,MMAX), B1(LDB1,MMAX), B2(LDB2,MMAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,MMAX), D1(LDD1,MMAX), D2(LDD2,MMAX) * .. External Subroutines .. EXTERNAL AB05PD * .. Executable Statements .. * OVER = 'N' WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M, P, N2, ALPHA IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M ), I = 1,P ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,M ) READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,M ), I = 1,P ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05PD = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) END slicot-5.0+20101122/examples77/TAB05QD.f000077500000000000000000000125531201767322700167220ustar00rootroot00000000000000* AB05QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER N1MAX, N2MAX, NMAX, M1MAX, M2MAX, MMAX, P1MAX, $ P2MAX, PMAX PARAMETER ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX, $ M1MAX = 20, M2MAX = 20, MMAX = M1MAX+M2MAX, $ P1MAX = 20, P2MAX = 20, PMAX = P1MAX+P2MAX ) INTEGER LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1, $ LDC2, LDD, LDD1, LDD2 PARAMETER ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX, $ LDB = NMAX, LDB1 = N1MAX, LDB2 = N2MAX, $ LDC = PMAX, LDC1 = P1MAX, LDC2 = P1MAX, $ LDD = PMAX, LDD1 = P1MAX, LDD2 = P1MAX ) DOUBLE PRECISION ONE PARAMETER ( ONE=1.0D0 ) * .. Local Scalars .. CHARACTER*1 OVER INTEGER I, INFO, J, M, M1, M2, N, N1, N2, P, P1, P2 * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX), $ B(LDB,MMAX), B1(LDB1,M1MAX), B2(LDB2,M2MAX), $ C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX), $ D(LDD,MMAX), D1(LDD1,M1MAX), D2(LDD2,M2MAX) * .. External Subroutines .. EXTERNAL AB05QD * .. Executable Statements .. * OVER = 'N' WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N1, M1, P1, N2, M2, P2 IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) N1 ELSE READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 ) IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN WRITE ( NOUT, FMT = 99991 ) M1 ELSE READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 ) IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN WRITE ( NOUT, FMT = 99990 ) P1 ELSE READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 ) READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 ) IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN WRITE ( NOUT, FMT = 99989 ) N2 ELSE READ ( NIN, FMT = * ) $ ( ( A2(I,J), J = 1,N2 ), I = 1,N2 ) IF ( M2.LE.0 .OR. M2.GT.M2MAX ) THEN WRITE ( NOUT, FMT = 99988 ) M2 ELSE READ ( NIN, FMT = * ) $ ( ( B2(I,J), I = 1,N2 ), J = 1,M2 ) IF ( P2.LE.0 .OR. P2.GT.P2MAX ) THEN WRITE ( NOUT, FMT = 99987 ) P2 ELSE READ ( NIN, FMT = * ) $ ( ( C2(I,J), J = 1,N2 ), I = 1,P2 ) READ ( NIN, FMT = * ) $ ( ( D2(I,J), J = 1,M2 ), I = 1,P2 ) * Find the state-space model (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) $ ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05QD = ',I2) 99997 FORMAT (' The state transition matrix of the connected system is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the connected system is ') 99994 FORMAT (/' The state/output matrix of the connected system is ') 99993 FORMAT (/' The input/output matrix of the connected system is ') 99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5) 99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5) 99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5) 99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5) 99988 FORMAT (/' M2 is out of range.',/' M2 = ',I5) 99987 FORMAT (/' P2 is out of range.',/' P2 = ',I5) END slicot-5.0+20101122/examples77/TAB05RD.f000077500000000000000000000131311201767322700167140ustar00rootroot00000000000000* AB05RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, MVMAX, PMAX, PZMAX PARAMETER ( NMAX = 20, MMAX = 20, MVMAX = 20, $ PMAX = 20, PZMAX = 20 ) INTEGER LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, LDF, LDG, $ LDH, LDK, LDWORK, LIWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDBC = NMAX, $ LDC = PMAX, LDCC = PZMAX, $ LDD = PMAX, LDDC = PZMAX, LDF = MMAX, $ LDG = MMAX, LDH = PZMAX, LDK = MMAX, $ LDWORK = ( MMAX + PMAX*MVMAX + $ PMAX*PMAX + 4*PMAX ), LIWORK = 2*PMAX ) * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. Local Scalars .. LOGICAL LJOBD, OUTPF CHARACTER*1 FBTYPE, JOBD INTEGER I, INFO, J, M, MV, N, P, PZ DOUBLE PRECISION ALPHA, BETA, RCOND * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), BC(LDBC,MVMAX), $ C(LDC,NMAX), CC(LDCC,NMAX), $ D(LDD,MMAX), DC(LDDC,MVMAX), DWORK(LDWORK), $ F(LDF,PMAX), G(LDG,MVMAX), H(LDH,PMAX), $ K(LDK,NMAX) * .. External functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB05RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, MV, PZ, ALPHA, BETA, FBTYPE, JOBD OUTPF = LSAME( FBTYPE, 'O' ) LJOBD = LSAME( JOBD, 'D' ) IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( BETA.NE.ZERO ) $ READ ( NIN, FMT = * ) ( ( K(I,J), J = 1,N ), I = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LJOBD ) $ READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF ( OUTPF.AND.ALPHA.NE.ZERO ) $ READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,P ), I = 1,M ) IF ( MV.LE.0 .OR. MV.GT.MVMAX ) THEN WRITE ( NOUT, FMT = 99989 ) MV ELSE READ ( NIN, FMT = * ) $ ( ( G(I,J), J = 1,MV ), I = 1,M ) IF ( PZ.LE.0 .OR. PZ.GT.PZMAX ) THEN WRITE ( NOUT, FMT = 99988 ) PZ ELSE READ ( NIN, FMT = * ) $ ( ( H(I,J), J = 1,P ), I = 1,PZ ) * Find the state-space model (A,B,C,D). CALL 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 ) * WRITE ( NOUT, FMT = 99987 ) RCOND IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) $ ( BC(I,J), J = 1,MV ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, PZ WRITE ( NOUT, FMT = 99996 ) $ ( CC(I,J), J = 1,N ) 60 CONTINUE IF ( LJOBD ) THEN WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, PZ WRITE ( NOUT, FMT = 99996 ) $ ( DC(I,J), J = 1,MV ) 80 CONTINUE END IF END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB05RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB05RD = ',I2) 99997 FORMAT (' The state transition matrix of the closed-loop system is $') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the closed-loop system is ') 99994 FORMAT (/' The state/output matrix of the closed-loop system is ') 99993 FORMAT (/' The input/output matrix of the closed-loop system is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) 99989 FORMAT (/' MV is out of range.',/' MV = ',I5) 99988 FORMAT (/' PZ is out of range.',/' PZ = ',I5) 99987 FORMAT ( ' The reciprocal condition number of the matrix ', $ ' I - alpha*D*F is',F8.4,/1X) END slicot-5.0+20101122/examples77/TAB07MD.f000077500000000000000000000063341201767322700167200ustar00rootroot00000000000000* AB07MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP ) * .. Local Scalars .. CHARACTER*1 JOBD INTEGER I, INFO, J, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP) * .. External functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB07MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBD IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the dual of the ssr (A,B,C,D). CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, $ LDD, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,P ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE IF ( LSAME( JOBD, 'D' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,P ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB07MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB07MD = ',I2) 99997 FORMAT (' The dual state dynamics matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The dual input/state matrix is ') 99994 FORMAT (/' The dual state/output matrix is ') 99993 FORMAT (/' The dual direct transmission matrix is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TAB07ND.f000077500000000000000000000056211201767322700167170ustar00rootroot00000000000000* AB07ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MMAX, $ LDD = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 4*MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N DOUBLE PRECISION RCOND * .. Local Arrays .. INTEGER IWORK(2*MMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB07ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,M ) * Find the inverse of the ssr (A,B,C,D). CALL AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND, $ IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' AB07ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB07ND = ',I2) 99997 FORMAT (' The state dynamics matrix of the inverse system is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix of the inverse system is ') 99994 FORMAT (/' The state/output matrix of the inverse system is ') 99993 FORMAT (/' The feedthrough matrix of the inverse system is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TAB08ND.f000077500000000000000000000214021201767322700167130ustar00rootroot00000000000000* AB08ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER MPMAX PARAMETER ( MPMAX = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDAF, LDBF, LDQ, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDAF = NMAX+MPMAX, $ LDBF = NMAX+PMAX, LDQ = 1, LDZ = 1 ) INTEGER LDWORK PARAMETER ( LDWORK = ( ( MPMAX+1 + NMAX ) + $ ( 3*(MPMAX+1) + NMAX+MPMAX ) + $ 8*NMAX ) ) * PARAMETER ( LDWORK = 10*NMAX + 5*MPMAX + 4 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, II, J, M, N, NINFZ, NKROL, NKROR, $ NU, P, RANK CHARACTER*1 EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AF(LDAF,NMAX+PMAX), ALFI(NMAX), $ ALFR(NMAX), B(LDB,MMAX), BETA(NMAX), $ BF(LDBF,MMAX+NMAX), C(LDC,NMAX), D(LDD,MMAX), $ DWORK(LDWORK), Q(LDQ,1), Z(LDZ,1) INTEGER INFZ(NMAX), IWORK(MPMAX+1), KRONL(NMAX+1), $ KRONR(NMAX+1), LINFZ(NMAX) * .. External Subroutines .. EXTERNAL AB08ND, DGEGV * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AB08ND( EQUIL, N, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99993 ) ELSE WRITE ( NOUT, FMT = 99992 ) N - NU WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 20 CONTINUE END IF END IF * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AB08ND( EQUIL, N, M, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99987 ) ELSE WRITE ( NOUT, FMT = 99986 ) N - NU WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 40 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 40 CONTINUE END IF END IF * Compute the structural invariants of the given system. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99984 ) NU IF ( NU.GT.0 ) THEN * Compute the invariant zeros of the given system. * Workspace: need 8*NU. WRITE ( NOUT, FMT = 99983 ) CALL DGEGV( 'No vectors', 'No vectors', NU, AF, $ LDAF, BF, LDBF, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 60 I = 1, NU IF ( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 60 CONTINUE WRITE ( NOUT, FMT = 99982 ) END IF END IF NINFZ = 0 II = 1 DO 100 I = 1, N IF ( INFZ(I).GT.0 ) THEN NINFZ = NINFZ + INFZ(I) DO 80 J = 1, INFZ(I) LINFZ(II) = I II = II + 1 80 CONTINUE END IF 100 CONTINUE WRITE ( NOUT, FMT = 99978 ) NINFZ IF ( NINFZ.GT.0 ) $ WRITE ( NOUT, FMT = 99977 ) $ ( LINFZ(I), I = 1,NINFZ ) WRITE ( NOUT, FMT = 99976 ) NKROR IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AB08ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB08ND = ',I2) 99997 FORMAT (' INFO on exit from DGEGV = ',I2) 99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X))) 99993 FORMAT (/' The system (A,C) is completely observable ') 99992 FORMAT (/' The dimension of the observable subspace = ',I3) 99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th', $ 'e matrix AF. ') 99990 FORMAT (/' The matrix AF is ') 99989 FORMAT (20(1X,F8.4)) 99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X) $ )) 99987 FORMAT (/' The system (A,B) is completely controllable ') 99986 FORMAT (/' The dimension of the controllable subspace = ',I3) 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' matrix AF. ') 99984 FORMAT (//' The number of finite invariant zeros = ',I3) 99983 FORMAT (/' The finite invariant zeros are ') 99982 FORMAT (/' which correspond to the generalized eigenvalues of (l', $ 'ambda*BF - AF).') 99981 FORMAT (/' real part imag part ') 99980 FORMAT (1X,F9.4) 99979 FORMAT (1X,F9.4,6X,F9.4) 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT (/' The orders of the infinite zeros are ',/(20(I3,2X))) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TAB08NZ.f000077500000000000000000000207731201767322700167530ustar00rootroot00000000000000* AB08NZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER MPMAX PARAMETER ( MPMAX = MMAX + PMAX ) INTEGER LDA, LDB, LDC, LDD, LDAF, LDBF, LDQ, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDAF = NMAX+MPMAX, $ LDBF = NMAX+PMAX, LDQ = 1, LDZ = 1 ) INTEGER LDWORK PARAMETER ( LDWORK = 8*NMAX ) INTEGER LZWORK PARAMETER ( LZWORK = 6*PMAX + 4*MMAX + 2*NMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, II, J, M, N, NINFZ, NKROL, NKROR, $ NU, P, RANK CHARACTER*1 EQUIL * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), AF(LDAF,NMAX+PMAX), ALPHA(NMAX), $ B(LDB,MMAX), BETA(NMAX), BF(LDBF,MMAX+NMAX), $ C(LDC,NMAX), D(LDD,MMAX), Q(LDQ,1), Z(LDZ,1), $ ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK) INTEGER INFZ(NMAX), IWORK(MPMAX+1), KRONL(NMAX+1), $ KRONR(NMAX+1), LINFZ(NMAX) * .. External Subroutines .. EXTERNAL AB08NZ, ZGEGV * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AB08NZ( EQUIL, N, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99993 ) ELSE WRITE ( NOUT, FMT = 99992 ) N - NU WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 20 CONTINUE END IF END IF * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AB08NZ( EQUIL, N, M, 0, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M ) IF ( NU.EQ.0 ) THEN WRITE ( NOUT, FMT = 99987 ) ELSE WRITE ( NOUT, FMT = 99986 ) N - NU WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 40 I = 1, NU WRITE ( NOUT, FMT = 99989 ) $ ( AF(I,J), J = 1,NU ) 40 CONTINUE END IF END IF * Compute the structural invariants of the given system. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99984 ) NU IF ( NU.GT.0 ) THEN * Compute the invariant zeros of the given system. * Complex Workspace: need 2*NU. * Real Workspace: need 8*NU. WRITE ( NOUT, FMT = 99983 ) CALL ZGEGV( 'No vectors', 'No vectors', NU, AF, $ LDAF, BF, LDBF, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 60 I = 1, NU WRITE ( NOUT, FMT = 99980 ) ALPHA(I)/BETA(I) 60 CONTINUE WRITE ( NOUT, FMT = 99982 ) END IF END IF NINFZ = 0 II = 1 DO 100 I = 1, N IF ( INFZ(I).GT.0 ) THEN NINFZ = NINFZ + INFZ(I) DO 80 J = 1, INFZ(I) LINFZ(II) = I II = II + 1 80 CONTINUE END IF 100 CONTINUE WRITE ( NOUT, FMT = 99978 ) NINFZ IF ( NINFZ.GT.0 ) $ WRITE ( NOUT, FMT = 99977 ) $ ( LINFZ(I), I = 1,NINFZ ) WRITE ( NOUT, FMT = 99976 ) NKROR IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AB08NZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB08NZ = ',I2) 99997 FORMAT (' INFO on exit from ZGEGV = ',I2) 99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X))) 99993 FORMAT (/' The system (A,C) is completely observable ') 99992 FORMAT (/' The dimension of the observable subspace = ',I3) 99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th', $ 'e matrix AF. ') 99990 FORMAT (/' The matrix AF is ') 99989 FORMAT (20(1X,F9.4,SP,F9.4,S,'i ')) 99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X) $ )) 99987 FORMAT (/' The system (A,B) is completely controllable ') 99986 FORMAT (/' The dimension of the controllable subspace = ',I3) 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' matrix AF. ') 99984 FORMAT (//' The number of finite invariant zeros = ',I3) 99983 FORMAT (/' The finite invariant zeros are ') 99982 FORMAT (/' which correspond to the generalized eigenvalues of (l', $ 'ambda*BF - AF).') 99981 FORMAT (/' real part imag part ') 99980 FORMAT (1X,F9.4,SP,F9.4,S,'i ') 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT (/' The orders of the infinite zeros are ',/(20(I3,2X))) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ', $ /(20(I3,2X))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TAB09AD.f000077500000000000000000000066121201767322700167050ustar00rootroot00000000000000* AB09AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + 5 + $ ( NMAX + MMAX + PMAX ) ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NR, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, TOL, DICO, JOB, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, $ A, LDA, B, LDB, C, LDC, HSV, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09AD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values HSV are') END slicot-5.0+20101122/examples77/TAB09BD.f000077500000000000000000000075211201767322700167060ustar00rootroot00000000000000* AB09BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + 5 + $ ( NMAX + MMAX + PMAX ) ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09BD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, TOL1, TOL2, DICO, JOB, EQUIL, $ ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09BD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values are') END slicot-5.0+20101122/examples77/TAB09CD.f000077500000000000000000000100421201767322700166770ustar00rootroot00000000000000* AB09CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( NMAX + MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*( 2*NMAX + $ ( NMAX + MMAX + PMAX ) + 5 ) + $ ( NMAX*( NMAX + 1 ) )/2 + $ NMAX*( MMAX + PMAX + 2 ) + $ 2*MMAX*PMAX + $ ( NMAX + MMAX ) + ( 3*MMAX + 1 + $ ( NMAX + MMAX ) + PMAX ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, P CHARACTER*1 DICO, EQUIL, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09CD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, TOL1, TOL2, DICO, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, $ A, LDA, B, LDB, C, LDC, D, LDD, HSV, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09CD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values are') END slicot-5.0+20101122/examples77/TAB09DD.f000077500000000000000000000066211201767322700167100ustar00rootroot00000000000000* AB09DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX ) * .. Local Scalars .. DOUBLE PRECISION RCOND INTEGER I, INFO, J, M, N, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09DD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, $ D, LDD, RCOND, IWORK, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RCOND IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09DD = ',I2) 99997 FORMAT (' The computed reciprocal condition number = ',1PD12.5) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TAB09ED.f000077500000000000000000000102641201767322700167070ustar00rootroot00000000000000* AB09ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( NMAX + MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*( 2*NMAX + $ ( NMAX + MMAX + PMAX ) + $ 5 ) + ( NMAX*( NMAX + 1 ) )/2 + $ NMAX*( MMAX + PMAX + 2 ) + $ 2*MMAX*PMAX + ( NMAX + MMAX ) + $ ( 3*MMAX + 1 + ( NMAX + MMAX ) + $ PMAX ) ) ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09ED * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, $ DICO, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09ED = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are') END slicot-5.0+20101122/examples77/TAB09FD.f000077500000000000000000000070661201767322700167160ustar00rootroot00000000000000* AB09FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( NMAX + MMAX + PMAX ) ) * The formula below uses that NMAX = MMAX = PMAX. INTEGER LDWORK PARAMETER ( LDWORK = 10*NMAX*NMAX + 5*NMAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09FD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, $ DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) * Find a reduced ssr for (A,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NQ ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09FD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of coprime factors are') END slicot-5.0+20101122/examples77/TAB09GD.f000077500000000000000000000076751201767322700167250ustar00rootroot00000000000000* AB09GD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*NMAX + MMAX + PMAX ) ) * The formula below uses that NMAX = MMAX = PMAX. INTEGER LDWORK PARAMETER ( LDWORK = 10*NMAX*NMAX + 5*NMAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3 INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09GD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, TOL3, $ DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NQ ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09GD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09GD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of coprime factors are') END slicot-5.0+20101122/examples77/TAB09HD.f000077500000000000000000000102441201767322700167100ustar00rootroot00000000000000* AB09HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LBWORK, LIWORK PARAMETER ( LBWORK = 2*NMAX, LIWORK = 2*NMAX ) INTEGER LDWORK, MBMAX PARAMETER ( MBMAX = MMAX + PMAX ) PARAMETER ( LDWORK = 2*NMAX*NMAX + MBMAX*(NMAX+PMAX) + $ ( NMAX*(( NMAX + MMAX + PMAX ) + 5) + $ 2*NMAX*PMAX + ( PMAX*(MBMAX+2 ) + $ 10*NMAX*(NMAX+1) ) ) ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) LOGICAL BWORK(LBWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09HD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, BETA, TOL1, TOL2, $ DICO, JOB, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09HD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The stochastic Hankel singular values of ALPHA-stable' $ ,' part are') END slicot-5.0+20101122/examples77/TAB09ID.f000077500000000000000000000220621201767322700167120ustar00rootroot00000000000000* AB09ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, MWMAX, NMAX, NVMAX, NWMAX, PMAX, PVMAX PARAMETER ( MMAX = 20, MWMAX = 20, $ NMAX = 20, NVMAX = 20, NWMAX = 20, $ PMAX = 20, PVMAX = 20 ) INTEGER LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW PARAMETER ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX, $ LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX, $ LDC = PMAX, LDCV = PVMAX, LDCW = MMAX, $ LDD = PMAX, LDDV = PVMAX, LDDW = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*NMAX + $ NVMAX + ( PMAX + PVMAX ) + $ NWMAX + ( MMAX + MWMAX ) ) ) INTEGER LDW1, LDW2, LDW3, LDW4, LDW5, LDW6, LDW7, LDW8, $ LDWORK PARAMETER ( LDW1 = NMAX + NVMAX, LDW2 = NMAX + NWMAX, $ LDW3 = ( LDW1*( LDW1 + ( LDW1 + PVMAX ) + $ 5 ) + NMAX*( PMAX + 5 ) ), $ LDW4 = ( LDW2*( LDW2 + ( LDW2 + MWMAX ) + $ 5 ) + NMAX*( MMAX + 5 ) ), $ LDW5 = PVMAX*( NVMAX + PVMAX ) + PVMAX*NVMAX + $ ( NVMAX*( NVMAX + 5 ) + 4*PVMAX + $ PVMAX*( PVMAX + 2 ) + 4*PMAX ), $ LDW6 = ( PMAX + PVMAX )*( 2*NVMAX + $ ( PMAX + PVMAX ) ) + $ ( LDW5 + NVMAX + $ ( NVMAX + 3*PMAX + 3*PVMAX ) $ ), $ LDW7 = ( NWMAX + ( NWMAX + 3*MMAX ) + $ 2*NWMAX*( MMAX + MWMAX ) + $ NWMAX + ( NWMAX + 3*MMAX + $ 3*MWMAX ) ), $ LDW8 = MWMAX*( NWMAX + MWMAX ) + $ ( NWMAX*( NWMAX + 5 ) + 4*MWMAX + $ MWMAX*( MWMAX + 2 ) + 4*MMAX ) ) PARAMETER ( LDWORK = ( LDW6 + LDW7 + LDW8 + $ 2*NMAX*NMAX + $ ( 1 + LDW3 + LDW4 + $ 2*NMAX*NMAX + 5*NMAX + $ NMAX*( MMAX + PMAX ) ) ) $ ) * .. Local Scalars .. LOGICAL LEFTW, RIGHTW DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, MW, N, NR, NS, NV, NW, P, $ PV CHARACTER*1 DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX), $ B(LDB,MMAX), BV(LDBV,PMAX), BW(LDBW,MWMAX), $ C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX), $ D(LDD,MMAX), DV(LDDV,PMAX), DW(LDDW,MWMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB09ID * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NV, PV, NW, MW, NR, $ ALPHA, ALPHAC, ALPHAO, TOL1, TOL2, $ DICO, JOBC, JOBO, JOB, WEIGHT, $ EQUIL, ORDSEL LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( LEFTW ) THEN IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NV ELSE IF( NV.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AV(I,J), J = 1,NV ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( BV(I,J), J = 1,P ), I = 1,NV ) IF( PV.LE.0 .OR. PV.GT.PVMAX ) THEN WRITE ( NOUT, FMT = 99985 ) PV ELSE READ ( NIN, FMT = * ) $ ( ( CV(I,J), J = 1,NV ), I = 1,PV ) END IF END IF IF( PV.LE.0 .OR. PV.GT.PVMAX ) THEN WRITE ( NOUT, FMT = 99985 ) PV ELSE READ ( NIN, FMT = * ) $ ( ( DV(I,J), J = 1,P ), I = 1,PV ) END IF END IF END IF IF( RIGHTW ) THEN IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN WRITE ( NOUT, FMT = 99984 ) NW ELSE IF( NW.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AW(I,J), J = 1,NW ), I = 1,NW ) IF( MW.LE.0 .OR. MW.GT.MWMAX ) THEN WRITE ( NOUT, FMT = 99983 ) MW ELSE READ ( NIN, FMT = * ) $ ( ( BW(I,J), J = 1,MW ), I = 1,NW ) END IF READ ( NIN, FMT = * ) $ ( ( CW(I,J), J = 1,NW ), I = 1,M ) END IF IF( MW.LE.0 .OR. MW.GT.MWMAX ) THEN WRITE ( NOUT, FMT = 99983 ) MW ELSE READ ( NIN, FMT = * ) $ ( ( DW(I,J), J = 1,MW ), I = 1,M ) END IF END IF END IF * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99982 ) IWARN WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09ID = ',I2) 99997 FORMAT (/' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NV is out of range.',/' NV = ',I5) 99985 FORMAT (/' PV is out of range.',/' PV = ',I5) 99984 FORMAT (/' NW is out of range.',/' NW = ',I5) 99983 FORMAT (/' MW is out of range.',/' MW = ',I5) 99982 FORMAT (' IWARN on exit from AB09ID = ',I2) END slicot-5.0+20101122/examples77/TAB09JD.f000077500000000000000000000175161201767322700167230ustar00rootroot00000000000000* AB09JD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, NVMAX, NVPMAX, NWMAX, NWMMAX, PMAX PARAMETER ( MMAX = 20, NMAX = 20, NVMAX = 10, NWMAX = 10, $ PMAX = 20, NVPMAX = NVMAX + PMAX, $ NWMMAX = NWMAX + MMAX ) INTEGER LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW PARAMETER ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX, $ LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX, $ LDC = PMAX, LDCV = PMAX, LDCW = MMAX, $ LDD = PMAX, LDDV = PMAX, LDDW = MMAX ) INTEGER LIW1, LIW2, LIW3, LIWORK PARAMETER ( LIW1 = 2*( MMAX + PMAX ), $ LIW2 = ( NVPMAX + NWMMAX ) + NMAX + 6, $ LIW3 = ( 2*NVMAX + PMAX + 2 + $ 2*NWMAX + MMAX + 2 ) ) PARAMETER ( LIWORK = ( LIW1 + LIW2 + LIW3 ) ) INTEGER LDW1, LDW2, LDW3, LDW4, LDWORK PARAMETER ( LDW1 = 2*NVPMAX*( NVPMAX + PMAX ) + PMAX*PMAX + $ ( 2*NVPMAX*NVPMAX + $ ( 11*NVPMAX + 16 + PMAX*NVPMAX ) + $ NVPMAX*NMAX + $ ( NVPMAX*NMAX + NMAX*NMAX + $ PMAX*NMAX + PMAX*MMAX ) ) ) PARAMETER ( LDW2 = 2*NWMMAX*( NWMMAX + MMAX ) + MMAX*MMAX + $ ( 2*NWMMAX*NWMMAX + $ ( 11*NWMMAX + 16 + MMAX*NWMMAX ) + $ NWMMAX*NMAX + $ ( NWMMAX*NMAX + NMAX*NMAX + $ MMAX*NMAX + PMAX*MMAX ) ) ) PARAMETER ( LDW3 = NMAX*( 2*NMAX + ( NMAX + MMAX + PMAX ) $ + 5 ) + ( NMAX*( NMAX + 1 ) )/2 ) PARAMETER ( LDW4 = NMAX*( MMAX + PMAX + 2 ) + 2*MMAX*PMAX + $ ( NMAX + MMAX ) + $ ( 3*MMAX + 1 + ( NMAX + MMAX ) + PMAX )) PARAMETER ( LDWORK = ( 1 + LDW1 + LDW2 + LDW3 + LDW4 ) ) * .. Local Scalars .. LOGICAL LEFTW, RIGHTW DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, NV, NW, P CHARACTER*1 DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX), $ B(LDB,MMAX), BV(LDBV,PMAX), BW(LDBW,MMAX), $ C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX), $ D(LDD,MMAX), DV(LDDV,PMAX), DW(LDDW,MMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB09JD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NV, NW, NR, ALPHA, TOL1, TOL2, $ JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL LEFTW = .NOT.LSAME( JOBV, 'N' ) RIGHTW = .NOT.LSAME( JOBW, 'N' ) IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( LEFTW ) THEN IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NV ELSE IF( NV.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AV(I,J), J = 1,NV ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( BV(I,J), J = 1,P ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( CV(I,J), J = 1,NV ), I = 1,P ) END IF IF( LEFTW ) $ READ ( NIN, FMT = * ) $ ( ( DV(I,J), J = 1,P ), I = 1,P ) END IF END IF IF( RIGHTW ) THEN IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN WRITE ( NOUT, FMT = 99985 ) NW ELSE IF( NW.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AW(I,J), J = 1,NW ), I = 1,NW ) READ ( NIN, FMT = * ) $ ( ( BW(I,J), J = 1,M ), I = 1,NW ) READ ( NIN, FMT = * ) $ ( ( CW(I,J), J = 1,NW ), I = 1,M ) END IF READ ( NIN, FMT = * ) $ ( ( DW(I,J), J = 1,M ), I = 1,M ) END IF END IF * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99994 ) IWARN WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09JD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09JD = ',I2) 99997 FORMAT (/' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' IWARN on exit from AB09JD = ',I2) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NV is out of range.',/' NV = ',I5) 99985 FORMAT (/' NW is out of range.',/' NW = ',I5) END slicot-5.0+20101122/examples77/TAB09KD.f000077500000000000000000000157471201767322700167300ustar00rootroot00000000000000* AB09KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, NVMAX, NWMAX, PMAX PARAMETER ( MMAX = 20, NMAX = 20, NVMAX = 10, NWMAX = 10, $ PMAX = 20 ) INTEGER LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW PARAMETER ( LDA = NMAX, LDAV = NVMAX, LDAW = NWMAX, $ LDB = NMAX, LDBV = NVMAX, LDBW = NWMAX, $ LDC = PMAX, LDCV = PMAX, LDCW = MMAX, $ LDD = PMAX, LDDV = PMAX, LDDW = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*( MMAX + PMAX ) ) INTEGER LDW1, LDW2, LDW3, LDW4, LDWORK PARAMETER ( LDW1 = ( NVMAX*( NVMAX + 5 ) + NVMAX*NMAX + $ ( 2*NVMAX + PMAX*NMAX + PMAX*MMAX ) )) PARAMETER ( LDW2 = ( NWMAX*( NWMAX + 5 ) + NWMAX*NMAX + $ ( 2*NWMAX + MMAX*NMAX + PMAX*MMAX ) )) PARAMETER ( LDW3 = NMAX*( 2*NMAX + ( NMAX + MMAX + PMAX ) $ + 5 ) + ( NMAX*( NMAX + 1 ) )/2 ) PARAMETER ( LDW4 = NMAX*( MMAX + PMAX + 2 ) + 2*MMAX*PMAX + $ ( NMAX + MMAX ) + $ ( 3*MMAX + 1 + ( NMAX + MMAX ) + PMAX )) PARAMETER ( LDWORK = ( 1 + LDW1 + LDW2 + LDW3 + LDW4 ) ) * .. Local Scalars .. LOGICAL LEFTW, RIGHTW DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, NV, NW, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL, WEIGHT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AV(LDAV,NVMAX), AW(LDAW,NWMAX), $ B(LDB,MMAX), BV(LDBV,PMAX), BW(LDBW,MMAX), $ C(LDC,NMAX), CV(LDCV,NVMAX), CW(LDCW,NWMAX), $ D(LDD,MMAX), DV(LDDV,PMAX), DW(LDDW,MMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB09KD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NV, NW, NR, ALPHA, TOL1, TOL2, $ JOB, DICO, WEIGHT, EQUIL, ORDSEL LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF( P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( LEFTW .OR. NV.GT.0 ) THEN IF( NV.LT.0 .OR. NV.GT.NVMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NV ELSE IF( NV.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AV(I,J), J = 1,NV ), I = 1,NV ) READ ( NIN, FMT = * ) $ ( ( BV(I,J), J = 1,P ), I = 1, NV ) READ ( NIN, FMT = * ) $ ( ( CV(I,J), J = 1,NV ), I = 1,P ) END IF IF( LEFTW ) READ ( NIN, FMT = * ) $ ( ( DV(I,J), J = 1,P ), I = 1,P ) END IF END IF IF( RIGHTW ) THEN IF( NW.LT.0 .OR. NW.GT.NWMAX ) THEN WRITE ( NOUT, FMT = 99985 ) NW ELSE IF( NW.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AW(I,J), J = 1,NW ), I = 1,NW ) READ ( NIN, FMT = * ) $ ( ( BW(I,J), J = 1,M ), I = 1, NW ) READ ( NIN, FMT = * ) $ ( ( CW(I,J), J = 1,NW ), I = 1,M ) END IF READ ( NIN, FMT = * ) $ ( ( DW(I,J), J = 1,M ), I = 1,M ) END IF END IF * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99984 ) IWARN WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1, NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09KD = ',I2) 99997 FORMAT (/' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NV is out of range.',/' NV = ',I5) 99985 FORMAT (/' NW is out of range.',/' NW = ',I5) 99984 FORMAT (' IWARN on exit from AB09KD = ',I2) END slicot-5.0+20101122/examples77/TAB09MD.f000077500000000000000000000067241201767322700167250ustar00rootroot00000000000000* AB09MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + $ ( NMAX + MMAX + PMAX ) + 5 ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL, DICO, JOB, EQUIL, $ ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a reduced ssr for (A,B,C). CALL AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, $ ALPHA, A, LDA, B, LDB, C, LDC, NS, HSV, $ TOL, IWORK, DWORK, LDWORK, IWARN, INFO) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09MD = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are') END slicot-5.0+20101122/examples77/TAB09ND.f000077500000000000000000000076401201767322700167240ustar00rootroot00000000000000* AB09ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX + $ ( NMAX + MMAX + PMAX ) + 5 ) + $ ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NR, NS, P CHARACTER*1 DICO, EQUIL, JOB, ORDSEL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL AB09ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NR, ALPHA, TOL1, TOL2, $ DICO, JOB, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' AB09ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB09ND = ',I2) 99997 FORMAT (' The order of reduced model = ',I2) 99996 FORMAT (/' The reduced state dynamics matrix Ar is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' The reduced input/output matrix Dr is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-stable part are') END slicot-5.0+20101122/examples77/TAB13AD.f000077500000000000000000000051751201767322700167030ustar00rootroot00000000000000* AB13AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( ( NMAX + MMAX + PMAX ) + 5 ) $ + ( NMAX*( NMAX + 1 ) )/2 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, SHNORM INTEGER I, INFO, J, M, N, NS, P CHARACTER*1 DICO, EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), HSV(NMAX) * .. External Functions .. DOUBLE PRECISION AB13AD EXTERNAL AB13AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Compute the Hankel-norm of the ALPHA-stable projection of * (A,B,C). SHNORM = AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, LDA, B, $ LDB, C, LDC, NS, HSV, DWORK, LDWORK, $ INFO) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) SHNORM WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,NS ) END IF END IF END IF END IF STOP * 99999 FORMAT (' AB13AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB13AD = ',I2) 99997 FORMAT (' The Hankel-norm of the ALPHA-projection = ',1PD14.5) 99995 FORMAT (20(1X,F8.4)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of ALPHA-projection are') END slicot-5.0+20101122/examples77/TAB13BD.f000077500000000000000000000056301201767322700167000ustar00rootroot00000000000000* AB13BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( MMAX*( NMAX + MMAX ) + $ ( NMAX*( NMAX + 5 ) + $ MMAX*( MMAX + 2 ) + 4*PMAX ) + $ NMAX*( ( NMAX + PMAX ) + 4 ) + $ ( NMAX + PMAX ) ) ) * .. Local Scalars .. DOUBLE PRECISION S2NORM, TOL INTEGER I, INFO, IWARN, J, M, N, NQ, P CHARACTER*1 DICO, JOBN * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION AB13BD EXTERNAL AB13BD, LSAME * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Compute the H2 or L2 norm of (A,B,C,D). S2NORM = AB13BD( DICO, JOBN, N, M, P, A, LDA, B, LDB, * C, LDC, D, LDD, NQ, TOL, DWORK, LDWORK, * IWARN, INFO) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( LSAME( JOBN, 'H' ) ) THEN WRITE ( NOUT, FMT = 99997 ) S2NORM ELSE WRITE ( NOUT, FMT = 99996 ) S2NORM END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' AB13BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB13BD = ',I2) 99997 FORMAT (' The H2-norm of the system = ',1PD14.5) 99996 FORMAT (' The L2-norm of the system = ',1PD14.5) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TAB13CD.f000077500000000000000000000060031201767322700166740ustar00rootroot00000000000000* AB13CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LCWORK PARAMETER ( LCWORK = ( NMAX + MMAX )*( NMAX + PMAX ) + $ 3*( MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX*NMAX + 2*MMAX*MMAX + $ 2*PMAX*PMAX + 3*NMAX*MMAX + $ 2*NMAX*PMAX + MMAX*PMAX + 10*NMAX + $ 6*( MMAX + PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION FPEAK, HNORM, TOL INTEGER I, INFO, J, M, N, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK) COMPLEX*16 CWORK( LCWORK ) * .. External Functions .. DOUBLE PRECISION AB13CD EXTERNAL AB13CD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) TOL * Computing the Hinf norm HNORM = AB13CD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, TOL, $ IWORK, DWORK, LDWORK, CWORK, LCWORK, BWORK, $ INFO ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99991 ) HNORM FPEAK = DWORK(2) WRITE ( NOUT, FMT = 99996 ) WRITE ( NOUT, FMT = 99991 ) FPEAK ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from AB13CD =',I2) 99997 FORMAT (/' The H_infty norm of the system is'/) 99996 FORMAT (/' The peak frequency is'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT (D17.10) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples77/TAB13DD.f000077500000000000000000000074221201767322700167030ustar00rootroot00000000000000* AB13DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDE PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDE = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LCWORK PARAMETER ( LCWORK = ( NMAX + MMAX )*( NMAX + PMAX ) + $ 2*( PMAX + MMAX ) + $ ( PMAX + MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 15*NMAX*NMAX + PMAX*PMAX + MMAX*MMAX + $ ( 6*NMAX + 3 )*( PMAX + MMAX ) + $ 4*PMAX*MMAX + NMAX*MMAX + 22*NMAX + $ 7*( PMAX + MMAX ) ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, P CHARACTER DICO, EQUIL, JOBD, JOBE * .. Local Arrays .. INTEGER IWORK( LIWORK ) DOUBLE PRECISION A( LDA, NMAX ), B( LDB, MMAX ), C( LDC, NMAX ), $ D( LDD, MMAX ), DWORK( LDWORK ), E( LDE, NMAX ), $ FPEAK( 2 ), GPEAK( 2 ) COMPLEX*16 CWORK( LCWORK ) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB13DD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, FPEAK, TOL, DICO, JOBE, EQUIL, JOBD IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOBE, 'G' ) ) $ READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( JOBD, 'D' ) ) $ READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Computing the Linf norm. CALL 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 ) * IF ( INFO.EQ.0 ) THEN IF ( GPEAK( 2 ).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99991 ) ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99995 ) GPEAK( 1 ) END IF IF ( FPEAK( 2 ).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99990 ) ELSE WRITE ( NOUT, FMT = 99996 ) WRITE ( NOUT, FMT = 99995 ) FPEAK( 1 ) END IF ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from AB13DD =',I2) 99997 FORMAT (/' The L_infty norm of the system is'/) 99996 FORMAT (/' The peak frequency is'/) 99995 FORMAT (D17.10) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' The L_infty norm of the system is infinite') 99990 FORMAT (/' The peak frequency is infinite'/) END slicot-5.0+20101122/examples77/TAB13ED.f000077500000000000000000000032471201767322700167050ustar00rootroot00000000000000* AB13ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX*( NMAX + 1 ) ) * .. Local Scalars .. INTEGER I, INFO, J, N DOUBLE PRECISION HIGH, LOW, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL AB13ED, UD01MD * .. * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) * Read N, TOL and next A (row wise). READ ( NIN, FMT = * ) N, TOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE DO 10 I = 1, N READ ( NIN, FMT = * ) ( A(I,J), J = 1, N ) 10 CONTINUE * WRITE ( NOUT, FMT = 99998 ) N, TOL CALL UD01MD( N, N, 5, NOUT, A, LDA, 'Matrix A', INFO ) * CALL AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, INFO ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) LOW, HIGH ELSE WRITE ( NOUT, FMT = 99996 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13ED EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' N =', I4, 2X, 'TOL =', D10.3) 99997 FORMAT (' LOW =', D18.11, /' HIGH =', D18.11) 99996 FORMAT (' INFO on exit from AB13ED = ', I2) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TAB13FD.f000077500000000000000000000034741201767322700167100ustar00rootroot00000000000000* AB13FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX*( NMAX + 2 ) ) INTEGER LCWORK PARAMETER ( LCWORK = NMAX*( NMAX + 3 ) ) * .. Local Scalars .. INTEGER I, INFO, J, N DOUBLE PRECISION BETA, OMEGA, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK) COMPLEX*16 CWORK(LCWORK) * .. External Subroutines .. EXTERNAL AB13FD, UD01MD * .. * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) * Read N, TOL and next A (row wise). READ ( NIN, FMT = * ) N, TOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE DO 10 I = 1, N READ ( NIN, FMT = * ) ( A(I,J), J = 1, N ) 10 CONTINUE * WRITE ( NOUT, FMT = 99998 ) N, TOL CALL UD01MD( N, N, 5, NOUT, A, LDA, 'A', INFO ) * CALL AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, CWORK, $ LCWORK, INFO ) * IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99996 ) INFO WRITE ( NOUT, FMT = 99997 ) BETA, OMEGA END IF * 99999 FORMAT (' AB13FD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' N =', I2, 3X, 'TOL =', D10.3) 99997 FORMAT (' Stability radius :', D18.11, / * ' Minimizing omega :', D18.11) 99996 FORMAT (' INFO on exit from AB13FD = ', I2) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TAB13MD.f000077500000000000000000000044731201767322700167170ustar00rootroot00000000000000* AB13MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDZ PARAMETER ( LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 4*MMAX-2 + NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NMAX*NMAX*MMAX - NMAX*NMAX + $ 9*MMAX*MMAX + NMAX*MMAX + 11*NMAX + $ 33*MMAX - 11 ) INTEGER LZWORK PARAMETER ( LZWORK = 6*NMAX*NMAX*MMAX + 12*NMAX*NMAX + $ 6*MMAX + 6*NMAX - 3 ) * .. Local Scalars .. INTEGER I, INFO, J, M, N DOUBLE PRECISION BOUND * .. Local Arrays .. INTEGER ITYPE(MMAX), IWORK(LIWORK), NBLOCK(MMAX) DOUBLE PRECISION D(NMAX), DWORK(LDWORK), G(NMAX), X(2*MMAX-1) COMPLEX*16 Z(LDZ,NMAX), ZWORK(LZWORK) * .. External Subroutines .. EXTERNAL AB13MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( NBLOCK(I), I = 1, M ) READ ( NIN, FMT = * ) ( ITYPE(I), I = 1, M ) READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N ) * Computing mu. CALL AB13MD( 'N', N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, G, $ IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99991 ) BOUND ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' AB13MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB13MD =',I2) 99997 FORMAT (' The value of the structured singular value is'/) 99991 FORMAT (D17.10) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TAG08BD.f000077500000000000000000000412751201767322700167160ustar00rootroot00000000000000* AG08BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, MMAX, NMAX, PMAX PARAMETER ( LMAX = 20, MMAX = 20, NMAX = 20, PMAX = 20 ) INTEGER LDA, LDAEMX, LDB, LDC, LDD, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDD = PMAX, LDE = LMAX, LDQ = 1, LDZ = 1, $ LDAEMX = ( PMAX + LMAX + NMAX + MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = ( 4*( LMAX + NMAX ) + 8*NMAX + $ LDAEMX*LDAEMX + $ ( 1 + 5*LDAEMX ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, J, L, M, N, NFZ, NINFE, NIZ, $ NKROL, NKROR, NRANK, P CHARACTER*1 EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFI(NMAX), ALFR(NMAX), $ ASAVE(LDA,NMAX), B(LDB,MMAX), BETA(NMAX), $ BSAVE(LDB,MMAX), C(LDC,NMAX), CSAVE(LDC,NMAX), $ D(LDD,MMAX), DSAVE(LDD,MMAX), DWORK(LDWORK), $ E(LDE,NMAX), ESAVE(LDE,NMAX), Q(LDQ,1), Z(LDZ,1) INTEGER INFE(1+LMAX+PMAX+NMAX+MMAX), INFZ(NMAX+1), $ IWORK(NMAX+MMAX), KRONL(LMAX+PMAX+1), $ KRONR(NMAX+MMAX+1) * .. External Subroutines .. EXTERNAL AG08BD, DGEGV, DLACPY * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL, EQUIL IF( ( L.LT.0 .OR. L.GT.LMAX ) .OR. ( N.LT.0 .OR. N.GT.NMAX ) ) $ THEN WRITE ( NOUT, FMT = 99972 ) L, N ELSE IF( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE IF( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) CALL DLACPY( 'F', L, N, A, LDA, ASAVE, LDA ) CALL DLACPY( 'F', L, N, E, LDE, ESAVE, LDE ) CALL DLACPY( 'F', L, M, B, LDB, BSAVE, LDB ) CALL DLACPY( 'F', P, N, C, LDC, CSAVE, LDC ) CALL DLACPY( 'F', P, M, D, LDD, DSAVE, LDD ) * Compute poles (call the routine with M = 0, P = 0). CALL AG08BD( EQUIL, L, N, 0, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99968 ) NIZ DO 10 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 10 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99958 ) $ ( INFE(I), I = 1,NINFE ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99965 ) ELSE WRITE ( NOUT, FMT = 99966 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 30 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 40 CONTINUE END IF END IF END IF CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AG08BD( EQUIL, L, N, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99964 ) NIZ DO 50 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 50 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99960 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,NKROL ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99993 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99957 ) ELSE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 70 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 70 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 80 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 80 CONTINUE END IF END IF END IF CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL DLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AG08BD( EQUIL, L, N, M, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99963 ) NIZ DO 90 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 90 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99959 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,NKROR ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99987 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99956 ) ELSE WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 100 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 100 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 110 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 110 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99982 ) DO 120 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 120 CONTINUE END IF END IF END IF CALL DLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL DLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL DLACPY( 'F', L, M, BSAVE, LDB, B, LDB ) CALL DLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) CALL DLACPY( 'F', P, M, DSAVE, LDD, D, LDD ) * Compute the structural invariants of the given system. CALL 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( L.EQ.N ) THEN WRITE ( NOUT, FMT = 99969 ) NRANK - N ELSE WRITE ( NOUT, FMT = 99955 ) NRANK END IF WRITE ( NOUT, FMT = 99984 ) NFZ IF( NFZ.GT.0 ) THEN * Compute the finite zeros of the given system. * Workspace: need 8*NFZ. WRITE ( NOUT, FMT = 99983 ) WRITE ( NOUT, FMT = 99990 ) DO 130 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 130 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 140 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 140 CONTINUE CALL DGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALFR, ALFI, BETA, Q, $ LDQ, Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 150 I = 1, NFZ IF( ALFI(I).EQ.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) $ ALFR(I)/BETA(I) ELSE WRITE ( NOUT, FMT = 99979 ) $ ALFR(I)/BETA(I), $ ALFI(I)/BETA(I) END IF 150 CONTINUE END IF END IF WRITE ( NOUT, FMT = 99978 ) NIZ DO 160 I = 1, DINFZ WRITE ( NOUT, FMT = 99977 ) INFZ(I), I 160 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99961 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99976 ) NKROR IF( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AG08BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AG08BD = ',I2) 99997 FORMAT (' INFO on exit from DGEGV = ',I2) 99996 FORMAT (/'Unobservable finite eigenvalues'/ $ ' real part imag part ') 99995 FORMAT (/' The matrix Ef is ') 99994 FORMAT (/' The left Kronecker indices of [A-lambda*E;C] are ', $ /(20(I3,2X))) 99993 FORMAT (/' The system (A-lambda*E,C) is completely observable ') 99991 FORMAT (/' The finite output decoupling zeros are the eigenvalues' $ ,' of the pair (Af,Ef). ') 99990 FORMAT (/' The matrix Af is ') 99989 FORMAT (20(1X,F8.4)) 99988 FORMAT (/' The right Kronecker indices of [A-lambda*E,B] are ', $ /( 20(I3,2X) ) ) 99987 FORMAT (/' The system (A-lambda*E,B) is completely controllable ') 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' pair (Af,Ef). ') 99984 FORMAT (/' The number of finite zeros = ',I3) 99983 FORMAT (/' The finite zeros are the eigenvalues ', $ 'of the pair (Af,Ef)') 99982 FORMAT (/'Uncontrollable finite eigenvalues'/ $ ' real part imag part ') 99981 FORMAT (/'Finite zeros'/' real part imag part ') 99980 FORMAT (1X,F9.4) 99979 FORMAT (1X,F9.4,6X,F9.4) 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT ( I4,' infinite zero(s) of order ',I3) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99972 FORMAT (/' L or N is out of range.',/' L = ', I5, ' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) 99969 FORMAT (/' Normal rank of transfer function matrix = ',I3) 99968 FORMAT (//' The number of infinite poles = ',I3) 99967 FORMAT ( I4,' infinite pole(s) of order ',I3) 99966 FORMAT (/' The finite poles are the eigenvalues', $ ' of the pair (Af,Ef). ') 99965 FORMAT (/' The system has no finite poles ') 99964 FORMAT (//' The number of unobservable infinite poles = ',I3) 99963 FORMAT (//' The number of uncontrollable infinite poles = ',I3) 99962 FORMAT (/' The number of infinite Kronecker blocks = ',I3) 99961 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B;C,D] are ', /(20(I3,2X))) 99960 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E;C] are ', /(20(I3,2X))) 99959 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B] are ', /(20(I3,2X))) 99958 FORMAT (/' Multiplicities of infinite eigenvalues of A-lambda*E' $ ,' are ', /(20(I3,2X))) 99957 FORMAT (/' The system (A-lambda*E,C) has no finite output', $ ' decoupling zeros ') 99956 FORMAT (/' The system (A-lambda*E,B) has no finite input', $ ' decoupling zeros ') 99955 FORMAT (/' Normal rank of system pencil = ',I3) END slicot-5.0+20101122/examples77/TAG08BZ.f000077500000000000000000000373411201767322700167430ustar00rootroot00000000000000* AG08BZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, MMAX, NMAX, PMAX PARAMETER ( LMAX = 20, MMAX = 20, NMAX = 20, PMAX = 20 ) INTEGER LDA, LDAEMX, LDB, LDC, LDD, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDD = PMAX, LDE = LMAX, LDQ = 1, LDZ = 1, $ LDAEMX = PMAX + LMAX + NMAX + MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 4*( LMAX + NMAX ) + 2*LDAEMX + $ 8*NMAX ) INTEGER LZWORK PARAMETER ( LZWORK = LDAEMX*LDAEMX + 2*LMAX + PMAX + $ 3*( MMAX + NMAX ) + $ 3*( LMAX + PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DINFZ, I, INFO, J, L, M, N, NFZ, NINFE, NIZ, $ NKROL, NKROR, NRANK, P CHARACTER*1 EQUIL * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), ALPHA(NMAX), ASAVE(LDA,NMAX), $ B(LDB,MMAX), BETA(NMAX), BSAVE(LDB,MMAX), $ C(LDC,NMAX), CSAVE(LDC,NMAX), $ D(LDD,MMAX), DSAVE(LDD,MMAX), $ E(LDE,NMAX), ESAVE(LDE,NMAX), Q(LDQ,1), Z(LDZ,1), $ ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK) INTEGER INFE(1+LMAX+PMAX), INFZ(NMAX+1), $ IWORK(NMAX+MMAX), KRONL(LMAX+PMAX+1), $ KRONR(NMAX+MMAX+1) * .. External Subroutines .. EXTERNAL AG08BZ, ZGEGV, ZLACPY * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL, EQUIL IF( ( L.LT.0 .OR. L.GT.LMAX ) .OR. ( N.LT.0 .OR. N.GT.NMAX ) ) $ THEN WRITE ( NOUT, FMT = 99972 ) L, N ELSE IF( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE IF( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99970 ) P ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) CALL ZLACPY( 'F', L, N, A, LDA, ASAVE, LDA ) CALL ZLACPY( 'F', L, N, E, LDE, ESAVE, LDE ) CALL ZLACPY( 'F', L, M, B, LDB, BSAVE, LDB ) CALL ZLACPY( 'F', P, N, C, LDC, CSAVE, LDC ) CALL ZLACPY( 'F', P, M, D, LDD, DSAVE, LDD ) * Compute poles (call the routine with M = 0, P = 0). CALL AG08BZ( EQUIL, L, N, 0, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99968 ) NIZ DO 10 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 10 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99958 ) $ ( INFE(I), I = 1,NINFE ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99965 ) ELSE WRITE ( NOUT, FMT = 99966 ) WRITE ( NOUT, FMT = 99990 ) DO 20 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 30 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 40 CONTINUE END IF END IF END IF CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) * Check the observability and compute the ordered set of * the observability indices (call the routine with M = 0). CALL AG08BZ( EQUIL, L, N, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99964 ) NIZ DO 50 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 50 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99960 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,NKROL ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99993 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99957 ) ELSE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 70 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 70 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 80 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 80 CONTINUE END IF END IF END IF CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL ZLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) * Check the controllability and compute the ordered set of * the controllability indices (call the routine with P = 0) CALL AG08BZ( EQUIL, L, N, M, 0, 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99963 ) NIZ DO 90 I = 1, DINFZ WRITE ( NOUT, FMT = 99967 ) INFZ(I), I 90 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99959 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,NKROR ) IF( NFZ+NINFE.EQ.0 ) WRITE ( NOUT, FMT = 99987 ) IF( NFZ.EQ.0 ) THEN WRITE ( NOUT, FMT = 99956 ) ELSE WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99990 ) DO 100 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 100 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 110 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 110 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99982 ) DO 120 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 120 CONTINUE END IF END IF END IF CALL ZLACPY( 'F', L, N, ASAVE, LDA, A, LDA ) CALL ZLACPY( 'F', L, N, ESAVE, LDE, E, LDE ) CALL ZLACPY( 'F', L, M, BSAVE, LDB, B, LDB ) CALL ZLACPY( 'F', P, N, CSAVE, LDC, C, LDC ) CALL ZLACPY( 'F', P, M, DSAVE, LDD, D, LDD ) * Compute the structural invariants of the given system. CALL 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 ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( L.EQ.N ) THEN WRITE ( NOUT, FMT = 99969 ) NRANK - N ELSE WRITE ( NOUT, FMT = 99955 ) NRANK END IF WRITE ( NOUT, FMT = 99984 ) NFZ IF( NFZ.GT.0 ) THEN * Compute the finite zeros of the given system. * Workspace: need 8*NFZ. WRITE ( NOUT, FMT = 99983 ) WRITE ( NOUT, FMT = 99990 ) DO 130 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( A(I,J), J = 1,NFZ ) 130 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 140 I = 1, NFZ WRITE ( NOUT, FMT = 99989 ) $ ( E(I,J), J = 1,NFZ ) 140 CONTINUE CALL ZGEGV( 'No vectors', 'No vectors', NFZ, A, $ LDA, E, LDE, ALPHA, BETA, Q, LDQ, $ Z, LDZ, ZWORK, LZWORK, DWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99981 ) DO 150 I = 1, NFZ WRITE ( NOUT, FMT = 99979 ) ALPHA(I)/BETA(I) 150 CONTINUE END IF END IF WRITE ( NOUT, FMT = 99978 ) NIZ DO 160 I = 1, DINFZ WRITE ( NOUT, FMT = 99977 ) INFZ(I), I 160 CONTINUE WRITE ( NOUT, FMT = 99962 ) NINFE IF( NINFE.GT.0 ) WRITE ( NOUT, FMT = 99961 ) $ ( INFE(I), I = 1,NINFE ) WRITE ( NOUT, FMT = 99976 ) NKROR IF( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 ) $ ( KRONR(I), I = 1,NKROR ) WRITE ( NOUT, FMT = 99974 ) NKROL IF( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 ) $ ( KRONL(I), I = 1,NKROL ) END IF END IF END IF END IF * STOP * 99999 FORMAT (' AG08BZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AG08BZ = ',I2) 99997 FORMAT (' INFO on exit from ZGEGV = ',I2) 99996 FORMAT (/' Unobservable finite eigenvalues'/ $ ' real part imag part ') 99995 FORMAT (/' The matrix Ef is ') 99994 FORMAT (/' The left Kronecker indices of [A-lambda*E;C] are ', $ /(20(I3,2X))) 99993 FORMAT (/' The system (A-lambda*E,C) is completely observable ') 99991 FORMAT (/' The finite output decoupling zeros are the eigenvalues' $ , ' of the pair (Af,Ef). ') 99990 FORMAT (/' The matrix Af is ') 99989 FORMAT (20(1X,F9.4,SP,F9.4,S,'i ')) 99988 FORMAT (/' The right Kronecker indices of [A-lambda*E,B] are ', $ /( 20(I3,2X) ) ) 99987 FORMAT (/' The system (A-lambda*E,B) is completely controllable ') 99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the', $ ' pair (Af,Ef). ') 99984 FORMAT (/' The number of finite zeros = ',I3) 99983 FORMAT (/' The finite zeros are the eigenvalues ', $ 'of the pair (Af,Ef)') 99982 FORMAT (/' Uncontrollable finite eigenvalues'/ $ ' real part imag part ') 99981 FORMAT (/' Finite zeros'/' real part imag part ') 99979 FORMAT (1X,F9.4,SP,F9.4,S,'i ') 99978 FORMAT (//' The number of infinite zeros = ',I3) 99977 FORMAT ( I4,' infinite zero(s) of order ',I3) 99976 FORMAT (/' The number of right Kronecker indices = ',I3) 99975 FORMAT (/' Right Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99974 FORMAT (/' The number of left Kronecker indices = ',I3) 99973 FORMAT (/' The left Kronecker indices of [A-lambda*E,B;C,D]' $ ,' are ', /(20(I3,2X))) 99972 FORMAT (/' L or N is out of range.',/' L = ', I5, ' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) 99970 FORMAT (/' P is out of range.',/' P = ',I5) 99969 FORMAT (/' Normal rank of transfer function matrix = ',I3) 99968 FORMAT (//' The number of infinite poles = ',I3) 99967 FORMAT ( I4,' infinite pole(s) of order ',I3) 99966 FORMAT (/' The finite poles are the eigenvalues', $ ' of the pair (Af,Ef). ') 99965 FORMAT (/' The system has no finite poles ') 99964 FORMAT (//' The number of unobservable infinite poles = ',I3) 99963 FORMAT (//' The number of uncontrollable infinite poles = ',I3) 99962 FORMAT (/' The number of infinite Kronecker blocks = ',I3) 99961 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B;C,D] are ', /(20(I3,2X))) 99960 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E;C] are ', /(20(I3,2X))) 99959 FORMAT (/' Multiplicities of infinite eigenvalues of ' $ ,'[A-lambda*E,B] are ', /(20(I3,2X))) 99958 FORMAT (/' Multiplicities of infinite eigenvalues of A-lambda*E' $ ,' are ', /(20(I3,2X))) 99957 FORMAT (/' The system (A-lambda*E,C) has no finite output', $ ' decoupling zeros ') 99956 FORMAT (/' The system (A-lambda*E,B) has no finite input', $ ' decoupling zeros ') 99955 FORMAT (/' Normal rank of system pencil = ',I3) END slicot-5.0+20101122/examples77/TB01ID.dat000077500000000000000000000015301201767322700171210ustar00rootroot00000000000000 TB01ID EXAMPLE PROGRAM DATA 5 2 5 A 0.0 0.0 1.0000e+000 0.0 0.0 0.0 -1.5800e+006 -1.2570e+003 0.0 0.0 0.0 3.5410e+014 0.0 -1.4340e+003 0.0 -5.3300e+011 0.0 0.0 0.0 0.0 1.0000e+000 0.0 0.0 0.0 -1.8630e+004 -1.4820e+000 0.0 0.0 1.1030e+002 0.0 0.0 0.0 0.0 0.0 0.0 8.3330e-003 1.0000e+000 0.0 0.0 0.0 0.0 0.0 0.0 1.0000e+000 0.0 0.0 0.0 0.0 0.0 1.0000e+000 0.0 6.6640e-001 0.0 -6.2000e-013 0.0 0.0 0.0 0.0 -1.0000e-003 1.8960e+006 1.5080e+002 slicot-5.0+20101122/examples77/TB01ID.res000077500000000000000000000027601201767322700171500ustar00rootroot00000000000000 TB01ID EXAMPLE PROGRAM RESULTS The balanced matrix A ( 5X 5) 1 2 3 4 5 1 0.0000000D+00 0.1000000D+05 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 -0.1580000D+03 -0.1257000D+04 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.3541000D+05 0.0000000D+00 -0.1434000D+04 0.0000000D+00 -0.5330000D+03 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+03 5 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.1863000D+03 -0.1482000D+01 The balanced matrix B ( 5X 2) 1 2 1 0.0000000D+00 0.0000000D+00 2 0.1103000D+04 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 5 0.0000000D+00 0.8333000D+02 The balanced matrix C ( 5X 5) 1 2 3 4 5 1 0.1000000D-04 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.1000000D+06 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D-05 0.0000000D+00 4 0.6664000D-05 0.0000000D+00 -0.6200000D-07 0.0000000D+00 0.0000000D+00 5 0.0000000D+00 0.0000000D+00 -0.1000000D+03 0.1896000D+01 0.1508000D-01 The scaling vector SCALE ( 1X 5) 1 2 3 4 5 1 0.1000000D-04 0.1000000D+00 0.1000000D+06 0.1000000D-05 0.1000000D-03 MAXRED is 0.3488E+10 slicot-5.0+20101122/examples77/TB01IZ.dat000077500000000000000000000022621201767322700171520ustar00rootroot00000000000000 TB01IZ EXAMPLE PROGRAM DATA 5 2 5 A 0.0 (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.5800e+006,0.0) (-1.2570e+003,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (3.5410e+014,0.0) (0.0,0.0) (-1.4340e+003,0.0) (0.0,0.0) (-5.3300e+011,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.8630e+004,0.0) (-1.4820e+000,0.0) (0.0,0.0) (0.0,0.0) (1.1030e+002,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (8.3330e-003,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (1.0000e+000,0.0) (0.0,0.0) (6.6640e-001,0.0) (0.0,0.0) (-6.2000e-013,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (0.0,0.0) (-1.0000e-003,0.0) (1.8960e+006,0.0) (1.5080e+002,0.0) slicot-5.0+20101122/examples77/TB01IZ.res000077500000000000000000000054721201767322700172010ustar00rootroot00000000000000 TB01IZ EXAMPLE PROGRAM RESULTS The balanced matrix A ( 5X 5) 1 2 3 1 0.0000000D+00 +0.0000000D+00i 0.1000000D+05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 -0.1580000D+03 +0.0000000D+00i -0.1257000D+04 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.3541000D+05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i -0.1434000D+04 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 5 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 5 1 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.0000000D+00 +0.0000000D+00i -0.5330000D+03 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.1000000D+03 +0.0000000D+00i 5 -0.1863000D+03 +0.0000000D+00i -0.1482000D+01 +0.0000000D+00i The balanced matrix B ( 5X 2) 1 2 1 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.1103000D+04 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 5 0.0000000D+00 +0.0000000D+00i 0.8333000D+02 +0.0000000D+00i The balanced matrix C ( 5X 5) 1 2 3 1 0.1000000D-04 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.1000000D+06 +0.0000000D+00i 3 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 0.6664000D-05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i -0.6200000D-07 +0.0000000D+00i 5 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i -0.1000000D+03 +0.0000000D+00i 4 5 1 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 2 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 3 0.1000000D-05 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 4 0.0000000D+00 +0.0000000D+00i 0.0000000D+00 +0.0000000D+00i 5 0.1896000D+01 +0.0000000D+00i 0.1508000D-01 +0.0000000D+00i The scaling vector SCALE ( 1X 5) 1 2 3 4 5 1 0.1000000D-04 0.1000000D+00 0.1000000D+06 0.1000000D-05 0.1000000D-03 MAXRED is 0.3488E+10 slicot-5.0+20101122/examples77/TB01KD.dat000077500000000000000000000010411201767322700171200ustar00rootroot00000000000000 TB01KD EXAMPLE PROGRAM DATA (Continuous system) 5 2 3 -1.0 C U G -0.04165 4.9200 -4.9200 0 0 -1.387944 -3.3300 0 0 0 0.5450 0 0 -0.5450 0 0 0 4.9200 -0.04165 4.9200 0 0 0 -1.387944 -3.3300 0 0 3.3300 0 0 0 0 0 0 3.3300 1 0 0 0 0 0 0 1 0 0 0 0 0 1 0 slicot-5.0+20101122/examples77/TB01KD.res000077500000000000000000000021731201767322700171500ustar00rootroot00000000000000 TB01KD EXAMPLE PROGRAM RESULTS The number of eigenvalues in the domain of interest = 2 The eigenvalues of state dynamics matrix A are ( -0.7483, 2.9940 ) ( -0.7483, -2.9940 ) ( -1.6858, 2.0311 ) ( -1.6858, -2.0311 ) ( -1.8751, 0.0000 ) The transformed state dynamics matrix inv(U)*A*U is -0.7483 -8.6406 0.0000 0.0000 0.0000 1.0374 -0.7483 0.0000 0.0000 0.0000 0.0000 0.0000 -1.6858 5.5669 0.0000 0.0000 0.0000 -0.7411 -1.6858 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8751 The transformed input/state matrix inv(U)*B is 2.0240 -2.0240 -1.1309 1.1309 -0.8621 -0.8621 2.1912 2.1912 -1.5555 1.5555 The transformed state/output matrix C*U is 0.6864 -0.0987 0.6580 0.2589 0.9650 -0.0471 0.6873 0.0000 0.0000 -0.5609 -0.6864 0.0987 0.6580 0.2589 -0.9650 The similarity transformation matrix U is 0.6864 -0.0987 0.6580 0.2589 0.9650 -0.1665 -0.5041 -0.2589 0.6580 -0.9205 -0.0471 0.6873 0.0000 0.0000 -0.5609 -0.6864 0.0987 0.6580 0.2589 -0.9650 0.1665 0.5041 -0.2589 0.6580 0.9205 slicot-5.0+20101122/examples77/TB01LD.dat000077500000000000000000000010411201767322700171210ustar00rootroot00000000000000 TB01LD EXAMPLE PROGRAM DATA (Continuous system) 5 2 3 -1.0 C U G -0.04165 4.9200 -4.9200 0 0 -1.387944 -3.3300 0 0 0 0.5450 0 0 -0.5450 0 0 0 4.9200 -0.04165 4.9200 0 0 0 -1.387944 -3.3300 0 0 3.3300 0 0 0 0 0 0 3.3300 1 0 0 0 0 0 0 1 0 0 0 0 0 1 0 slicot-5.0+20101122/examples77/TB01LD.res000077500000000000000000000021641201767322700171510ustar00rootroot00000000000000 TB01LD EXAMPLE PROGRAM RESULTS The number of eigenvalues in the domain of interest = 2 The eigenvalues of state dynamics matrix A are ( -0.7483, 2.9940 ) ( -0.7483, -2.9940 ) ( -1.6858, 2.0311 ) ( -1.6858, -2.0311 ) ( -1.8751, 0.0000 ) The transformed state dynamics matrix U'*A*U is -0.7483 -8.6406 0.0000 0.0000 1.1745 1.0374 -0.7483 0.0000 0.0000 -2.1164 0.0000 0.0000 -1.6858 5.5669 0.0000 0.0000 0.0000 -0.7411 -1.6858 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8751 The transformed input/state matrix U'*B is -0.5543 0.5543 -1.6786 1.6786 -0.8621 -0.8621 2.1912 2.1912 -1.5555 1.5555 The transformed state/output matrix C*U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 The similarity transformation matrix U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.1665 -0.5041 -0.2589 0.6580 -0.4671 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 0.1665 0.5041 -0.2589 0.6580 0.4671 slicot-5.0+20101122/examples77/TB01MD.dat000077500000000000000000000006041201767322700171260ustar00rootroot00000000000000 TB01MD EXAMPLE PROGRAM DATA 6 3 N U 35.0 1.0 6.0 26.0 19.0 24.0 3.0 32.0 7.0 21.0 23.0 25.0 31.0 9.0 2.0 22.0 27.0 20.0 8.0 28.0 33.0 17.0 10.0 15.0 30.0 5.0 34.0 12.0 14.0 16.0 4.0 36.0 29.0 13.0 18.0 11.0 1.0 5.0 11.0 -1.0 4.0 11.0 -5.0 1.0 9.0 -11.0 -4.0 5.0 -19.0 -11.0 -1.0 -29.0 -20.0 -9.0 slicot-5.0+20101122/examples77/TB01MD.res000077500000000000000000000011431201767322700171460ustar00rootroot00000000000000 TB01MD EXAMPLE PROGRAM RESULTS The transformed state transition matrix is 60.3649 58.8853 5.0480 -5.4406 2.1382 -7.3870 54.5832 33.1865 36.5234 6.3272 -3.1377 8.8154 17.6406 21.4501 -13.5942 0.5417 1.6926 0.0786 -9.0567 10.7202 0.3531 1.5444 -1.2846 24.6407 0.0000 6.8796 -20.1372 -2.6440 2.4983 -21.8071 0.0000 0.0000 0.0000 0.0000 0.0000 27.0000 The transformed input matrix is -16.8819 -8.8260 13.9202 0.0000 13.8240 39.9205 0.0000 0.0000 4.1928 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 slicot-5.0+20101122/examples77/TB01ND.dat000077500000000000000000000004541201767322700171320ustar00rootroot00000000000000 TB01ND EXAMPLE PROGRAM DATA 5 3 N U 15.0 21.0 -3.0 3.0 9.0 20.0 1.0 2.0 8.0 9.0 4.0 1.0 7.0 13.0 14.0 5.0 6.0 12.0 13.0 -6.0 5.0 11.0 17.0 -7.0 -1.0 7.0 -1.0 3.0 -6.0 -3.0 4.0 5.0 6.0 -2.0 -3.0 9.0 8.0 5.0 2.0 1.0 slicot-5.0+20101122/examples77/TB01ND.res000077500000000000000000000007421201767322700171530ustar00rootroot00000000000000 TB01ND EXAMPLE PROGRAM RESULTS The transformed state transition matrix is 7.1637 -0.9691 -16.5046 0.2869 0.9205 -2.3285 11.5431 -8.7471 3.4122 -3.7118 -10.5440 -7.6032 -0.3215 3.6571 -0.4335 -3.6845 5.6449 0.5906 -15.6996 17.4267 0.0000 -6.4260 1.5591 14.4317 32.3143 The transformed output matrix is 0.0000 0.0000 7.6585 5.2973 -4.1576 0.0000 0.0000 0.0000 5.8305 -7.4837 0.0000 0.0000 0.0000 0.0000 -13.2288 slicot-5.0+20101122/examples77/TB01PD.dat000077500000000000000000000002641201767322700171330ustar00rootroot00000000000000 TB01PD EXAMPLE PROGRAM DATA 3 1 2 0.0 M N 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/TB01PD.res000077500000000000000000000007001201767322700171470ustar00rootroot00000000000000 TB01PD EXAMPLE PROGRAM RESULTS The order of the minimal realization = 3 The transformed state dynamics matrix of a minimal realization is 1.0000 -1.4142 1.4142 -2.8284 0.0000 1.0000 2.8284 1.0000 0.0000 The transformed input/state matrix of a minimal realization is -1.0000 0.7071 0.7071 The transformed state/output matrix of a minimal realization is 0.0000 0.0000 -1.4142 0.0000 0.7071 0.7071 slicot-5.0+20101122/examples77/TB01TD.dat000077500000000000000000000005361201767322700171410ustar00rootroot00000000000000 TB01TD EXAMPLE PROGRAM DATA 5 2 2 0.0 0.0 1.0 4.0 5.0 50.0 10.0 1.0 0.0 0.0 0.0 0.0 90.0 10.0 0.0 0.0 1.0 1.0 1.0 1.0 100.0 0.0 0.0 0.0 70.0 0.0 2.0 0.0 1.0 2.0 0.0 20.0 100.0 1.0 0.0 1.0 0.0 0.0 1.0 0.0 1.0 1.0 0.0 2.0 1.0 1.0 1.0 1.0 1.0 slicot-5.0+20101122/examples77/TB01TD.res000077500000000000000000000013301201767322700171530ustar00rootroot00000000000000 TB01TD EXAMPLE PROGRAM RESULTS LOW = 1 IGH = 5 The balanced state dynamics matrix A is 0.0000 0.0000 1.0000 4.0000 40.0000 6.2500 10.0000 0.1250 0.0000 0.0000 0.0000 0.0000 90.0000 10.0000 0.0000 0.0000 8.0000 1.0000 1.0000 8.0000 12.5000 0.0000 0.0000 0.0000 70.0000 The balanced input/state matrix B is 0.0000 0.0000 16.0000 2.5000 0.0000 100.0000 64.0000 1.0000 16.0000 0.0000 The balanced state/output matrix C is 32.0000 0.0000 0.0000 32.0000 0.0000 4.0000 32.0000 0.0000 8.0000 32.0000 The scaled direct transmission matrix D is 2048.0000 32.0000 256.0000 4.0000 slicot-5.0+20101122/examples77/TB01UD.dat000077500000000000000000000003011201767322700171300ustar00rootroot00000000000000 TB01UD EXAMPLE PROGRAM DATA 3 2 2 0.0 I -1.0 0.0 0.0 -2.0 -2.0 -2.0 -1.0 0.0 -3.0 1.0 0.0 0.0 0.0 2.0 1.0 0.0 2.0 1.0 1.0 0.0 0.0 slicot-5.0+20101122/examples77/TB01UD.res000077500000000000000000000012571201767322700171640ustar00rootroot00000000000000 TB01UD EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 2 The transformed state dynamics matrix of a controllable realization is -3.0000 2.2361 0.0000 -1.0000 and the dimensions of its diagonal blocks are 2 The transformed input/state matrix B of a controllable realization is 0.0000 -2.2361 1.0000 0.0000 The transformed output/state matrix C of a controllable realization is -2.2361 0.0000 0.0000 1.0000 The controllability index of the transformed system representation = 1 The similarity transformation matrix Z is 0.0000 1.0000 0.0000 -0.8944 0.0000 -0.4472 -0.4472 0.0000 0.8944 slicot-5.0+20101122/examples77/TB01WD.dat000077500000000000000000000010061201767322700171350ustar00rootroot00000000000000 TB01WD EXAMPLE PROGRAM DATA (Continuous system) 5 2 3 -0.04165 4.9200 -4.9200 0 0 -1.387944 -3.3300 0 0 0 0.5450 0 0 -0.5450 0 0 0 4.9200 -0.04165 4.9200 0 0 0 -1.387944 -3.3300 0 0 3.3300 0 0 0 0 0 0 3.3300 1 0 0 0 0 0 0 1 0 0 0 0 0 1 0 slicot-5.0+20101122/examples77/TB01WD.res000077500000000000000000000020661201767322700171650ustar00rootroot00000000000000 TB01WD EXAMPLE PROGRAM RESULTS The eigenvalues of state dynamics matrix A are ( -0.7483, 2.9940 ) ( -0.7483, -2.9940 ) ( -1.6858, 2.0311 ) ( -1.6858, -2.0311 ) ( -1.8751, 0.0000 ) The transformed state dynamics matrix U'*A*U is -0.7483 -8.6406 0.0000 0.0000 1.1745 1.0374 -0.7483 0.0000 0.0000 -2.1164 0.0000 0.0000 -1.6858 5.5669 0.0000 0.0000 0.0000 -0.7411 -1.6858 0.0000 0.0000 0.0000 0.0000 0.0000 -1.8751 The transformed input/state matrix U'*B is -0.5543 0.5543 -1.6786 1.6786 -0.8621 -0.8621 2.1912 2.1912 -1.5555 1.5555 The transformed state/output matrix C*U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 The similarity transformation matrix U is 0.6864 -0.0987 0.6580 0.2589 -0.1381 -0.1665 -0.5041 -0.2589 0.6580 -0.4671 -0.0471 0.6873 0.0000 0.0000 -0.7249 -0.6864 0.0987 0.6580 0.2589 0.1381 0.1665 0.5041 -0.2589 0.6580 0.4671 slicot-5.0+20101122/examples77/TB01ZD.dat000077500000000000000000000002501201767322700171400ustar00rootroot00000000000000 TB01ZD EXAMPLE PROGRAM DATA 3 2 0.0 I 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 2.0 1.0 1.0 0.0 0.0 slicot-5.0+20101122/examples77/TB01ZD.res000077500000000000000000000011061201767322700171620ustar00rootroot00000000000000 TB01ZD EXAMPLE PROGRAM RESULTS The order of the controllable state-space representation = 3 The state dynamics matrix A of a controllable realization is 1.0000 1.4142 0.0000 2.8284 -1.0000 2.8284 0.0000 1.4142 1.0000 The input/state vector B of a controllable realization is -1.4142 0.0000 0.0000 The output/state matrix C of a controllable realization is -0.7071 -2.0000 0.7071 -0.7071 0.0000 -0.7071 The similarity transformation matrix Z is -0.7071 0.0000 -0.7071 0.0000 -1.0000 0.0000 -0.7071 0.0000 0.7071 slicot-5.0+20101122/examples77/TB03AD.dat000077500000000000000000000003011201767322700171060ustar00rootroot00000000000000 TB03AD EXAMPLE PROGRAM DATA 3 1 2 0.0 R N 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 0.0 1.0 -1.0 0.0 0.0 1.0 0.0 1.0 slicot-5.0+20101122/examples77/TB03AD.res000077500000000000000000000014451201767322700171410ustar00rootroot00000000000000 TB03AD EXAMPLE PROGRAM RESULTS The order of the minimal state-space representation = 3 The transformed state dynamics matrix of a minimal realization is 1.0000 -1.4142 0.0000 -2.8284 -1.0000 2.8284 0.0000 1.4142 1.0000 and the dimensions of its diagonal blocks are 1 1 1 The transformed input/state matrix of a minimal realization is -1.4142 0.0000 0.0000 The transformed state/output matrix of a minimal realization is 0.7071 1.0000 0.7071 -0.7071 0.0000 -0.7071 The controllability index of the transformed minimal system representation = 3 INDEX is 3 The denominator matrix P(s) is 0.1768 -0.1768 -1.5910 1.5910 The numerator matrix Q(s) is 0.0000 -0.1768 0.7071 0.8839 0.1768 0.0000 -1.5910 0.0000 slicot-5.0+20101122/examples77/TB04AD.dat000077500000000000000000000003431201767322700171150ustar00rootroot00000000000000 TB04AD EXAMPLE PROGRAM DATA 3 2 2 0.0 0.0 R -1.0 0.0 0.0 0.0 -2.0 0.0 0.0 0.0 -3.0 0.0 1.0 -1.0 1.0 1.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/TB04AD.res000077500000000000000000000024341201767322700171410ustar00rootroot00000000000000 TB04AD EXAMPLE PROGRAM RESULTS The order of the transformed state-space representation = 3 The transformed state dynamics matrix A is -2.5000 -0.2887 -0.4082 -0.2887 -1.5000 -0.7071 -0.4082 -0.7071 -2.0000 The transformed input/state matrix B is -1.4142 -0.7071 0.0000 1.2247 0.0000 0.0000 The transformed state/output matrix C is 0.0000 0.8165 1.1547 0.0000 1.6330 0.5774 The controllability index of the transformed state-space representation = 2 The dimensions of the diagonal blocks of the transformed A are 2 1 The degrees of the denominator polynomials are 2 3 The coefficients of polynomials in the transfer matrix T(s) are element ( 1, 1) is 1.00 5.00 7.00 0.00 ----------------------------- 1.00 5.00 6.00 0.00 element ( 1, 2) is 0.00 1.00 3.00 0.00 ----------------------------- 1.00 5.00 6.00 0.00 element ( 2, 1) is 0.00 0.00 1.00 1.00 ----------------------------- 1.00 6.00 11.00 6.00 element ( 2, 2) is 1.00 8.00 20.00 15.00 ----------------------------- 1.00 6.00 11.00 6.00 slicot-5.0+20101122/examples77/TB04BD.dat000077500000000000000000000003501201767322700171140ustar00rootroot00000000000000 TB04BD EXAMPLE PROGRAM DATA 3 2 2 0.0 D I N -1.0 0.0 0.0 0.0 -2.0 0.0 0.0 0.0 -3.0 0.0 1.0 -1.0 1.0 1.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/TB04BD.res000077500000000000000000000012331201767322700171360ustar00rootroot00000000000000 TB04BD EXAMPLE PROGRAM RESULTS The polynomial coefficients appear in increasing order of the powers of the indeterminate The coefficients of polynomials in the transfer matrix T(s) are element ( 1, 1) is 7.00 5.00 1.00 ---------------------- 6.00 5.00 1.00 element ( 2, 1) is 1.00 ---------------------- 6.00 5.00 1.00 element ( 1, 2) is 1.00 --------------- 2.00 1.00 element ( 2, 2) is 5.00 5.00 1.00 ---------------------- 2.00 3.00 1.00 slicot-5.0+20101122/examples77/TB04CD.dat000077500000000000000000000003421201767322700171160ustar00rootroot00000000000000 TB04CD EXAMPLE PROGRAM DATA 3 2 2 0.0 D N -1.0 0.0 0.0 0.0 -2.0 0.0 0.0 0.0 -3.0 0.0 1.0 -1.0 1.0 1.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/TB04CD.res000077500000000000000000000017141201767322700171430ustar00rootroot00000000000000 TB04CD EXAMPLE PROGRAM RESULTS The poles, zeros and gains of the transfer matrix elements: zeros of element ( 1, 1) are real part imag part -2.5000 0.8660 -2.5000 -0.8660 poles of element ( 1, 1) are real part imag part -2.0000 0.0000 -3.0000 0.0000 gain of element ( 1, 1) is 1.0000 no zeros for element ( 2, 1) poles of element ( 2, 1) are real part imag part -2.0000 0.0000 -3.0000 0.0000 gain of element ( 2, 1) is 1.0000 no zeros for element ( 1, 2) poles of element ( 1, 2) are real part imag part -2.0000 0.0000 gain of element ( 1, 2) is 1.0000 zeros of element ( 2, 2) are real part imag part -3.6180 0.0000 -1.3820 0.0000 poles of element ( 2, 2) are real part imag part -1.0000 0.0000 -2.0000 0.0000 gain of element ( 2, 2) is 1.0000 slicot-5.0+20101122/examples77/TB05AD.dat000077500000000000000000000002721201767322700171170ustar00rootroot00000000000000 TB05AD EXAMPLE PROGRAM DATA 3 1 2 (0.0,0.5) G A 1.0 2.0 0.0 4.0 -1.0 0.0 0.0 0.0 1.0 1.0 0.0 1.0 1.0 0.0 -1.0 0.0 0.0 1.0 slicot-5.0+20101122/examples77/TB05AD.res000077500000000000000000000004521201767322700171400ustar00rootroot00000000000000 TB05AD EXAMPLE PROGRAM RESULTS RCOND = 0.22 Eigenvalues of the state transmission matrix A are 3.00 0.00*j -3.00 0.00*j 1.00 0.00*j The frequency response matrix G(freq) is ( 0.69, 0.35) (-0.80,-0.40) H(inverse)*B is (-0.11,-0.05) (-0.43, 0.00) (-0.80,-0.40) slicot-5.0+20101122/examples77/TBB01AD.f000077500000000000000000000137411201767322700166770ustar00rootroot00000000000000* BB01AD EXAMPLE PROGRAM TEXT * * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 100, NMAX = 100, PMAX = 100 ) INTEGER LDA, LDB, LDC, LDG, LDQ, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDG = NMAX, LDQ = NMAX, LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 4 + NMAX ) ) * .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, ISYMM, J, LBPAR, LDPAR, LIPAR, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB,MMAX), C(LDC, NMAX), $ DPAR(7), DWORK(LDWORK), G(LDG, NMAX), $ Q(LDQ, NMAX), X(LDX, NMAX) INTEGER IPAR(3), NR(2) LOGICAL BPAR(6), VEC(9) CHARACTER CHPAR*255 * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL BB01AD, MA02DD * .. Executable Statements .. WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ( NIN, FMT = '()' ) READ( NIN, FMT = * ) DEF READ( NIN, FMT = * ) ( NR(I), I = 1, 2 ) IF( LSAME( DEF, 'N' ) ) THEN READ( NIN, FMT = * ) LBPAR IF( LBPAR.GT.0 ) READ( NIN, FMT = * ) ( BPAR(I), I = 1, LBPAR ) READ( NIN, FMT = * ) LDPAR IF( LDPAR.GT.0 ) READ( NIN, FMT = * ) ( DPAR(I), I = 1, LDPAR ) READ( NIN, FMT = * ) LIPAR IF( LIPAR.GT.0 ) READ( NIN, FMT = * ) ( IPAR(I), I = 1, LIPAR ) END IF * Generate benchmark example CALL BB01AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, A, $ LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, DWORK, $ LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99998 ) INFO ELSE WRITE( NOUT, FMT = * ) CHPAR(1:70) WRITE( NOUT, FMT = 99997 ) N WRITE( NOUT, FMT = 99996 ) M WRITE( NOUT, FMT = 99995 ) P WRITE( NOUT, FMT = 99994 ) DO 10 I = 1, N WRITE( NOUT, FMT = 99979 ) ( A(I,J), J = 1, N ) 10 CONTINUE IF( VEC(5) ) THEN WRITE( NOUT, FMT = 99993 ) DO 20 I = 1, N WRITE( NOUT, FMT = 99979 ) ( B(I,J), J = 1, M ) 20 CONTINUE ELSE WRITE( NOUT, FMT = 99992 ) END IF IF( VEC(6) ) THEN WRITE( NOUT,FMT = 99991 ) DO 30 I = 1, P WRITE( NOUT, FMT = 99979 ) ( C(I,J), J = 1, N ) 30 CONTINUE ELSE WRITE( NOUT, FMT = 99990 ) END IF IF( .NOT.VEC(5) ) THEN WRITE( NOUT, FMT = 99989 ) IF( .NOT.BPAR(2) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, G, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, G, LDG, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, G, LDG, DWORK ) END IF END IF DO 40 I = 1, N WRITE( NOUT, FMT = 99979 ) ( G(I,J), J = 1, N ) 40 CONTINUE ELSE WRITE( NOUT, FMT = 99988 ) END IF IF( .NOT.VEC(6) ) THEN IF( .NOT. BPAR(5) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99987 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99979 ) ( Q(I,J), J = 1, N ) 50 CONTINUE ELSE WRITE( NOUT, FMT = 99986 ) END IF IF( VEC(6) ) THEN IF( .NOT.BPAR(5) ) THEN ISYMM = ( P * ( P + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', P, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', P, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99985 ) DO 60 I = 1, N WRITE( NOUT, FMT = 99979 ) ( Q(I,J), J = 1, N ) 60 CONTINUE ELSE WRITE( NOUT, FMT = 99984 ) END IF IF( VEC(5) ) THEN IF( .NOT.BPAR(2) ) THEN ISYMM = ( M * ( M + 1 ) ) / 2 CALL DCOPY( ISYMM, G, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', M, G, LDG, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', M, G, LDG, DWORK ) END IF END IF WRITE( NOUT, FMT = 99983 ) DO 70 I = 1, N WRITE( NOUT, FMT = 99979 ) ( G(I,J), J = 1, N ) 70 CONTINUE ELSE WRITE( NOUT, FMT = 99982 ) END IF IF( VEC(9) ) THEN WRITE( NOUT, FMT = 99981 ) DO 80 I = 1, N WRITE( NOUT, FMT = 99979 ) ( X(I,J), J = 1, N ) 80 CONTINUE ELSE WRITE( NOUT, FMT = 99980 ) END IF END IF STOP * 99999 FORMAT (' BB01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB03AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (' A = ') 99993 FORMAT (' B = ') 99992 FORMAT (' B is not provided.') 99991 FORMAT (' C = ') 99990 FORMAT (' C is not provided.') 99989 FORMAT (' G = ') 99988 FORMAT (' G is not provided.') 99987 FORMAT (' Q = ') 99986 FORMAT (' Q is not provided.') 99985 FORMAT (' W = ') 99984 FORMAT (' W is not provided.') 99983 FORMAT (' R = ') 99982 FORMAT (' R is not provided.') 99981 FORMAT (' X = ') 99980 FORMAT (' X is not provided.') 99979 FORMAT (20(1X,F8.4)) * END slicot-5.0+20101122/examples77/TBB02AD.f000077500000000000000000000144771201767322700167070ustar00rootroot00000000000000* BB02AD EXAMPLE PROGRAM TEXT * * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 100, NMAX = 100, PMAX = 100 ) INTEGER LDA, LDB, LDC, LDQ, LDR, LDS, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDQ = NMAX, LDR = NMAX, LDS = NMAX, $ LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*NMAX ) * .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, ISYMM, J, LBPAR, LDPAR, LIPAR, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB,MMAX), C(LDC, NMAX), $ DPAR(4), DWORK(LDWORK), Q(LDQ, NMAX), $ R(LDR, NMAX), S(LDS, NMAX), X(LDX, NMAX) INTEGER IPAR(3), NR(2) LOGICAL BPAR(7), VEC(10) CHARACTER CHPAR*255 * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL BB02AD, MA02DD * .. Executable Statements .. WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ( NIN, FMT = '()' ) READ( NIN, FMT = * ) DEF READ( NIN, FMT = * ) ( NR(I), I = 1, 2 ) IF( LSAME( DEF, 'N' ) ) THEN READ( NIN, FMT = * ) LBPAR IF( LBPAR.GT.0 ) READ( NIN, FMT = * ) ( BPAR(I), I = 1, LBPAR ) READ( NIN, FMT = * ) LDPAR IF( LDPAR.GT.0 ) READ( NIN, FMT = * ) ( DPAR(I), I = 1, LDPAR ) READ( NIN, FMT = * ) LIPAR IF( LIPAR.GT.0 ) READ( NIN, FMT = * ) ( IPAR(I), I = 1, LIPAR ) END IF * Generate benchmark example CALL BB02AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, A, $ LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, X, LDX, $ DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99998 ) INFO ELSE WRITE( NOUT, FMT = * ) CHPAR(1:70) WRITE( NOUT, FMT = 99997 ) N WRITE( NOUT, FMT = 99996 ) M WRITE( NOUT, FMT = 99995 ) P WRITE( NOUT, FMT = 99994 ) DO 10 I = 1, N WRITE( NOUT, FMT = 99977 ) ( A(I,J), J = 1, N ) 10 CONTINUE IF( VEC(5) ) THEN WRITE( NOUT, FMT = 99993 ) DO 20 I = 1, N WRITE( NOUT, FMT = 99977 ) ( B(I,J), J = 1, M ) 20 CONTINUE ELSE WRITE( NOUT, FMT = 99992 ) END IF IF( VEC(6) ) THEN WRITE( NOUT,FMT = 99991 ) DO 30 I = 1, P WRITE( NOUT, FMT = 99977 ) ( C(I,J), J = 1, N ) 30 CONTINUE ELSE WRITE( NOUT, FMT = 99990 ) END IF IF( .NOT.VEC(5) ) THEN WRITE( NOUT, FMT = 99989 ) IF( .NOT.BPAR(2) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, R, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, R, LDR, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, R, LDR, DWORK ) END IF END IF DO 40 I = 1, N WRITE( NOUT, FMT = 99977 ) ( R(I,J), J = 1, N ) 40 CONTINUE ELSE WRITE( NOUT, FMT = 99988 ) END IF IF( .NOT.VEC(6) ) THEN IF( .NOT.BPAR(5) ) THEN ISYMM = ( N * ( N + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', N, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', N, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99987 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99977 ) ( Q(I,J), J = 1, N ) 50 CONTINUE ELSE WRITE( NOUT, FMT = 99986 ) END IF IF( VEC(6) ) THEN IF( .NOT.BPAR(5) ) THEN ISYMM = ( P * ( P + 1 ) ) / 2 CALL DCOPY( ISYMM, Q, 1, DWORK, 1 ) IF( BPAR(6) ) THEN CALL MA02DD( 'Unpack', 'Upper', P, Q, LDQ, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', P, Q, LDQ, DWORK ) END IF END IF WRITE( NOUT, FMT = 99985 ) DO 60 I = 1, P WRITE( NOUT, FMT = 99977 ) ( Q(I,J), J = 1, P ) 60 CONTINUE ELSE WRITE( NOUT, FMT = 99984 ) END IF IF( VEC(5) ) THEN IF( .NOT.BPAR(2) ) THEN ISYMM = ( M * ( M + 1 ) ) / 2 CALL DCOPY( ISYMM, R, 1, DWORK, 1 ) IF( BPAR(3) ) THEN CALL MA02DD( 'Unpack', 'Upper', M, R, LDR, DWORK ) ELSE CALL MA02DD( 'Unpack', 'Lower', M, R, LDR, DWORK ) END IF END IF WRITE( NOUT, FMT = 99983 ) DO 70 I = 1, M WRITE( NOUT, FMT = 99977 ) ( R(I,J), J = 1, M ) 70 CONTINUE ELSE WRITE( NOUT, FMT = 99982 ) END IF IF( VEC(9) ) THEN WRITE( NOUT, FMT = 99981 ) DO 80 I = 1, N WRITE( NOUT, FMT = 99977 ) ( S(I,J), J = 1, M ) 80 CONTINUE ELSE WRITE( NOUT, FMT = 99980 ) END IF IF( VEC(10) ) THEN WRITE( NOUT, FMT = 99979 ) DO 90 I = 1, N WRITE( NOUT, FMT = 99977 ) ( X(I,J), J = 1, N ) 90 CONTINUE ELSE WRITE( NOUT, FMT = 99978 ) END IF END IF STOP * 99999 FORMAT (' BB02AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB02AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (' A = ') 99993 FORMAT (' B = ') 99992 FORMAT (' B is not provided.') 99991 FORMAT (' C = ') 99990 FORMAT (' C is not provided.') 99989 FORMAT (' G = ') 99988 FORMAT (' G is not provided.') 99987 FORMAT (' Q = ') 99986 FORMAT (' Q is not provided.') 99985 FORMAT (' Q0 = ') 99984 FORMAT (' Q0 is not provided.') 99983 FORMAT (' R = ') 99982 FORMAT (' R is not provided.') 99981 FORMAT (' S = ') 99980 FORMAT (' S is not provided.') 99979 FORMAT (' X = ') 99978 FORMAT (' X is not provided.') 99977 FORMAT (20(1X,F8.4)) * END slicot-5.0+20101122/examples77/TBB03AD.f000077500000000000000000000070371201767322700167020ustar00rootroot00000000000000C BB03AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX PARAMETER (NMAX = 100, MMAX = 100) INTEGER LDE, LDA, LDY, LDB, LDX, LDU, LDWORK PARAMETER (LDE = NMAX, LDA = NMAX, LDY = NMAX, LDB = MMAX, 1 LDX = NMAX, LDU = NMAX, LDWORK = 2*NMAX) C .. Local Scalars .. CHARACTER DEF INTEGER INFO, N, M, I, J, LDPAR, LIPAR CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION E(LDE,NMAX), A(LDA, NMAX), Y(LDY, NMAX), 1 B(LDB,NMAX), X(LDX, NMAX), U(LDU, NMAX), 2 DPAR(2), DWORK(LDWORK) INTEGER NR(2), IPAR(1) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BB03AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, Y, 1 LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, LDWORK, 2 INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M IF (VEC(3)) THEN WRITE (NOUT, FMT = 99995) DO 10 I = 1, N WRITE (NOUT, FMT = 99985) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99994) END IF WRITE (NOUT,FMT = 99993) DO 20 I = 1, N WRITE (NOUT, FMT = 99985) (A(I,J), J = 1, N) 20 CONTINUE IF (VEC(6)) THEN WRITE (NOUT,FMT = 99992) DO 30 I = 1, M WRITE (NOUT, FMT = 99985) (B(I,J), J = 1, N) 30 CONTINUE ELSE WRITE (NOUT, FMT = 99991) END IF WRITE (NOUT,FMT = 99990) DO 40 I = 1, N WRITE (NOUT, FMT = 99985) (Y(I,J), J = 1, N) 40 CONTINUE IF (VEC(7)) THEN WRITE (NOUT, FMT = 99989) DO 50 I = 1, N WRITE (NOUT, FMT = 99985) (X(I,J), J = 1, N) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF IF (VEC(8)) THEN WRITE (NOUT, FMT = 99987) DO 60 I = 1, N WRITE (NOUT, FMT = 99985) (U(I,J), J = 1, N) 60 CONTINUE ELSE WRITE (NOUT, FMT = 99986) END IF END IF C 99999 FORMAT (' BB03AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB03AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of rows in matrix B: M = ', I3) 99995 FORMAT (/' E = ') 99994 FORMAT (/' E is the identity matrix.') 99993 FORMAT (' A = ') 99992 FORMAT (' B = ') 99991 FORMAT (' B is not provided.') 99990 FORMAT (' Y = ') 99989 FORMAT (' X = ') 99988 FORMAT (' X is not provided.') 99987 FORMAT (' U = ') 99986 FORMAT (' U is not provided.') 99985 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples77/TBB04AD.f000077500000000000000000000070371201767322700167030ustar00rootroot00000000000000C BB04AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX PARAMETER (NMAX = 100, MMAX = 100) INTEGER LDE, LDA, LDY, LDB, LDX, LDU, LDWORK PARAMETER (LDE = NMAX, LDA = NMAX, LDY = NMAX, LDB = MMAX, 1 LDX = NMAX, LDU = NMAX, LDWORK = 2*NMAX) C .. Local Scalars .. CHARACTER DEF INTEGER INFO, N, M, I, J, LDPAR, LIPAR CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION E(LDE,NMAX), A(LDA, NMAX), Y(LDY, NMAX), 1 B(LDB,NMAX), X(LDX, NMAX), U(LDU, NMAX), 2 DPAR(2), DWORK(LDWORK) INTEGER NR(2), IPAR(1) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BB04AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, Y, 1 LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, LDWORK, 2 INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M IF (VEC(3)) THEN WRITE (NOUT, FMT = 99995) DO 10 I = 1, N WRITE (NOUT, FMT = 99985) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99994) END IF WRITE (NOUT,FMT = 99993) DO 20 I = 1, N WRITE (NOUT, FMT = 99985) (A(I,J), J = 1, N) 20 CONTINUE IF (VEC(6)) THEN WRITE (NOUT,FMT = 99992) DO 30 I = 1, M WRITE (NOUT, FMT = 99985) (B(I,J), J = 1, N) 30 CONTINUE ELSE WRITE (NOUT, FMT = 99991) END IF WRITE (NOUT,FMT = 99990) DO 40 I = 1, N WRITE (NOUT, FMT = 99985) (Y(I,J), J = 1, N) 40 CONTINUE IF (VEC(7)) THEN WRITE (NOUT, FMT = 99989) DO 50 I = 1, N WRITE (NOUT, FMT = 99985) (X(I,J), J = 1, N) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF IF (VEC(8)) THEN WRITE (NOUT, FMT = 99987) DO 60 I = 1, N WRITE (NOUT, FMT = 99985) (U(I,J), J = 1, N) 60 CONTINUE ELSE WRITE (NOUT, FMT = 99986) END IF END IF C 99999 FORMAT (' BB04AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BB04AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of rows in matrix B: M = ', I3) 99995 FORMAT (/' E = ') 99994 FORMAT (/' E is the identity matrix.') 99993 FORMAT (' A = ') 99992 FORMAT (' B = ') 99991 FORMAT (' B is not provided.') 99990 FORMAT (' Y = ') 99989 FORMAT (' X = ') 99988 FORMAT (' X is not provided.') 99987 FORMAT (' U = ') 99986 FORMAT (' U is not provided.') 99985 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples77/TBD01AD.f000077500000000000000000000062401201767322700166750ustar00rootroot00000000000000C BD01AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX, PMAX PARAMETER (NMAX = 421, MMAX = 211, PMAX = 211) INTEGER LDA, LDB, LDC, LDD, LDE, LDWORK PARAMETER (LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, 1 LDE = NMAX, LDWORK = 4*NMAX) C .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, J, LDPAR, LIPAR, M, N, P CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), 1 D(LDD,MMAX), DPAR(7), DWORK(LDWORK), E(LDE,NMAX) INTEGER NR(2), IPAR(7) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BD01AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BD01AD(DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, LDA, 1 B, LDB, C, LDC, D, LDD, NOTE, DWORK, LDWORK, INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M WRITE (NOUT, FMT = 99995) P IF (VEC(4)) THEN WRITE (NOUT, FMT = 99994) DO 10 I = 1, N WRITE (NOUT, FMT = 99987) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99993) END IF WRITE (NOUT,FMT = 99992) DO 20 I = 1, N WRITE (NOUT, FMT = 99987) (A(I,J), J = 1, N) 20 CONTINUE WRITE (NOUT,FMT = 99991) DO 30 I = 1, N WRITE (NOUT, FMT = 99987) (B(I,J), J = 1, M) 30 CONTINUE WRITE (NOUT,FMT = 99990) DO 40 I = 1, P WRITE (NOUT, FMT = 99987) (C(I,J), J = 1, N) 40 CONTINUE IF (VEC(8)) THEN WRITE (NOUT,FMT = 99989) DO 50 I = 1, P WRITE (NOUT, FMT = 99987) (D(I,J), J = 1, M) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF END IF C 99999 FORMAT (' BD01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BD01AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (/' E = ') 99993 FORMAT (/' E is the identity matrix.') 99992 FORMAT (' A = ') 99991 FORMAT (' B = ') 99990 FORMAT (' C = ') 99989 FORMAT (' D = ') 99988 FORMAT (' D is of zeros.') 99987 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples77/TBD02AD.f000077500000000000000000000062331201767322700167000ustar00rootroot00000000000000C BD02AD EXAMPLE PROGRAM TEXT C Copyright (c) 2002-2010 NICONET e.V. C C .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN = 5, NOUT = 6) INTEGER NMAX, MMAX, PMAX PARAMETER (NMAX = 421, MMAX = 211, PMAX = 211) INTEGER LDA, LDB, LDC, LDD, LDE, LDWORK PARAMETER (LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, 1 LDE = NMAX, LDWORK = 1) C .. Local Scalars .. CHARACTER DEF INTEGER I, INFO, J, LDPAR, LIPAR, M, N, P CHARACTER*70 NOTE C .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), 1 D(LDD,MMAX), DPAR(7), DWORK(LDWORK), E(LDE,NMAX) INTEGER NR(2), IPAR(7) LOGICAL VEC(8) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL BD02AD C .. Executable Statements .. WRITE (NOUT, FMT = 99999) C Skip the heading in the data file and read the data. READ (NIN, FMT = '()') READ (NIN, FMT = *) DEF READ (NIN, FMT = *) (NR(I), I = 1, 2) IF (LSAME(DEF,'N')) THEN READ (NIN, FMT = *) LDPAR IF (LDPAR .GT. 0) READ (NIN, FMT = *) (DPAR(I), I = 1, LDPAR) READ (NIN, FMT = *) LIPAR IF (LIPAR .GT. 0) READ (NIN, FMT = *) (IPAR(I), I = 1, LIPAR) END IF C Generate benchmark example CALL BD02AD(DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, LDA, 1 B, LDB, C, LDC, D, LDD, NOTE, DWORK, LDWORK, INFO) C IF (INFO .NE. 0) THEN WRITE (NOUT, FMT = 99998) INFO ELSE WRITE (NOUT, FMT = *) NOTE WRITE (NOUT, FMT = 99997) N WRITE (NOUT, FMT = 99996) M WRITE (NOUT, FMT = 99995) P IF (VEC(4)) THEN WRITE (NOUT, FMT = 99994) DO 10 I = 1, N WRITE (NOUT, FMT = 99987) (E(I,J), J = 1, N) 10 CONTINUE ELSE WRITE (NOUT, FMT = 99993) END IF WRITE (NOUT,FMT = 99992) DO 20 I = 1, N WRITE (NOUT, FMT = 99987) (A(I,J), J = 1, N) 20 CONTINUE WRITE (NOUT,FMT = 99991) DO 30 I = 1, N WRITE (NOUT, FMT = 99987) (B(I,J), J = 1, M) 30 CONTINUE WRITE (NOUT,FMT = 99990) DO 40 I = 1, P WRITE (NOUT, FMT = 99987) (C(I,J), J = 1, N) 40 CONTINUE IF (VEC(8)) THEN WRITE (NOUT,FMT = 99989) DO 50 I = 1, P WRITE (NOUT, FMT = 99987) (D(I,J), J = 1, M) 50 CONTINUE ELSE WRITE (NOUT, FMT = 99988) END IF END IF C 99999 FORMAT (' BD02AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from BD02AD = ', I3) 99997 FORMAT (/' Order of matrix A: N = ', I3) 99996 FORMAT (' Number of columns in matrix B: M = ', I3) 99995 FORMAT (' Number of rows in matrix C: P = ', I3) 99994 FORMAT (/' E = ') 99993 FORMAT (/' E is the identity matrix.') 99992 FORMAT (' A = ') 99991 FORMAT (' B = ') 99990 FORMAT (' C = ') 99989 FORMAT (' D = ') 99988 FORMAT (' D is of zeros.') 99987 FORMAT (20(1X,F8.4)) C END slicot-5.0+20101122/examples77/TC01OD.dat000077500000000000000000000003141201767322700171270ustar00rootroot00000000000000 TC01OD EXAMPLE PROGRAM DATA 2 2 3 L 2.0 3.0 1.0 4.0 -1.0 -1.0 5.0 7.0 -6.0 3.0 2.0 2.0 6.0 -1.0 5.0 1.0 7.0 5.0 1.0 1.0 1.0 4.0 1.0 -1.0 slicot-5.0+20101122/examples77/TC01OD.res000077500000000000000000000010011201767322700171420ustar00rootroot00000000000000 TC01OD EXAMPLE PROGRAM RESULTS The coefficients of the denominator matrix of the dual system are element ( 1, 1) is 2.00 3.00 1.00 element ( 1, 2) is 5.00 7.00 -6.00 element ( 2, 1) is 4.00 -1.00 -1.00 element ( 2, 2) is 3.00 2.00 2.00 The coefficients of the numerator matrix of the dual system are element ( 1, 1) is 6.00 -1.00 5.00 element ( 1, 2) is 1.00 1.00 1.00 element ( 2, 1) is 1.00 7.00 5.00 element ( 2, 2) is 4.00 1.00 -1.00 slicot-5.0+20101122/examples77/TC04AD.dat000077500000000000000000000003211201767322700171120ustar00rootroot00000000000000 TC04AD EXAMPLE PROGRAM DATA 2 2 L 2 2 2.0 3.0 1.0 4.0 -1.0 -1.0 5.0 7.0 -6.0 3.0 2.0 2.0 6.0 -1.0 5.0 1.0 7.0 5.0 1.0 1.0 1.0 4.0 1.0 -1.0 slicot-5.0+20101122/examples77/TC04AD.res000077500000000000000000000011061201767322700171350ustar00rootroot00000000000000 TC04AD EXAMPLE PROGRAM RESULTS The order of the resulting state-space representation = 4 RCOND = 0.25 The state dynamics matrix A is 0.0000 0.5714 0.0000 -0.4286 1.0000 1.0000 0.0000 -1.0000 0.0000 -2.0000 0.0000 2.0000 0.0000 0.7857 1.0000 -1.7143 The input/state matrix B is 8.0000 3.8571 4.0000 4.0000 -9.0000 5.0000 4.0000 -5.0714 The state/output matrix C is 0.0000 -0.2143 0.0000 0.2857 0.0000 0.3571 0.0000 -0.1429 The direct transmission matrix D is -1.0000 0.9286 2.0000 -0.2143 slicot-5.0+20101122/examples77/TC05AD.dat000077500000000000000000000003371201767322700171220ustar00rootroot00000000000000 TC05AD EXAMPLE PROGRAM DATA 2 2 (0.0,0.5) L 2 2 2.0 3.0 1.0 4.0 -1.0 -1.0 5.0 7.0 -6.0 3.0 2.0 2.0 6.0 -1.0 5.0 1.0 7.0 5.0 1.0 1.0 1.0 4.0 1.0 -1.0 slicot-5.0+20101122/examples77/TC05AD.res000077500000000000000000000002311201767322700171340ustar00rootroot00000000000000 TC05AD EXAMPLE PROGRAM RESULTS RCOND = 0.19 The frequency response matrix T(SVAL) is (-0.25,-0.33) ( 0.26,-0.45) (-1.48, 0.35) (-2.25,-1.11) slicot-5.0+20101122/examples77/TD03AD.dat000077500000000000000000000003431201767322700171160ustar00rootroot00000000000000 TD01ND EXAMPLE PROGRAM DATA 2 2 0.0 R L N 3 3 1.0 6.0 11.0 6.0 1.0 6.0 11.0 6.0 1.0 6.0 12.0 7.0 0.0 1.0 4.0 3.0 0.0 0.0 1.0 1.0 1.0 8.0 20.0 15.0 slicot-5.0+20101122/examples77/TD03AD.res000077500000000000000000000016721201767322700171450ustar00rootroot00000000000000 TD03AD EXAMPLE PROGRAM RESULTS The order of the resulting minimal realization = 3 The state dynamics matrix A is 0.5000 0.9478 10.1036 0.0000 -1.0000 0.0000 -0.8660 -0.6156 -5.5000 The input/state matrix B is 2.0000 12.5000 0.0000 -5.6273 0.0000 -2.0207 The state/output matrix C is 0.0000 0.0296 -0.5774 0.0000 -0.1481 -0.5774 The direct transmission matrix D is 1.0000 0.0000 0.0000 1.0000 The observability index of the minimal realization = 2 The dimensions of the diagonal blocks of the state dynamics matrix are 2 1 The row degrees of the denominator matrix P(s) are 2 1 The denominator matrix P(s) is 1.6667 4.3333 6.6667 0.3333 5.6667 5.3333 5.6273 5.6273 0.0000 -5.6273 -5.6273 0.0000 The numerator matrix Q(s) is 1.6667 4.3333 8.6667 0.3333 8.0000 16.6667 5.6273 5.6273 0.0000 -5.6273 -11.2546 0.0000 slicot-5.0+20101122/examples77/TD04AD.dat000077500000000000000000000003271201767322700171210ustar00rootroot00000000000000 TD04AD EXAMPLE PROGRAM DATA 2 2 0.0 R 3 3 1.0 6.0 11.0 6.0 1.0 6.0 11.0 6.0 1.0 6.0 12.0 7.0 0.0 1.0 4.0 3.0 0.0 0.0 1.0 1.0 1.0 8.0 20.0 15.0 slicot-5.0+20101122/examples77/TD04AD.res000077500000000000000000000012411201767322700171360ustar00rootroot00000000000000 TD04AD EXAMPLE PROGRAM RESULTS The order of the minimal realization = 3 The state dynamics matrix A of a minimal realization is 0.5000 -0.8028 0.9387 4.4047 -2.3380 2.5076 -5.5541 1.6872 -4.1620 The input/state matrix B of a minimal realization is -0.2000 -1.2500 0.0000 -0.6097 0.0000 2.2217 The state/output matrix C of a minimal realization is 0.0000 -0.8679 0.2119 0.0000 0.0000 0.9002 The direct transmission matrix D is 1.0000 0.0000 0.0000 1.0000 The observability index of a minimal state-space representation = 2 The dimensions of the diagonal blocks of the state dynamics matrix are 2 1 slicot-5.0+20101122/examples77/TD05AD.dat000077500000000000000000000001721201767322700171200ustar00rootroot00000000000000 TD05AD EXAMPLE PROGRAM DATA 6 4 1.0 R C 1.0 1.0 0.0 0.0 2.0 1.0 6.0 2.0 3.0 1.0 slicot-5.0+20101122/examples77/TD05AD.res000077500000000000000000000001171201767322700171400ustar00rootroot00000000000000 TD05AD EXAMPLE PROGRAM RESULTS Complex value of G(jW) = 0.8462 -0.2308*j slicot-5.0+20101122/examples77/TDE01OD.f000077500000000000000000000032051201767322700167140ustar00rootroot00000000000000* DE01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 CONV * .. Local Arrays .. DOUBLE PRECISION A(NMAX), B(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DE01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, CONV IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( A(I), B(I), I = 1,N ) * Perform convolution on A and B. CALL DE01OD( CONV, N, A, B, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( CONV, 'C' ) ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99996 ) END IF DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DE01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DE01OD = ',I2) 99997 FORMAT (' Convolution ',//' i A(i)',/) 99996 FORMAT (' Deconvolution ',//' i A(i)',/) 99995 FORMAT (I4,1X,F8.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TDE01PD.f000077500000000000000000000032431201767322700167170ustar00rootroot00000000000000* DE01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 CONV, WGHT * .. Local Arrays .. DOUBLE PRECISION A(NMAX), B(NMAX), W(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DE01PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, CONV, WGHT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( A(I), B(I), I = 1,N ) * Perform convolution on A and B. CALL DE01PD( CONV, WGHT, N, A, B, W, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( CONV, 'C' ) ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99996 ) END IF DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DE01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DE01PD = ',I2) 99997 FORMAT (' Convolution ',//' i A(i)',/) 99996 FORMAT (' Deconvolution ',//' i A(i)',/) 99995 FORMAT (I4,1X,F8.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TDF01MD.f000077500000000000000000000035641201767322700167230ustar00rootroot00000000000000* DF01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 129 ) * .. Local Scalars .. DOUBLE PRECISION DT INTEGER I, INFO, N CHARACTER*1 SICO * .. Local Arrays .. DOUBLE PRECISION A(NMAX), DWORK(NMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DF01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DT, SICO IF ( N.LE.1 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,N ) * Compute the sine/cosine transform of the given real signal. CALL DF01MD( SICO, N, DT, A, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( SICO, 'S' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 20 CONTINUE ELSE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) I, A(I) 40 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' DF01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DF01MD = ',I2) 99997 FORMAT (' Components of sine transform are',//' i',6X,'A(i)',/) 99996 FORMAT (' Components of cosine transform are',//' i',6X,'A(i)', $ /) 99995 FORMAT (I4,3X,F8.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TDG01MD.f000077500000000000000000000027301201767322700167160ustar00rootroot00000000000000* DG01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 INDI * .. Local Arrays .. DOUBLE PRECISION XI(NMAX), XR(NMAX) * .. External Subroutines .. EXTERNAL DG01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, INDI IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( XR(I), XI(I), I = 1,N ) * Find the Fourier transform of the given complex signal. CALL DG01MD( INDI, N, XR, XI, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, XR(I), XI(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DG01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DG01MD = ',I2) 99997 FORMAT (' Components of Fourier transform are',//' i',6X, $ 'XR(i)',6X,'XI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TDG01ND.f000077500000000000000000000034571201767322700167260ustar00rootroot00000000000000* DG01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, IEND, INFO, N CHARACTER*1 INDI * .. Local Arrays .. DOUBLE PRECISION A(2*NMAX), XI(NMAX+1), XR(NMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DG01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, INDI IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,2*N ) * Copy the odd and even parts of A into XR and XI respectively. DO 20 I = 1, N XR(I) = A(2*I-1) XI(I) = A(2*I) 20 CONTINUE * Find the Fourier transform of the given real signal. CALL DG01ND( INDI, N, XR, XI, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) IEND = N IF ( LSAME( INDI, 'D' ) ) IEND = N + 1 DO 40 I = 1, IEND WRITE ( NOUT, FMT = 99996 ) I, XR(I), XI(I) 40 CONTINUE END IF END IF STOP * 99999 FORMAT (' DG01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DG01ND = ',I2) 99997 FORMAT (' Components of Fourier transform are',//' i',6X, $ 'XR(i)',6X,'XI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TDG01OD.f000077500000000000000000000026051201767322700167210ustar00rootroot00000000000000* DG01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 128 ) * .. Local Scalars .. INTEGER I, INFO, N CHARACTER*1 SCR, WGHT * .. Local Arrays .. DOUBLE PRECISION A(NMAX), W(NMAX) * .. External Subroutines .. EXTERNAL DG01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, SCR, WGHT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,N ) * Compute the Hartley transform. CALL DG01OD( SCR, WGHT, N, A, W, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, A(I) 10 CONTINUE END IF END IF STOP * 99999 FORMAT (' DG01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DG01OD = ',I2) 99997 FORMAT (' Hartley transform ',//' i A(i)',/) 99996 FORMAT (I4,1X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TDK01MD.f000077500000000000000000000026371201767322700167300ustar00rootroot00000000000000* DK01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) * .. Local Scalars .. CHARACTER*1 TYPE INTEGER I, INFO, N * .. Local Arrays .. DOUBLE PRECISION A(NMAX) * .. External Subroutines .. EXTERNAL DK01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TYPE IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,N ) * Apply a Hamming window to the given signal. CALL DK01MD( TYPE, N, A, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, A(I) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' DK01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DK01MD = ',I2) 99997 FORMAT (' Components of the windowing function are',//' k ', $ ' A(k)',/) 99996 FORMAT (I4,3X,F8.4) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TF01MD.dat000077500000000000000000000007231201767322700171340ustar00rootroot00000000000000 TF01MD EXAMPLE PROGRAM DATA 3 2 2 10 0.0000 -0.0700 0.0150 1.0000 0.8000 -0.1500 0.0000 0.0000 0.5000 0.0000 2.0000 1.0000 -1.0000 -0.1000 1.0000 0.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.5000 0.0000 0.5000 1.0000 1.0000 1.0000 -0.6922 -1.4934 0.3081 -2.7726 2.0039 0.2614 -0.9160 -0.6030 1.2556 0.2951 -1.5734 1.5639 -0.9942 1.8957 0.8988 0.4118 -1.4893 -0.9344 1.2506 -0.0701 slicot-5.0+20101122/examples77/TF01MD.res000077500000000000000000000006731201767322700171610ustar00rootroot00000000000000 TF01MD EXAMPLE PROGRAM RESULTS The output sequence Y(1),...,Y(10) is Y( 1) : 0.3078 -0.0928 Y( 2) : -1.5125 1.2611 Y( 3) : -1.2577 3.4002 Y( 4) : -0.2947 -0.7060 Y( 5) : -0.5632 5.4532 Y( 6) : -1.0846 1.1846 Y( 7) : -1.2427 2.2286 Y( 8) : 1.8097 -1.9534 Y( 9) : 0.6685 -4.4965 Y(10) : -0.0896 1.1654 slicot-5.0+20101122/examples77/TF01ND.dat000077500000000000000000000007311201767322700171340ustar00rootroot00000000000000 TF01ND EXAMPLE PROGRAM DATA 3 2 2 10 U 0.0000 -0.0700 0.0000 1.0000 0.8000 -0.1500 0.0000 0.0000 0.5000 0.0000 2.0000 1.0000 -1.0000 -0.1000 1.0000 0.0000 1.0000 0.0000 0.0000 1.0000 0.0000 1.0000 0.5000 0.0000 0.5000 1.0000 1.0000 1.0000 -0.6922 -1.4934 0.3081 -2.7726 2.0039 0.2614 -0.9160 -0.6030 1.2556 0.2951 -1.5734 1.5639 -0.9942 1.8957 0.8988 0.4118 -1.4893 -0.9344 1.2506 -0.0701 slicot-5.0+20101122/examples77/TF01ND.res000077500000000000000000000006731201767322700171620ustar00rootroot00000000000000 TF01ND EXAMPLE PROGRAM RESULTS The output sequence Y(1),...,Y(10) is Y( 1) : 0.3078 -0.0928 Y( 2) : -1.5275 1.2611 Y( 3) : -1.3026 3.4002 Y( 4) : -0.3512 -0.7060 Y( 5) : -0.5922 5.4532 Y( 6) : -1.1693 1.1846 Y( 7) : -1.3029 2.2286 Y( 8) : 1.7529 -1.9534 Y( 9) : 0.6793 -4.4965 Y(10) : -0.0349 1.1654 slicot-5.0+20101122/examples77/TF01OD.dat000077500000000000000000000003361201767322700171360ustar00rootroot00000000000000 TF01OD EXAMPLE PROGRAM DATA 2 2 3 3 1.0647 -0.4282 -0.4922 -1.2072 -0.3043 0.6883 -0.0926 0.7167 -0.1844 -0.8507 0.4441 -0.0478 0.7195 0.0500 -0.3955 0.5674 1.3387 -0.2801 0.1073 -0.5315 slicot-5.0+20101122/examples77/TF01OD.res000077500000000000000000000006061201767322700171570ustar00rootroot00000000000000 TF01OD EXAMPLE PROGRAM RESULTS The 6 by 6 matrix T is 1.0647 -0.4922 -0.3043 -0.0926 -0.1844 0.4441 -0.4282 -1.2072 0.6883 0.7167 -0.8507 -0.0478 -0.3043 -0.0926 -0.1844 0.4441 0.7195 -0.3955 0.6883 0.7167 -0.8507 -0.0478 0.0500 0.5674 -0.1844 0.4441 0.7195 -0.3955 1.3387 0.1073 -0.8507 -0.0478 0.0500 0.5674 -0.2801 -0.5315 slicot-5.0+20101122/examples77/TF01PD.dat000077500000000000000000000003361201767322700171370ustar00rootroot00000000000000 TF01PD EXAMPLE PROGRAM DATA 2 2 3 3 1.0647 -0.4282 -0.4922 -1.2072 -0.3043 0.6883 -0.0926 0.7167 -0.1844 -0.8507 0.4441 -0.0478 0.7195 0.0500 -0.3955 0.5674 1.3387 -0.2801 0.1073 -0.5315 slicot-5.0+20101122/examples77/TF01PD.res000077500000000000000000000006061201767322700171600ustar00rootroot00000000000000 TF01PD EXAMPLE PROGRAM RESULTS The 6 by 6 matrix T is -0.1844 0.4441 -0.3043 -0.0926 1.0647 -0.4922 -0.8507 -0.0478 0.6883 0.7167 -0.4282 -1.2072 0.7195 -0.3955 -0.1844 0.4441 -0.3043 -0.0926 0.0500 0.5674 -0.8507 -0.0478 0.6883 0.7167 1.3387 0.1073 0.7195 -0.3955 -0.1844 0.4441 -0.2801 -0.5315 0.0500 0.5674 -0.8507 -0.0478 slicot-5.0+20101122/examples77/TF01QD.dat000077500000000000000000000003131201767322700171330ustar00rootroot00000000000000 TF01QD EXAMPLE PROGRAM DATA 8 10 2 2 2 1.0 -0.5 0.6 -0.2 1 1.0 -0.8 3 0.5 -0.4 0.3 0.8 0.4 0.1 4 1.0 0.5 -0.5 0.0 -0.8 0.6 0.0 -0.2 slicot-5.0+20101122/examples77/TF01QD.res000077500000000000000000000010031201767322700171510ustar00rootroot00000000000000 TF01QD EXAMPLE PROGRAM RESULTS The Markov Parameters M(1),...,M(8) are M(1) : 1.0000 1.0000 0.5000 1.0000 M(2) : -1.1000 0.8000 -0.8000 1.3000 M(3) : 0.8600 0.6400 0.7400 -0.0600 M(4) : -0.7360 0.5120 -0.3220 -0.8280 M(5) : 0.6136 0.4096 0.0416 -0.4264 M(6) : -0.5154 0.3277 0.0215 0.4157 M(7) : 0.4319 0.2621 -0.0017 0.5764 M(8) : -0.3622 0.2097 -0.0114 0.0461 slicot-5.0+20101122/examples77/TF01RD.dat000077500000000000000000000003251201767322700171370ustar00rootroot00000000000000 TF01RD EXAMPLE PROGRAM DATA 5 3 2 2 0.000 -0.070 0.015 1.000 0.800 -0.150 0.000 0.000 0.500 0.000 2.000 1.000 -1.000 -0.100 1.000 0.000 1.000 0.000 0.000 1.000 0.000 slicot-5.0+20101122/examples77/TF01RD.res000077500000000000000000000005361201767322700171640ustar00rootroot00000000000000 TF01RD EXAMPLE PROGRAM RESULTS The Markov Parameters M(1),...,M(5) are M(1) : 1.0000 1.0000 0.0000 -1.0000 M(2) : 0.2000 0.5000 2.0000 -0.1000 M(3) : -0.1100 0.2500 1.6000 -0.0100 M(4) : -0.2020 0.1250 1.1400 -0.0010 M(5) : -0.2039 0.0625 0.8000 -0.0001 slicot-5.0+20101122/examples77/TFB01QD.f000077500000000000000000000102551201767322700167200ustar00rootroot00000000000000* FB01QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDK, LDQ, LDR, LDS PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDK = NMAX, LDQ = MMAX, LDR = PMAX, $ LDS = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*(PMAX+NMAX)+2*PMAX + $ NMAX*(NMAX+MMAX+2) + 3*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBK, MULTBQ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DIAG(PMAX), DWORK(LDWORK), K(LDK,PMAX), $ Q(LDQ,MMAX), R(LDR,PMAX), S(LDS,NMAX) INTEGER IWORK(PMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBK, TOL, MULTBQ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( LSAME( MULTBQ, 'N' ) ) READ ( NIN, FMT = *) $ ( ( Q(I,J), J = 1,M ), I = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,P ), I = 1,P ) * Save the strict lower triangle of R in its strict upper * triangle and the diagonal in the array DIAG. DO 10 I = 2, P CALL DCOPY( I, R(I,1), LDR, R(1,I), 1 ) 10 CONTINUE CALL DCOPY( P, R, LDR+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter recursion * (in square root covariance form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the lower triangle of R. DO 30 I = 2, P CALL DCOPY( I, R(1,I), 1, R(I,1), LDR ) 30 CONTINUE CALL DCOPY( P, DIAG, 1, R, LDR+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( S(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBK, 'K' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( K(I,J), J = 1,P ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01QD = ',I2) 99997 FORMAT (' The square root of the state covariance matrix is ') 99996 FORMAT (/' The Kalman gain matrix is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TFB01RD.f000077500000000000000000000103161201767322700167170ustar00rootroot00000000000000* FB01RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDK, LDQ, LDR, LDS PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDK = NMAX, $ LDQ = MMAX, LDR = PMAX, LDS = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*(PMAX+NMAX+1) + $ NMAX*(PMAX+NMAX)+2*PMAX + $ NMAX*(NMAX+MMAX+2) + 3*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBK, MULTBQ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DIAG(PMAX), DWORK(LDWORK), K(LDK,PMAX), $ Q(LDQ,MMAX), R(LDR,PMAX), S(LDS,NMAX) INTEGER IWORK(PMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBK, TOL, MULTBQ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( LSAME( MULTBQ, 'N' ) ) READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,M ), I = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,P ), I = 1,P ) * Save the strict lower triangle of R in its strict upper * triangle and the diagonal in the array DIAG. DO 10 I = 2, P CALL DCOPY( I, R(I,1), LDR, R(1,I), 1 ) 10 CONTINUE CALL DCOPY( P, R, LDR+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter recursion * (in square root covariance form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the lower triangle of R. DO 30 I = 2, P CALL DCOPY( I, R(1,I), 1, R(I,1), LDR ) 30 CONTINUE CALL DCOPY( P, DIAG, 1, R, LDR+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( S(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBK, 'K' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( K(I,J), J = 1,P ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01QD = ',I2) 99997 FORMAT (' The square root of the state covariance matrix is ') 99996 FORMAT (/' The Kalman gain matrix is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TFB01SD.f000077500000000000000000000113031201767322700167150ustar00rootroot00000000000000* FB01SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV PARAMETER ( LDAINV = NMAX, LDB = NMAX, LDC = PMAX, $ LDQINV = MMAX, LDRINV = PMAX, LDSINV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*(NMAX + 2*MMAX) + 3*MMAX + $ (NMAX + PMAX)*(NMAX + 1) + 2*NMAX + $ 3*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBX, MULTAB, MULTRC * .. Local Arrays .. DOUBLE PRECISION AINV(LDAINV,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DIAG(MMAX), DWORK(LDWORK), E(PMAX), $ QINV(LDQINV,MMAX), RINV(LDRINV,PMAX), $ RINVY(PMAX), SINV(LDSINV,NMAX), X(NMAX), Z(MMAX) INTEGER IWORK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBX, TOL, MULTAB, MULTRC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( AINV(I,J), J = 1,N ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( MULTRC, 'N' ) ) READ ( NIN, FMT = * ) $ ( ( RINV(I,J), J = 1,P ), I = 1,P ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QINV(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( SINV(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( Z(J), J = 1,M ) READ ( NIN, FMT = * ) ( X(J), J = 1,N ) READ ( NIN, FMT = * ) ( RINVY(J), J = 1,P ) * Save the strict upper triangle of QINV in its strict * lower triangle and the diagonal in the array DIAG. DO 10 I = 2, M CALL DCOPY( I, QINV(1,I), 1, QINV(I,1), LDQINV ) 10 CONTINUE CALL DCOPY( M, QINV, LDQINV+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter recursion * (in square root information form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the upper triangle of QINV. DO 30 I = 2, M CALL DCOPY( I, QINV(I,1), LDQINV, QINV(1,I), 1 ) 30 CONTINUE CALL DCOPY( M, DIAG, 1, QINV, LDQINV+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( SINV(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBX, 'X' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99994 ) I, X(I) 50 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01SD = ',I2) 99997 FORMAT (' The inverse of the square root of the state covariance', $ ' matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The components of the estimated filtered state are ', $ //' k X(k)',/) 99994 FORMAT (I4,3X,F8.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TFB01TD.f000077500000000000000000000114311201767322700167200ustar00rootroot00000000000000* FB01TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDAINB, LDAINV, LDC, LDQINV, LDRINV, LDSINV PARAMETER ( LDAINB = NMAX, LDAINV = NMAX, LDC = PMAX, $ LDQINV = MMAX, LDRINV = PMAX, LDSINV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*(NMAX + 2*MMAX) + 3*MMAX + $ ( NMAX + PMAX)*(NMAX + 1) + NMAX + $ ( NMAX - 1 + MMAX + 1 ) + $ 3*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, ISTEP, J, M, N, P CHARACTER*1 JOBX, MULTRC * .. Local Arrays .. DOUBLE PRECISION AINV(LDAINV,NMAX), AINVB(LDAINB,MMAX), $ C(LDC,NMAX), DIAG(MMAX), DWORK(LDWORK), E(PMAX), $ QINV(LDQINV,MMAX), RINV(LDRINV,PMAX), $ RINVY(PMAX), SINV(LDSINV,NMAX), X(NMAX), Z(MMAX) INTEGER IWORK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DCOPY, FB01TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOBX, TOL, MULTRC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( AINV(I,J), J = 1,N ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( MULTRC, 'N' ) ) READ ( NIN, FMT = * ) $ ( ( RINV(I,J), J = 1,P ), I = 1,P ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) $ ( ( AINVB(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QINV(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( SINV(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( Z(J), J = 1,M ) READ ( NIN, FMT = * ) ( X(J), J = 1,N ) READ ( NIN, FMT = * ) ( RINVY(J), J = 1,P ) * Save the strict upper triangle of QINV in its strict * lower triangle and the diagonal in the array DIAG. DO 10 I = 2, M CALL DCOPY( I, QINV(1,I), 1, QINV(I,1), LDQINV ) 10 CONTINUE CALL DCOPY( M, QINV, LDQINV+1, DIAG, 1 ) * Perform three iterations of the (Kalman) filter * recursion (in square root information form). ISTEP = 1 20 CONTINUE CALL 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 ) ISTEP = ISTEP + 1 IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN * Restore the upper triangle of QINV. DO 30 I = 2, M CALL DCOPY( I, QINV(I,1), LDQINV, QINV(1,I), 1 ) 30 CONTINUE CALL DCOPY( M, DIAG, 1, QINV, LDQINV+1 ) GO TO 20 END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( SINV(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( JOBX, 'X' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99994 ) I, X(I) 50 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01TD = ',I2) 99997 FORMAT (' The inverse of the square root of the state covariance', $ ' matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The components of the estimated filtered state are ', $ //' k X(k)',/) 99994 FORMAT (I4,3X,F8.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TFB01VD.f000077500000000000000000000065721201767322700167340ustar00rootroot00000000000000* FB01VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, LMAX PARAMETER ( NMAX = 20, MMAX = 20, LMAX = 20 ) INTEGER LDA, LDB, LDC, LDK, LDP, LDQ, LDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = LMAX, LDK = NMAX, $ LDP = NMAX, LDQ = MMAX, LDR = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( LMAX*NMAX + 3*LMAX + NMAX*NMAX + $ MMAX*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, L, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), K(LDK,LMAX), P(LDP,NMAX), $ Q(LDQ,MMAX), R(LDR,LMAX) INTEGER IWORK(LMAX) * .. External Subroutines .. EXTERNAL DCOPY, FB01VD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, L, TOL IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( P(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,M ), I = 1,M ) IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99991 ) L ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,L ), I = 1,L ) * Perform one iteration of the (Kalman) filter recursion. CALL FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, $ Q, LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N CALL DCOPY( I-1, P(1,I), 1, P(I,1), LDP ) WRITE ( NOUT, FMT = 99994 ) ( P(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( K(I,J), J = 1,L ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, L WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1,L ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' FB01VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from FB01VD = ',I3) 99997 FORMAT (' The state covariance matrix is ') 99996 FORMAT (/' The Kalman filter gain matrix is ') 99995 FORMAT (/' The square root of the covariance matrix of the innov', $ 'ations is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' L is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TFD01AD.f000077500000000000000000000100241201767322700166740ustar00rootroot00000000000000* FD01AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT, NOUT1 PARAMETER ( NIN = 5, NOUT = 6, NOUT1 = 7 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER IMAX, LMAX PARAMETER ( IMAX = 500, LMAX = 10 ) DOUBLE PRECISION LAMBDA PARAMETER ( LAMBDA = 0.99D0 ) * .. Local Scalars .. CHARACTER JP INTEGER I, INFO, IWARN, L DOUBLE PRECISION DELTA, EFOR, EOUT, EPOS, XIN, YIN * .. Local Arrays .. DOUBLE PRECISION CTETA(LMAX), EPSBCK(LMAX+1), SALPH(LMAX), $ STETA(LMAX), XF(LMAX), YQ(LMAX) * .. External Functions .. DOUBLE PRECISION XFCN, YFCN EXTERNAL XFCN, YFCN * NOTE: XFCN() generates at each iteration the next sample of the * input sequence. YFCN() generates at each iteration the next * sample of the reference sequence. These functions are user * defined (obtained from data acquisition devices, for * example). * .. External Subroutines .. EXTERNAL FD01AD * * .. File for the output error sequence .. OPEN ( UNIT = NOUT1, FILE = 'ERR.OUT', STATUS = 'REPLACE' ) * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, DELTA, JP IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE IF ( DELTA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99991 ) ELSE * DO 10 I = 1, L CTETA(I) = ONE STETA(I) = ZERO EPSBCK(I) = ZERO XF(I) = ZERO YQ(I) = ZERO 10 CONTINUE EPSBCK(L+1) = ONE EFOR = DELTA * .. Run least squares filter. DO 20 I = 1, IMAX XIN = XFCN(I) YIN = YFCN(I) CALL FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK, $ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN, $ INFO) WRITE(NOUT1,*) EOUT 20 CONTINUE CLOSE(NOUT1) * NOTE: File 'ERR.OUT' now contains the output error * sequence. * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99996 ) I, XF(I), YQ(I), EPSBCK(I) 30 CONTINUE WRITE ( NOUT, FMT = 99995 ) L+1, EPSBCK(L+1) WRITE ( NOUT, FMT = 99994 ) EFOR IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99993 ) IWARN END IF END IF END IF END IF STOP * 99999 FORMAT (' FD01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from FD01AD = ', I2) 99997 FORMAT (' i', 7X, 'XF(i)', 7X, 'YQ(i)', 6X, 'EPSBCK(i)', /1X) 99996 FORMAT ( I3, 2X, 3(2X, F10.6)) 99995 FORMAT ( I3, 28X, F10.6, /1X) 99994 FORMAT (' EFOR = ', D10.3) 99993 FORMAT (' IWARN on exit from FD01AD = ', I2) 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' The exponentially weighted forward prediction error', $ ' energy must be non-negative.' ) * END * * .. Example functions .. * DOUBLE PRECISION FUNCTION XFCN( I ) * .. Intrinsic Functions .. INTRINSIC DBLE, SIN * .. Local Scalar .. INTEGER I * .. Executable Statements .. XFCN = SIN( 0.3D0*DBLE( I ) ) * *** Last line of XFCN *** END * DOUBLE PRECISION FUNCTION YFCN( I ) * .. Intrinsic Functions .. INTRINSIC DBLE, SIN * .. Local Scalar .. INTEGER I * .. Executable Statements .. YFCN = 0.5D0 * SIN( 0.3D0*DBLE( I ) ) + $ 2.0D0 * SIN( 0.3D0*DBLE( I-1 ) ) * *** Last line of YFCN *** END slicot-5.0+20101122/examples77/TG01AD.dat000077500000000000000000000010211201767322700171110ustar00rootroot00000000000000TG01AD EXAMPLE PROGRAM DATA 4 4 2 2 A 0.0 -1 0 0 0.003 0 0 0.1000 0.02 100 10 0 0.4 0 0 0 0.0 1 0.2 0 0.0 0 1 0 0.01 300 90 6 0.3 0 0 20 0.0 10 0 0 0 0 1000 10000 10000 -0.1 0.0 0.001 0.0 0.0 0.01 -0.001 0.0001 slicot-5.0+20101122/examples77/TG01AD.res000077500000000000000000000020421201767322700171360ustar00rootroot00000000000000 TG01AD EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix Dl*A*Dr is -1.0000 0.0000 0.0000 0.3000 0.0000 0.0000 1.0000 2.0000 1.0000 0.1000 0.0000 0.4000 0.0000 0.0000 0.0000 0.0000 The transformed descriptor matrix Dl*E*Dr is 1.0000 0.2000 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 3.0000 0.9000 0.6000 0.3000 0.0000 0.0000 0.2000 0.0000 The transformed input/state matrix Dl*B is 100.0000 0.0000 0.0000 0.0000 0.0000 100.0000 100.0000 100.0000 The transformed state/output matrix C*Dr is -0.0100 0.0000 0.0010 0.0000 0.0000 0.0010 -0.0010 0.0010 The diagonal of left scaling matrix Dl is 10.0000 10.0000 0.1000 0.0100 The diagonal of right scaling matrix Dr is 0.1000 0.1000 1.0000 10.0000 Norm of [ A B; C 0] = 1.100D+04 Norm of scaled [ A B; C 0] = 2.000D+02 Norm of E = 3.010D+02 Norm of scaled E = 4.000D+00 slicot-5.0+20101122/examples77/TG01AZ.dat000077500000000000000000000012201201767322700171400ustar00rootroot00000000000000TG01AZ EXAMPLE PROGRAM DATA 4 4 2 2 A 0.0 (-1,0) (0,0) (0,0) (0.003,0) (0,0) (0,0) (0.1000,0) (0.02,0) (100,0) (10,0) (0,0) (0.4,0) (0,0) (0,0) (0,0) (0.0,0) (1,0) (0.2,0) (0,0) (0.0,0) (0,0) (1,0) (0,0) ( 0.01,0) (300,0) (90,0) (6,0) (0.3,0) (0,0) (0,0) (20,0) (0.0,0) (10,0) (0,0) (0,0) (0,0) (0,0) (1000,0) (10000,0) (10000,0) (-0.1,0) (0.0,0) (0.001,0) (0.0,0) (0.0,0) (0.01,0) (-0.001,0) (0.0001,0) slicot-5.0+20101122/examples77/TG01AZ.res000077500000000000000000000030621201767322700171670ustar00rootroot00000000000000 TG01AZ EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix Dl*A*Dr is -1.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.3000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 1.0000 +0.0000i 2.0000 +0.0000i 1.0000 +0.0000i 0.1000 +0.0000i 0.0000 +0.0000i 0.4000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i The transformed descriptor matrix Dl*E*Dr is 1.0000 +0.0000i 0.2000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 1.0000 +0.0000i 0.0000 +0.0000i 1.0000 +0.0000i 3.0000 +0.0000i 0.9000 +0.0000i 0.6000 +0.0000i 0.3000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.2000 +0.0000i 0.0000 +0.0000i The transformed input/state matrix Dl*B is 100.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 100.0000 +0.0000i 100.0000 +0.0000i 100.0000 +0.0000i The transformed state/output matrix C*Dr is -0.0100 +0.0000i 0.0000 +0.0000i 0.0010 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0010 +0.0000i -0.0010 +0.0000i 0.0010 +0.0000i The diagonal of left scaling matrix Dl is 10.0000 10.0000 0.1000 0.0100 The diagonal of right scaling matrix Dr is 0.1000 0.1000 1.0000 10.0000 Norm of [ A B; C 0] = 1.100D+04 Norm of scaled [ A B; C 0] = 2.000D+02 Norm of E = 3.010D+02 Norm of scaled E = 4.000D+00 slicot-5.0+20101122/examples77/TG01CD.dat000077500000000000000000000004621201767322700171230ustar00rootroot00000000000000TG01CD EXAMPLE PROGRAM DATA 4 4 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 1 0 0 0 0 1 1 1 slicot-5.0+20101122/examples77/TG01CD.res000077500000000000000000000013341201767322700171430ustar00rootroot00000000000000 TG01CD EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix Q'*A is -0.6325 -0.9487 0.0000 -4.7434 -0.8706 -0.2176 -0.7255 -0.3627 -0.5203 -0.1301 0.3902 1.4307 -0.7559 -0.1890 0.5669 2.0788 The transformed descriptor matrix Q'*E is -3.1623 -9.1706 -5.6921 -2.8460 0.0000 -1.3784 -1.3059 -1.3784 0.0000 0.0000 -2.4279 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed input/state matrix Q'*B is -0.3162 -0.9487 0.6529 -0.2176 -0.4336 -0.9538 1.1339 0.3780 The left transformation matrix Q is -0.3162 0.6529 0.3902 0.5669 0.0000 -0.7255 0.3902 0.5669 -0.9487 -0.2176 -0.1301 -0.1890 0.0000 0.0000 -0.8238 0.5669 slicot-5.0+20101122/examples77/TG01DD.dat000077500000000000000000000004601201767322700171220ustar00rootroot00000000000000TG01DD EXAMPLE PROGRAM DATA 4 4 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 -1 0 1 0 0 1 -1 1 slicot-5.0+20101122/examples77/TG01DD.res000077500000000000000000000013301201767322700171400ustar00rootroot00000000000000 TG01DD EXAMPLE PROGRAM RESULTS The transformed state dynamics matrix A*Z is 0.4082 3.0773 0.6030 0.0000 0.8165 1.7233 0.6030 -1.0000 2.0412 2.8311 2.4121 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed descriptor matrix E*Z is 0.0000 -0.7385 2.1106 0.0000 0.0000 0.7385 1.2060 0.0000 0.0000 0.0000 9.9499 -6.0000 0.0000 0.0000 0.0000 -2.0000 The transformed input/state matrix C*Z is -0.8165 0.4924 -0.3015 -1.0000 0.0000 0.7385 1.2060 1.0000 The right transformation matrix Z is 0.8165 -0.4924 0.3015 0.0000 -0.4082 -0.1231 0.9045 0.0000 0.0000 0.0000 0.0000 -1.0000 0.4082 0.8616 0.3015 0.0000 slicot-5.0+20101122/examples77/TG01ED.dat000077500000000000000000000005531201767322700171260ustar00rootroot00000000000000TG01ED EXAMPLE PROGRAM DATA 4 4 2 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 1 0 0 0 0 1 1 1 -1 0 1 0 0 1 -1 1 slicot-5.0+20101122/examples77/TG01ED.res000077500000000000000000000021121201767322700171400ustar00rootroot00000000000000 TG01ED EXAMPLE PROGRAM RESULTS Rank of matrix E = 3 Rank of matrix A22 = 1 The transformed state dynamics matrix Q'*A*Z is 2.1882 -0.8664 -3.5097 -2.1353 -0.4569 -0.2146 1.9802 0.3531 -0.5717 -0.5245 -0.4591 0.4696 -0.4766 -0.5846 2.1414 0.3086 The transformed descriptor matrix Q'*E*Z is 11.8494 0.0000 0.0000 0.0000 0.0000 2.1302 0.0000 0.0000 0.0000 0.0000 1.0270 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed input/state matrix Q'*B is -0.2396 -1.0668 -0.2656 -0.8393 -0.7657 -0.1213 1.1339 0.3780 The transformed state/output matrix C*Z is -0.2499 -1.0573 0.3912 -0.8165 -0.5225 1.3958 0.8825 0.0000 The left transformation matrix Q is -0.1534 0.5377 -0.6049 0.5669 -0.0872 0.2536 0.7789 0.5669 -0.9805 -0.0360 0.0395 -0.1890 -0.0863 -0.8033 -0.1608 0.5669 The right transformation matrix Z is -0.2612 0.2017 -0.4737 0.8165 -0.7780 0.4718 -0.0738 -0.4082 -0.5111 -0.8556 -0.0826 0.0000 -0.2556 0.0684 0.8737 0.4082 slicot-5.0+20101122/examples77/TG01FD.dat000077500000000000000000000005531201767322700171270ustar00rootroot00000000000000TG01FD EXAMPLE PROGRAM DATA 4 4 2 2 0.0 -1 0 0 3 0 0 1 2 1 1 0 4 0 0 0 0 1 2 0 0 0 1 0 1 3 9 6 3 0 0 2 0 1 0 0 0 0 1 1 1 -1 0 1 0 0 1 -1 1 slicot-5.0+20101122/examples77/TG01FD.res000077500000000000000000000021121201767322700171410ustar00rootroot00000000000000 TG01FD EXAMPLE PROGRAM RESULTS Rank of matrix E = 3 Rank of matrix A22 = 1 The transformed state dynamics matrix Q'*A*Z is 2.0278 0.1078 3.9062 -2.1571 -0.0980 0.2544 1.6053 -0.1269 0.2713 0.7760 -0.3692 -0.4853 0.0690 -0.5669 -2.1974 0.3086 The transformed descriptor matrix Q'*E*Z is 10.1587 5.8230 1.3021 0.0000 0.0000 -2.4684 -0.1896 0.0000 0.0000 0.0000 1.0338 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed input/state matrix Q'*B is -0.2157 -0.9705 0.3015 0.9516 0.7595 0.0991 1.1339 0.3780 The transformed state/output matrix C*Z is 0.3651 -1.0000 -0.4472 -0.8165 -1.0954 1.0000 -0.8944 0.0000 The left transformation matrix Q is -0.2157 -0.5088 0.6109 0.5669 -0.1078 -0.2544 -0.7760 0.5669 -0.9705 0.1413 -0.0495 -0.1890 0.0000 0.8102 0.1486 0.5669 The right transformation matrix Z is -0.3651 0.0000 0.4472 0.8165 -0.9129 0.0000 0.0000 -0.4082 0.0000 -1.0000 0.0000 0.0000 -0.1826 0.0000 -0.8944 0.4082 slicot-5.0+20101122/examples77/TG01FZ.dat000077500000000000000000000010531201767322700171510ustar00rootroot00000000000000TG01FZ EXAMPLE PROGRAM DATA 4 4 2 2 0.0 (-1,0) (0,0) (0,0) (3,0) (0,0) (0,0) (1,0) (2,0) (1,0) (1,0) (0,0) (4,0) (0,0) (0,0) (0,0) (0,0) (1,0) (2,0) (0,0) (0,0) (0,0) (1,0) (0,0) (1,0) (3,0) (9,0) (6,0) (3,0) (0,0) (0,0) (2,0) (0,0) (1,0) (0,0) (0,0) (0,0) (0,0) (1,0) (1,0) (1,0) (-1,0) (0,0) (1,0) (0,0) (0,0) (1,0) (-1,0) (1,0) slicot-5.0+20101122/examples77/TG01FZ.res000077500000000000000000000035521201767322700172000ustar00rootroot00000000000000 TG01FZ EXAMPLE PROGRAM RESULTS Rank of matrix E = 3 Rank of matrix A22 = 1 The transformed state dynamics matrix Q'*A*Z is 2.0278 +0.0000i 0.1078 +0.0000i 3.9062 +0.0000i -2.1571 +0.0000i -0.0980 +0.0000i 0.2544 +0.0000i 1.6053 +0.0000i -0.1269 +0.0000i 0.2713 +0.0000i 0.7760 +0.0000i -0.3692 +0.0000i -0.4853 +0.0000i 0.0690 +0.0000i -0.5669 +0.0000i -2.1974 +0.0000i 0.3086 +0.0000i The transformed descriptor matrix Q'*E*Z is 10.1587 +0.0000i 5.8230 +0.0000i 1.3021 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i -2.4684 +0.0000i -0.1896 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 1.0338 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i The transformed input/state matrix Q'*B is -0.2157 +0.0000i -0.9705 +0.0000i 0.3015 +0.0000i 0.9516 +0.0000i 0.7595 +0.0000i 0.0991 +0.0000i 1.1339 +0.0000i 0.3780 +0.0000i The transformed state/output matrix C*Z is 0.3651 +0.0000i -1.0000 +0.0000i -0.4472 +0.0000i -0.8165 +0.0000i -1.0954 +0.0000i 1.0000 +0.0000i -0.8944 +0.0000i 0.0000 +0.0000i The left transformation matrix Q is -0.2157 +0.0000i -0.5088 +0.0000i 0.6109 +0.0000i 0.5669 +0.0000i -0.1078 +0.0000i -0.2544 +0.0000i -0.7760 +0.0000i 0.5669 +0.0000i -0.9705 +0.0000i 0.1413 +0.0000i -0.0495 +0.0000i -0.1890 +0.0000i 0.0000 +0.0000i 0.8102 +0.0000i 0.1486 +0.0000i 0.5669 +0.0000i The right transformation matrix Z is -0.3651 +0.0000i 0.0000 +0.0000i 0.4472 +0.0000i 0.8165 +0.0000i -0.9129 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i -0.4082 +0.0000i 0.0000 +0.0000i -1.0000 +0.0000i 0.0000 +0.0000i 0.0000 +0.0000i -0.1826 +0.0000i 0.0000 +0.0000i -0.8944 +0.0000i 0.4082 +0.0000i slicot-5.0+20101122/examples77/TG01HD.dat000077500000000000000000000015561201767322700171350ustar00rootroot00000000000000TG01HD EXAMPLE PROGRAM DATA 7 3 2 0.0 C 2 0 2 0 -1 3 1 0 1 0 0 1 0 0 0 0 0 1 0 0 1 0 0 2 0 -1 3 1 0 0 0 1 0 0 1 0 1 0 0 1 0 0 0 0 0 1 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 -1 0 0 1 3 0 2 0 0 0 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 3 1 0 0 1 0 0 1 0 -1 1 0 -1 1 0 slicot-5.0+20101122/examples77/TG01HD.res000077500000000000000000000050051201767322700171470ustar00rootroot00000000000000 TG01HD EXAMPLE PROGRAM RESULTS Dimension of controllable part = 3 Number of uncontrollable infinite eigenvalues = 1 The staircase form row dimensions are 2 1 The transformed state dynamics matrix Q'*A*Z is 0.0000 0.0000 0.0000 0.0000 -1.2627 0.4334 0.4666 0.0000 2.0000 0.0000 -3.7417 -0.8520 0.2924 -0.4342 0.0000 0.0000 1.7862 0.3780 -0.2651 -0.7723 0.0000 0.0000 0.0000 0.0000 3.7417 0.8520 -0.2924 0.4342 0.0000 0.0000 0.0000 0.0000 -1.5540 0.5334 0.5742 0.0000 0.0000 0.0000 0.0000 -0.6533 0.2242 0.2414 0.0000 0.0000 0.0000 0.0000 -0.5892 0.2022 0.2177 The transformed descriptor matrix Q'*E*Z is -1.8325 1.0000 2.3752 0.0000 -0.8214 0.2819 1.8016 0.4887 0.0000 0.3770 -0.5345 0.1874 0.5461 0.0000 -0.1728 0.0000 -0.1333 -1.1339 0.1325 0.3861 0.0000 0.0000 0.0000 0.0000 0.0000 0.8520 -0.2924 0.4342 0.0000 0.0000 0.0000 0.0000 -1.0260 -0.1496 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.1937 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 The transformed input/state matrix Q'*B is 1.0000 2.0000 3.0000 2.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed state/output matrix C*Z is 0.0000 1.0000 0.0000 0.0000 -1.2627 0.4334 0.4666 0.3665 0.0000 -0.9803 -1.6036 0.1874 0.5461 0.0000 The left transformation matrix Q is 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.7071 0.0000 0.2740 -0.6519 0.0000 0.0000 0.0000 0.0000 0.0000 0.8304 0.3491 -0.4342 0.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.4003 0.1683 0.9008 0.0000 0.0000 0.7071 0.0000 -0.2740 0.6519 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The right transformation matrix Z is 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -0.6108 0.0000 0.7917 0.0000 0.0000 0.0000 0.0000 0.4887 0.0000 0.3770 -0.5345 0.1874 0.5461 0.0000 0.0000 0.0000 0.0000 0.0000 -0.4107 0.1410 0.9008 0.6108 0.0000 0.4713 0.2673 -0.1874 -0.5461 0.0000 -0.1222 0.0000 -0.0943 -0.8018 -0.1874 -0.5461 0.0000 0.0000 0.0000 0.0000 0.0000 -0.8520 0.2924 -0.4342 slicot-5.0+20101122/examples77/TG01ID.dat000077500000000000000000000015571201767322700171370ustar00rootroot00000000000000TG01ID EXAMPLE PROGRAM DATA 7 2 3 0.0 O 2 0 0 0 0 0 0 0 1 0 0 0 1 0 2 0 0 2 0 0 0 0 0 1 0 1 0 1 -1 1 0 -1 0 1 0 3 0 0 3 0 0 0 1 0 1 1 1 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 3 1 0 0 0 0 1 0 0 0 0 0 1 0 2 0 0 0 0 0 -1 0 0 1 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 -1 0 1 1 0 0 -1 0 1 1 0 2 0 0 0 0 0 1 1 0 0 0 0 0 2 0 0 0 0 0 0 3 slicot-5.0+20101122/examples77/TG01ID.res000077500000000000000000000050051201767322700171500ustar00rootroot00000000000000 TG01ID EXAMPLE PROGRAM RESULTS Dimension of observable part = 3 Number of unobservable infinite eigenvalues = 1 The staircase form column dimensions are 2 1 The transformed state dynamics matrix Q'*A*Z is 0.2177 0.2414 0.5742 0.4342 0.0000 -0.4342 0.4666 0.2022 0.2242 0.5334 -0.2924 -0.7723 0.2924 0.4334 -0.5892 -0.6533 -1.5540 0.8520 -0.2651 -0.8520 -1.2627 0.0000 0.0000 0.0000 3.7417 0.3780 -3.7417 0.0000 0.0000 0.0000 0.0000 0.0000 1.7862 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 The transformed descriptor matrix Q'*E*Z is 1.0000 0.0000 0.0000 0.4342 0.0000 0.0000 1.8016 0.0000 1.1937 -0.1496 -0.2924 0.3861 0.5461 0.2819 0.0000 0.0000 -1.0260 0.8520 0.1325 0.1874 -0.8214 0.0000 0.0000 0.0000 0.0000 -1.1339 -0.5345 0.0000 0.0000 0.0000 0.0000 0.0000 -0.1333 0.3770 2.3752 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 -0.1728 0.4887 -1.8325 The transformed input/state matrix Q'*B is 0.4666 0.0000 0.4334 0.5461 -1.2627 0.1874 0.0000 -1.6036 0.0000 -0.9803 1.0000 0.0000 0.0000 0.3665 The transformed state/output matrix C*Z is 0.0000 0.0000 0.0000 0.0000 0.0000 2.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.0000 The left transformation matrix Q is 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.7917 0.0000 -0.6108 0.0000 0.5461 0.1874 -0.5345 0.3770 0.0000 0.4887 0.9008 0.1410 -0.4107 0.0000 0.0000 0.0000 0.0000 0.0000 -0.5461 -0.1874 0.2673 0.4713 0.0000 0.6108 0.0000 -0.5461 -0.1874 -0.8018 -0.0943 0.0000 -0.1222 -0.4342 0.2924 -0.8520 0.0000 0.0000 0.0000 0.0000 The right transformation matrix Z is 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 -0.6519 0.2740 0.0000 0.7071 0.0000 0.0000 -0.4342 0.3491 0.8304 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 0.9008 0.1683 0.4003 0.0000 0.0000 0.0000 0.0000 0.0000 0.6519 -0.2740 0.0000 0.7071 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 slicot-5.0+20101122/examples77/TG01JD.dat000077500000000000000000000024001201767322700171240ustar00rootroot00000000000000TG01JD EXAMPLE PROGRAM DATA 9 2 2 0.0 I R N -2 -3 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 -2 -3 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 1 0 0 -1 0 0 0 0 -1 0 0 0 0 1 0 1 -3 0 1 0 2 0 0 1 1 3 0 1 0 0 1 slicot-5.0+20101122/examples77/TG01JD.res000077500000000000000000000030651201767322700171550ustar00rootroot00000000000000 TG01JD EXAMPLE PROGRAM RESULTS Order of reduced system = 7 Achieved order reductions in different phases Phase 1: 0 elliminated eigenvalue(s) Phase 2: 0 elliminated eigenvalue(s) Phase 3: 2 elliminated eigenvalue(s) Phase 4: 0 elliminated eigenvalue(s) The reduced state dynamics matrix Ar is 1.0000 -0.0393 -0.0980 -0.1066 0.0781 -0.2330 0.0777 0.0000 1.0312 0.2717 0.2609 -0.1533 0.6758 -0.3553 0.0000 0.0000 1.3887 0.6699 -0.4281 1.6389 -0.7615 0.0000 0.0000 0.0000 -1.2147 0.2423 -0.9792 0.4788 0.0000 0.0000 0.0000 0.0000 -1.0545 0.5035 -0.2788 0.0000 0.0000 0.0000 0.0000 0.0000 1.6355 -0.4323 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 The reduced descriptor matrix Er is 0.4100 0.2590 0.5080 -0.3109 0.0705 0.1429 -0.1477 -0.7629 -0.3464 0.0992 -0.3007 0.0619 0.2483 -0.0152 0.1120 -0.2124 -0.4184 -0.1288 0.0569 -0.4213 -0.6182 0.0000 0.1122 -0.0039 0.2771 -0.0758 0.0975 0.3923 0.0000 0.0000 0.3708 -0.4290 0.1006 0.1402 -0.2699 0.0000 0.0000 0.0000 0.0000 0.9458 -0.2211 0.2378 0.0000 0.0000 0.0000 0.5711 0.2648 0.5948 -0.5000 The reduced input/state matrix Br is -0.5597 0.2363 -0.4843 -0.0498 -0.4727 -0.1491 0.1802 1.1574 0.5995 0.1556 -0.1729 -0.3999 0.0000 0.2500 The reduced state/output matrix Cr is 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 4.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.1524 -1.7500 slicot-5.0+20101122/examples77/TIB01AD.f000077500000000000000000000110501201767322700166750ustar00rootroot00000000000000* IB01AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDR, LDU, LDWORK, LDY, LIWORK, LMAX, MMAX, $ NOBRMX, NSMPMX PARAMETER ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000, $ LDR = ( 2*( MMAX + LMAX )*NOBRMX + $ 3*MMAX*NOBRMX ), LDU = NSMPMX, $ LDWORK = ( 6*( MMAX + LMAX )*NOBRMX + $ ( MMAX + LMAX )*( 4*NOBRMX* $ ( MMAX + LMAX + 1 ) + 2*NOBRMX ) + $ ( MMAX + LMAX )*4*NOBRMX* $ ( NOBRMX + 1 ) ), $ LDY = NSMPMX, LIWORK = ( MMAX + LMAX )*NOBRMX ) * .. Local Scalars .. LOGICAL NGIVEN CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH INTEGER I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE, $ NGIV, NOBR, NSAMPL, NSMP DOUBLE PRECISION RCOND, TOL * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), R(LDR, 2*(MMAX+LMAX)*NOBRMX), $ SV(LMAX*NOBRMX), U(LDU, MMAX), Y(LDY, LMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB01AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * If the value of N is positive, it will be taken as system order. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL, METH, ALG, $ JOBD, BATCH, CONCT, CTRL IF ( LSAME( BATCH, 'F' ) ) THEN READ ( NIN, FMT = * ) NCYCLE ELSE NCYCLE = 1 END IF NSAMPL = NCYCLE*NSMP * NGIVEN = N.GT.0 IF( NGIVEN ) $ NGIV = N IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99997 ) NOBR ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99995 ) L ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR. $ ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'O' ) ) .OR. $ ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'L' ) ) .OR. $ NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR. $ LSAME( BATCH, 'I' ) ) ) THEN WRITE ( NOUT, FMT = 99994 ) NSMP ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN WRITE ( NOUT, FMT = 99993 ) NCYCLE ELSE * Read the matrices U and Y from the input file. IF ( M.GT.0 ) $ READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1, M ), I = 1, NSAMPL ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL ) * Compute the R factor from a QR (or Cholesky) factorization * of the Hankel-like matrix (or correlation matrix). DO 10 ICYCLE = 1, NCYCLE II = ( ICYCLE - 1 )*NSMP + 1 IF ( NCYCLE.GT.1 ) THEN IF ( ICYCLE.GT.1 ) BATCH = 'I' IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L' END IF CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, $ L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR, $ SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN, $ INFO ) 10 CONTINUE IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99990 ) IWARN IF( NGIVEN ) $ N = NGIV WRITE ( NOUT, FMT = 99992 ) N WRITE ( NOUT, FMT = 99991 ) ( SV(I), I = 1,L*NOBR ) END IF END IF STOP 99999 FORMAT ( ' IB01AD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT ( ' INFO on exit from IB01AD = ',I2) 99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5) 99996 FORMAT (/' M is out of range.',/' M = ', I5) 99995 FORMAT (/' L is out of range.',/' L = ', I5) 99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5) 99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5) 99992 FORMAT ( ' The order of the system is ', I5) 99991 FORMAT ( ' The singular values are ',/ (8(1X,F8.4))) 99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2) END slicot-5.0+20101122/examples77/TIB01BD.f000077500000000000000000000235311201767322700167050ustar00rootroot00000000000000* IB01BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDA, LDB, LDC, LDD, LDK, LDQ, LDR, LDRY, LDS, $ LDU, LDW1, LDW2, LDW3, LDWORK, LDY, LIWORK, LMAX, $ MMAX, NMAX, NOBRMX, NSMPMX PARAMETER ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000, $ NMAX = NOBRMX - 1, LDA = NMAX, LDB = NMAX, $ LDC = LMAX, LDD = LMAX, LDK = NMAX, $ LDQ = NMAX, LDRY = LMAX, LDS = NMAX, $ LDR = ( 2*( MMAX + LMAX )*NOBRMX + $ 3*MMAX*NOBRMX ), LDU = NSMPMX, $ LDW1 = ( LMAX*( NOBRMX - 1 )*NMAX + NMAX + $ ( 6*MMAX + 4*LMAX )*NOBRMX + $ LMAX*NOBRMX*NMAX + $ ( LMAX*( NOBRMX - 1 )*NMAX + $ 3*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX + $ 2*LMAX*( NOBRMX - 1 )*NMAX + $ NMAX*NMAX + 8*NMAX + $ NMAX + $ 4*( MMAX*NOBRMX + NMAX ) ) ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ ( ( NMAX + LMAX )**2 + $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW3 = ( 4*NMAX*NMAX + 2*NMAX*LMAX + $ LMAX*LMAX + $ ( 3*LMAX + NMAX*LMAX ) + $ 14*NMAX*NMAX + 12*NMAX + 5 ), $ LDWORK = ( 6*( MMAX + LMAX )*NOBRMX + $ ( MMAX + LMAX )*( 4*NOBRMX* $ ( MMAX + LMAX + 2 ) - 2 ) + $ ( MMAX + LMAX )*4*NOBRMX* $ ( NOBRMX + 1 ) + LDW1 + LDW2 + $ LDW3 ), $ LDY = NSMPMX, $ LIWORK = ( ( MMAX + LMAX )*NOBRMX + $ MMAX*NOBRMX + NMAX + LMAX*NOBRMX + $ MMAX*( NMAX + LMAX ) + NMAX*NMAX ) $ ) * .. Local Scalars .. LOGICAL NGIVEN CHARACTER ALG, BATCH, CONCT, CTRL, JOB, JOBCK, JOBD, JOBDA, $ METH, METHA INTEGER I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE, $ NGIV, NOBR, NSAMPL, NSMP DOUBLE PRECISION RCOND, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, MMAX), C(LDC, NMAX), $ D(LDD, MMAX), DWORK(LDWORK), K(LDK, LMAX), $ Q(LDQ, NMAX), R(LDR, 2*(MMAX+LMAX)*NOBRMX), $ RY(LDRY, LMAX), S(LDS, LMAX), SV(LMAX*NOBRMX), $ U(LDU, MMAX), Y(LDY, LMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(2*NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB01AD, IB01BD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * If the value of N is positive, it will be taken as system order. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL READ ( NIN, FMT = * ) METH, ALG, JOBD, BATCH, CONCT, CTRL, JOB, $ JOBCK IF ( LSAME( BATCH, 'F' ) ) THEN READ ( NIN, FMT = * ) NCYCLE ELSE NCYCLE = 1 END IF NSAMPL = NCYCLE*NSMP * NGIVEN = N.GT.0 IF( NGIVEN ) $ NGIV = N IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99997 ) NOBR ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99995 ) L ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR. $ ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'O' ) ) .OR. $ ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'L' ) ) .OR. $ NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR. $ LSAME( BATCH, 'I' ) ) ) THEN WRITE ( NOUT, FMT = 99994 ) NSMP ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN WRITE ( NOUT, FMT = 99993 ) NCYCLE ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99980 ) N ELSE * Read the matrices U and Y from the input file. IF ( M.GT.0 ) $ READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1, M ), I = 1, NSAMPL ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL ) * Read A and C matrices, if METH <> 'M' and JOB = 'B' or 'D'. IF ( .NOT.LSAME( METH, 'M' ) .AND. $ ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'D' ) ) ) THEN DO 10 I = 1, N READ ( NIN, FMT = * ) ( A(I,J), J = 1, N ) 10 CONTINUE DO 20 I = 1, L READ ( NIN, FMT = * ) ( C(I,J), J = 1, N ) 20 CONTINUE END IF * Force some options for IB01AD, depending on the specifications. IF ( LSAME( METH, 'C' ) ) THEN METHA = 'M' JOBDA = 'N' ELSE METHA = METH JOBDA = JOBD END IF * Compute the R factor from a QR (or Cholesky) factorization * of the Hankel-like matrix (or correlation matrix). DO 30 ICYCLE = 1, NCYCLE II = ( ICYCLE - 1 )*NSMP + 1 IF ( NCYCLE.GT.1 ) THEN IF ( ICYCLE.GT.1 ) BATCH = 'I' IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L' END IF CALL IB01AD( METHA, ALG, JOBDA, BATCH, CONCT, CTRL, NOBR, M, $ L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR, $ SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN, $ INFO ) 30 CONTINUE IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99990 ) IWARN IF( NGIVEN ) $ N = NGIV * Compute the system matrices. CALL IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMP, R, $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, $ RY, LDRY, S, LDS, K, LDK, RCOND, IWORK, DWORK, $ LDWORK, BWORK, IWARN, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99992 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99991 ) IWARN IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( A(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( C(I,J), J = 1,N ) 50 CONTINUE END IF IF ( .NOT.LSAME( JOB, 'C' ) ) THEN WRITE ( NOUT, FMT = 99986 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( B(I,J), J = 1,M ) 60 CONTINUE END IF IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'D' ) ) THEN WRITE ( NOUT, FMT = 99985 ) DO 70 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( D(I,J), J = 1,M ) 70 CONTINUE END IF IF ( LSAME( JOBCK, 'K' ) ) THEN WRITE ( NOUT, FMT = 99984 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( K(I,J), J = 1,L ) 80 CONTINUE END IF IF ( .NOT.LSAME( JOBCK, 'N' ) ) THEN WRITE ( NOUT, FMT = 99983 ) DO 90 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( Q(I,J), J = 1,N ) 90 CONTINUE WRITE ( NOUT, FMT = 99982 ) DO 100 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( RY(I,J), J = 1,L ) 100 CONTINUE WRITE ( NOUT, FMT = 99981 ) DO 110 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( S(I,J), J = 1,L ) 110 CONTINUE END IF END IF END IF END IF STOP 99999 FORMAT ( ' IB01BD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT ( ' INFO on exit from IB01AD = ',I2) 99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5) 99996 FORMAT (/' M is out of range.',/' M = ', I5) 99995 FORMAT (/' L is out of range.',/' L = ', I5) 99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5) 99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5) 99992 FORMAT ( ' INFO on exit from IB01BD = ',I2) 99991 FORMAT ( ' IWARN on exit from IB01BD = ',I2) 99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2) 99989 FORMAT (/' The system state matrix A is ') 99988 FORMAT (20(1X,F8.4)) 99987 FORMAT (/' The system output matrix C is ') 99986 FORMAT (/' The system input matrix B is ') 99985 FORMAT (/' The system input-output matrix D is ') 99984 FORMAT (/' The Kalman gain matrix K is ') 99983 FORMAT (/' The state covariance matrix Q is ') 99982 FORMAT (/' The output covariance matrix Ry is ') 99981 FORMAT (/' The state-output cross-covariance matrix S is ') 99980 FORMAT (/' N is out of range.',/' N = ', I5) END slicot-5.0+20101122/examples77/TIB01CD.f000077500000000000000000000252661201767322700167150ustar00rootroot00000000000000* IB01CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDA, LDB, LDC, LDD, LDR, LDU, LDV, LDW1, LDW2, $ LDW4, LDW5, LDWORK, LDY, LIWORK, LMAX, MMAX, $ NMAX, NOBRMX, NSMPMX PARAMETER ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000, $ NMAX = NOBRMX - 1, LDA = NMAX, LDB = NMAX, $ LDC = LMAX, LDD = LMAX, LDV = NMAX, $ LDR = ( 2*( MMAX + LMAX )*NOBRMX + $ 3*MMAX*NOBRMX ), LDU = NSMPMX, $ LDW1 = ( LMAX*( NOBRMX - 1 )*NMAX + NMAX + $ ( 6*MMAX + 4*LMAX )*NOBRMX + $ LMAX*NOBRMX*NMAX + $ ( LMAX*( NOBRMX - 1 )*NMAX + $ 3*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX + $ 2*LMAX*( NOBRMX - 1 )*NMAX + $ NMAX*NMAX + 8*NMAX + $ NMAX + $ 4*( MMAX*NOBRMX + NMAX ) ) ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ ( ( NMAX + LMAX )**2 + $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW4 = NSMPMX*LMAX*NMAX*( MMAX + 1 ) + $ ( NMAX + $ ( 2*NMAX*NMAX + NMAX + $ MMAX + $ ( 2*NMAX*( MMAX + 1 ) + $ MMAX ) + $ 6*NMAX*( MMAX + 1 ) ) + $ 2*MMAX*MMAX*NMAX + 6*MMAX ), $ LDW5 = ( LMAX*MMAX + NMAX*( MMAX + 1 ) )* $ NMAX*( MMAX + 1 ) + $ ( ( LMAX*MMAX + $ LMAX*NMAX*( MMAX + 1 ) )* $ NMAX*( MMAX + 1 ) + $ NMAX*NMAX*MMAX + LMAX*NMAX + $ ( 2*NMAX*NMAX + NMAX + $ MMAX + $ ( 2*NMAX*( MMAX + 1 ) + $ MMAX ) + $ 6*NMAX*( MMAX + 1 ) ) + $ 2*MMAX*MMAX*NMAX + 6*MMAX ), $ LDWORK = ( 6*( MMAX + LMAX )*NOBRMX + $ ( MMAX + LMAX )*( 4*NOBRMX* $ ( MMAX + LMAX + 2 ) - 2 ) + $ ( MMAX + LMAX )*4*NOBRMX* $ ( NOBRMX + 1 ) + LDW1 + LDW2 + $ 3 + ( NMAX + MMAX + LMAX )*NMAX + $ ( 5*NMAX + 3 + $ ( LDW4 + LDW5 ) ) ), $ LDY = NSMPMX, $ LIWORK = ( ( MMAX + LMAX )*NOBRMX + $ MMAX*NOBRMX + NMAX + $ MMAX*( NMAX + LMAX ) + $ NMAX*MMAX + NMAX + MMAX ) $ ) * .. Local Scalars .. LOGICAL NGIVEN CHARACTER ALG, BATCH, COMUSE, CONCT, CTRL, JOB, JOBBD, $ JOBCK, JOBD, JOBDA, JOBX0, METH, METHA INTEGER I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE, $ NGIV, NOBR, NSAMPL, NSMP DOUBLE PRECISION RCOND, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, MMAX), C(LDC, NMAX), $ D(LDD, MMAX), DUM(1), DWORK(LDWORK), $ R(LDR, 2*(MMAX+LMAX)*NOBRMX), $ SV(LMAX*NOBRMX), U(LDU, MMAX), V(LDV, NMAX), $ X0(NMAX), Y(LDY, LMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB01AD, IB01BD, IB01CD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * If the value of N is positive, it will be taken as system order. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL READ ( NIN, FMT = * ) METH, ALG, JOBD, BATCH, CONCT, CTRL, JOB, $ COMUSE, JOBX0 IF ( LSAME( BATCH, 'F' ) ) THEN READ ( NIN, FMT = * ) NCYCLE ELSE NCYCLE = 1 END IF NSAMPL = NCYCLE*NSMP * NGIVEN = N.GT.0 IF( NGIVEN ) $ NGIV = N IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99997 ) NOBR ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99995 ) L ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR. $ ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'O' ) ) .OR. $ ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND. $ LSAME( BATCH, 'L' ) ) .OR. $ NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR. $ LSAME( BATCH, 'I' ) ) ) THEN WRITE ( NOUT, FMT = 99994 ) NSMP ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN WRITE ( NOUT, FMT = 99993 ) NCYCLE ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99983 ) N ELSE * Read the matrices U and Y from the input file. IF ( M.GT.0 ) $ READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1, M ), I = 1, NSAMPL ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL ) * Force some options, depending on the specifications. IF ( LSAME( METH, 'C' ) ) THEN METHA = 'M' JOBDA = 'N' ELSE METHA = METH JOBDA = JOBD END IF * The covariances and Kalman gain matrix are not computed. JOBCK = 'N' IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN JOBBD = 'D' ELSE JOBBD = JOB END IF IF ( LSAME( COMUSE, 'C' ) ) THEN JOB = 'C' ELSE IF ( LSAME( COMUSE, 'U' ) ) THEN JOB = 'A' END IF * Compute the R factor from a QR (or Cholesky) factorization * of the Hankel-like matrix (or correlation matrix). DO 10 ICYCLE = 1, NCYCLE II = ( ICYCLE - 1 )*NSMP + 1 IF ( NCYCLE.GT.1 ) THEN IF ( ICYCLE.GT.1 ) BATCH = 'I' IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L' END IF CALL IB01AD( METHA, ALG, JOBDA, BATCH, CONCT, CTRL, NOBR, M, $ L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR, $ SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN, $ INFO ) 10 CONTINUE IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99990 ) IWARN IF( NGIVEN ) $ N = NGIV * Compute the system matrices and x0. CALL IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMP, R, $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, DUM, 1, $ DUM, 1, DUM, 1, DUM, 1, RCOND, IWORK, DWORK, $ LDWORK, BWORK, IWARN, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99982 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99981 ) IWARN CALL IB01CD( JOBX0, COMUSE, JOBBD, N, M, L, NSMP, A, LDA, $ B, LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, $ V, LDV, RCOND, IWORK, DWORK, LDWORK, IWARN, $ INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99992 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99991 ) IWARN IF ( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99988 ) ( C(I,J), J = 1,N ) 30 CONTINUE END IF IF ( LSAME( COMUSE, 'C' ) ) THEN WRITE ( NOUT, FMT = 99986 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99988 ) ( B(I,J), J = 1,M ) 40 CONTINUE IF ( LSAME( JOBBD, 'D' ) ) THEN WRITE ( NOUT, FMT = 99985 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99988 ) $ ( D(I,J), J = 1,M ) 50 CONTINUE END IF END IF IF ( LSAME( JOBX0, 'X' ) ) THEN WRITE ( NOUT, FMT = 99984 ) WRITE ( NOUT, FMT = 99988 ) ( X0(I), I = 1,N ) END IF END IF END IF END IF END IF STOP 99999 FORMAT ( ' IB01CD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT ( ' INFO on exit from IB01AD = ',I2) 99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5) 99996 FORMAT (/' M is out of range.',/' M = ', I5) 99995 FORMAT (/' L is out of range.',/' L = ', I5) 99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5) 99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5) 99992 FORMAT ( ' INFO on exit from IB01CD = ',I2) 99991 FORMAT ( ' IWARN on exit from IB01CD = ',I2) 99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2) 99989 FORMAT (/' The system state matrix A is ') 99988 FORMAT (20(1X,F8.4)) 99987 FORMAT (/' The system output matrix C is ') 99986 FORMAT (/' The system input matrix B is ') 99985 FORMAT (/' The system input-output matrix D is ') 99984 FORMAT (/' The initial state vector x0 is ') 99983 FORMAT (/' N is out of range.',/' N = ', I5) 99982 FORMAT ( ' INFO on exit from IB01BD = ',I2) 99981 FORMAT ( ' IWARN on exit from IB01BD = ',I2) END slicot-5.0+20101122/examples77/TIB03AD.f000077500000000000000000000240131201767322700167020ustar00rootroot00000000000000* IB03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LDU, LDY, LIWORK, LMAX, MMAX, NMAX, NNMAX, $ NOBRMX, NSMPMX PARAMETER ( LMAX = 2, MMAX = 3, NOBRMX = 10, NNMAX = 12, $ NMAX = 4, NSMPMX = 1024, $ LDU = NSMPMX, LDY = NSMPMX, $ LIWORK = ( MMAX + LMAX + MMAX*NOBRMX + NMAX + $ MMAX*( NMAX + LMAX ) ) ) INTEGER BSNM, L0, L1M, L2M, LDW1, LDW2, LDW3, LDW4, $ LDW5, LDW6, LDW7, LDW8, LDWORK, LTHS, LW1, LW2, $ LW3, LW4, LXM PARAMETER ( BSNM = NNMAX*( LMAX + 2 ) + 1, $ LTHS = NMAX*( LMAX + MMAX + 1 ) + LMAX*MMAX, $ L0 = ( NMAX*( NMAX + LMAX ) + $ NMAX + MMAX + LMAX ), $ L1M = NSMPMX*LMAX + $ ( 2*NNMAX + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ 2*NMAX + L0 ), $ LXM = BSNM*LMAX + LTHS, $ L2M = ( LXM*LXM + 3*LXM + NSMPMX*LMAX ), $ LDW1 = ( 2*( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX + $ ( LMAX*NOBRMX - LMAX )*NMAX + $ NMAX*NMAX + 7*NMAX + $ LMAX*NOBRMX*NMAX + $ ( ( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX + $ 2*( LMAX*NOBRMX - LMAX )*NMAX $ + NMAX*NMAX + 8*NMAX + $ NMAX + 4*( MMAX*NOBRMX + $ NMAX ) + 1 + $ MMAX*NOBRMX + 3*NMAX + LMAX ) $ ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ ( ( NMAX + LMAX )**2 + $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW3 = NSMPMX*LMAX*( NMAX + 1 ) + 2*NMAX + $ ( 2*NMAX*NMAX + 4*NMAX ), $ LDW4 = NMAX*( NMAX + 1 ) + 2*NMAX + $ ( NMAX*LMAX*( NMAX + 1 ) + $ 2*NMAX*NMAX + LMAX*NMAX + 4*NMAX ), $ LDW5 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LDW6 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + NMAX + $ ( 1 + NMAX*NMAX*LMAX + NMAX*LMAX + $ NMAX + NMAX*NMAX + $ ( NMAX*NMAX + $ NMAX* ( NMAX + LMAX ) + $ 6*NMAX + NMAX + LMAX + $ NMAX*MMAX ) ), $ LDW7 = ( BSNM*BSNM + 3*BSNM + NSMPMX ), $ LDW8 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LW1 = ( 2*( MMAX + LMAX )*NOBRMX* $ ( 2*( MMAX + LMAX )*( NOBRMX + 1 ) $ + 3 ) + LMAX*NOBRMX + $ 4*( MMAX + LMAX )*NOBRMX* $ ( MMAX + LMAX )*NOBRMX + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ ( LDW1 + LDW2 ) + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ NMAX + NMAX*NMAX + 2 + $ NMAX*( NMAX + MMAX + LMAX ) + $ ( 5*NMAX + 2 + LDW3 + LDW4 + $ LDW5 + LDW6 ) ), $ LW2 = NSMPMX*LMAX + $ ( 5 + NSMPMX + 2*BSNM + NSMPMX*BSNM + $ ( 2*NNMAX + BSNM + LDW7 ) ), $ LW3 = ( LDW8 + NSMPMX*LMAX + $ ( NMAX + LMAX )*( 2*NMAX + MMAX )+ $ 2*NMAX ), $ LW4 = ( 5 + NSMPMX*LMAX + 2*LXM + $ NSMPMX*LMAX*( BSNM + LTHS ) + $ ( L1M + LXM + NSMPMX*LMAX + L1M + $ L2M ) ), $ LDWORK = ( LW1 + LW2 + LW3 + LW4 ) ) * .. Local Scalars .. LOGICAL INIT1, INITB, INITL, INITN, INITS CHARACTER*1 ALG, INIT, STOR INTEGER BSN, I, INFO, INI, ITER, ITERCG, ITMAX1, ITMAX2, $ IWARN, J, L, L1, L2, LPAR, LX, M, N, NN, NOBR, $ NPRINT, NS, NSMP DOUBLE PRECISION TOL1, TOL2 * .. Array Arguments .. INTEGER IWORK(LIWORK) DOUBLE PRECISION DWORK(LDWORK), U(LDU,MMAX), X(LXM), Y(LDY,LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB03AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, $ NPRINT, TOL1, TOL2, INIT, ALG, STOR INITL = LSAME( INIT, 'L' ) INITS = LSAME( INIT, 'S' ) INITB = LSAME( INIT, 'B' ) INITN = LSAME( INIT, 'N' ) INIT1 = INITL .OR. INITB IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE NS = N IF( INIT1 ) THEN IF( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99991 ) NOBR STOP ELSEIF( NSMP.LT.2*( M + L + 1 )*NOBR - 1 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.EQ.0 .OR. N.GE.NOBR ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF IF ( N.LT.0 ) $ N = NOBR - 1 ELSE IF( NSMP.LT.0 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF END IF IF( NN.LT.0 .OR. NN.GT.NNMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NN ELSE BSN = NN*( L + 2 ) + 1 L1 = BSN*L L2 = N*( L + M + 1 ) + L*M LX = L1 + L2 INI = 1 IF ( INITL ) THEN LPAR = L1 ELSEIF ( INITS ) THEN INI = L1 + 1 LPAR = L2 ELSEIF ( INITN ) THEN LPAR = LX END IF IF( INIT1 ) $ N = NS * Read the input-output data, initial parameters, and seed. READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,NSMP ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1,L ), I = 1,NSMP ) IF ( .NOT.INITB ) $ READ ( NIN, FMT = * ) ( X(I), I = INI,INI+LPAR-1 ) IF ( INITS .OR. INITB ) $ READ ( NIN, FMT = * ) ( DWORK(I), I = 1,4 ) * Solve a Wiener system identification problem. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99987 ) IWARN ITER = DWORK(3) ITERCG = DWORK(4) WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) ITER, ITERCG, $ IWORK(1), IWORK(2) * Recompute LX is necessary. IF ( INIT1 .AND. NS.LT.0 ) $ LX = L1 + N*( L + M + 1 ) + L*M WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, LX ) END IF END IF END IF END IF STOP * 99999 FORMAT (' IB03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from IB03AD = ',I4) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' Number of iterations = ', I7, $ /' Number of conjugate gradients iterations = ', I7, $ /' Number of function evaluations = ', I7, $ /' Number of Jacobian evaluations = ', I7) 99995 FORMAT (10(1X,F8.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' NOBR is out of range.',/' NOBR = ',I5) 99990 FORMAT (/' NSMP is out of range.',/' NSMP = ',I5) 99989 FORMAT (/' N is out of range.',/' N = ',I5) 99988 FORMAT (/' NN is out of range.',/' NN = ',I5) 99987 FORMAT (' IWARN on exit from IB03AD = ',I4) END slicot-5.0+20101122/examples77/TIB03BD.f000077500000000000000000000250641201767322700167120ustar00rootroot00000000000000* IB03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER BSNM, LDU, LDY, LIWORK, LMAX, LTHS, LXM, MMAX, $ NMAX, NNMAX, NOBRMX, NSMPMX PARAMETER ( LMAX = 2, MMAX = 3, NOBRMX = 10, NNMAX = 12, $ NMAX = 4, NSMPMX = 1024, $ BSNM = NNMAX*( LMAX + 2 ) + 1, $ LTHS = NMAX*( LMAX + MMAX + 1 ) + LMAX*MMAX, $ LDU = NSMPMX, LDY = NSMPMX, $ LXM = BSNM*LMAX + LTHS, $ LIWORK = ( MMAX + LMAX + MMAX*NOBRMX + NMAX + $ MMAX*( NMAX + LMAX ) + 3 + $ ( BSNM + 1 + LXM + LMAX ) ) ) INTEGER L0, L1M, L2M, L3M, LDW1, LDW2, LDW3, LDW4, LDW5, $ LDW6, LDW7, LDWORK, LW1, LW2, LW3, LW4 PARAMETER ( L0 = ( NMAX*( NMAX + LMAX ) + $ NMAX + MMAX + LMAX ), $ L1M = NSMPMX*LMAX + $ ( 2*NNMAX + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ 2*NMAX + L0 ), $ L2M = ( 4*LXM + 1 + BSNM + $ ( 3*BSNM + 1 + LTHS ) + $ NSMPMX*( LMAX - 1 ) ), $ L3M = ( 4*LXM + LTHS*BSNM + 2*LXM + $ 2* ( BSNM + LTHS ) ), $ LDW1 = ( 2*( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX + $ ( LMAX*NOBRMX - LMAX )*NMAX + $ NMAX*NMAX + 7*NMAX + $ LMAX*NOBRMX*NMAX + $ ( ( LMAX*NOBRMX - LMAX )*NMAX + $ 2*NMAX + LMAX + $ ( 2*MMAX + LMAX )*NOBRMX + $ 2*( LMAX*NOBRMX - LMAX )*NMAX $ + NMAX*NMAX + 8*NMAX + $ NMAX + 4*( MMAX*NOBRMX + $ NMAX ) + 1 + $ MMAX*NOBRMX + 3*NMAX + LMAX ) $ ), $ LDW2 = LMAX*NOBRMX*NMAX + $ MMAX*NOBRMX*( NMAX + LMAX )* $ ( MMAX*( NMAX + LMAX ) + 1 ) + $ ( ( NMAX + LMAX )**2 + $ 4*MMAX*( NMAX + LMAX ) + 1 ), $ LDW3 = NSMPMX*LMAX*( NMAX + 1 ) + 2*NMAX + $ ( 2*NMAX*NMAX + 4*NMAX ), $ LDW4 = NMAX*( NMAX + 1 ) + 2*NMAX + $ ( NMAX*LMAX*( NMAX + 1 ) + $ 2*NMAX*NMAX + LMAX*NMAX + 4*NMAX ), $ LDW5 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LDW6 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + NMAX + $ ( 1 + NMAX*NMAX*LMAX + NMAX*LMAX + $ NMAX + NMAX*NMAX + $ ( NMAX*NMAX + $ NMAX* ( NMAX + LMAX ) + $ 6*NMAX + ( NMAX + LMAX ) + $ NMAX*MMAX ) ), $ LDW7 = NSMPMX*LMAX + ( NMAX + LMAX )* $ ( NMAX + MMAX ) + 3*NMAX + MMAX + LMAX, $ LW1 = ( 2*( MMAX + LMAX )*NOBRMX* $ ( 2*( MMAX + LMAX )*( NOBRMX + 1 ) $ + 3 ) + LMAX*NOBRMX + $ 4*( MMAX + LMAX )*NOBRMX* $ ( MMAX + LMAX )*NOBRMX + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ ( LDW1 + LDW2 ) + $ ( NMAX + LMAX )*( NMAX + MMAX ) + $ NMAX + NMAX*NMAX + 2 + $ NMAX*( NMAX + MMAX + LMAX ) + $ ( 5*NMAX + 2 + ( LDW3 + LDW4 ) + $ LDW5 + LDW6 ) ), $ LW2 = NSMPMX*LMAX + BSNM + $ ( 4 + NSMPMX + $ ( NSMPMX*BSNM + $ ( 2*NNMAX + 5*BSNM + 1 ) + $ BSNM**2 + BSNM + $ ( NSMPMX + 2*NNMAX + $ 5*BSNM ) ) ), $ LW3 = ( LDW7 + NSMPMX*LMAX + $ ( NMAX + LMAX )*( 2*NMAX + MMAX )+ $ 2*NMAX ), $ LW4 = NSMPMX*LMAX + LXM + $ ( 4 + NSMPMX*LMAX + $ ( NSMPMX*LMAX*( BSNM + LTHS ) + $ ( NSMPMX*LMAX + L1M + $ L2M + LXM ) + $ LXM*( BSNM + LTHS ) + $ LXM + $ ( NSMPMX*LMAX + L1M + $ LXM + L3M ) ) ), $ LDWORK = ( LW1 + LW2 + LW3 + LW4 ) ) * .. Local Scalars .. LOGICAL INIT1, INITB, INITL, INITN, INITS CHARACTER*1 INIT INTEGER BSN, I, INFO, INI, ITER, ITMAX1, ITMAX2, IWARN, $ J, L, L1, L2, LPAR, LX, M, N, NN, NOBR, NPRINT, $ NS, NSMP DOUBLE PRECISION TOL1, TOL2 * .. Array Arguments .. INTEGER IWORK(LIWORK) DOUBLE PRECISION DWORK(LDWORK), U(LDU,MMAX), X(LXM), Y(LDY,LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL IB03BD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, $ NPRINT, TOL1, TOL2, INIT INITL = LSAME( INIT, 'L' ) INITS = LSAME( INIT, 'S' ) INITB = LSAME( INIT, 'B' ) INITN = LSAME( INIT, 'N' ) INIT1 = INITL .OR. INITB IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE NS = N IF( INIT1 ) THEN IF( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN WRITE ( NOUT, FMT = 99991 ) NOBR STOP ELSEIF( NSMP.LT.2*( M + L + 1 )*NOBR - 1 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.EQ.0 .OR. N.GE.NOBR ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF IF ( N.LT.0 ) $ N = NOBR - 1 ELSE IF( NSMP.LT.0 ) THEN WRITE ( NOUT, FMT = 99990 ) NSMP STOP ELSEIF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99989 ) N STOP END IF END IF IF( NN.LT.0 .OR. NN.GT.NNMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NN ELSE BSN = NN*( L + 2 ) + 1 L1 = BSN*L L2 = N*( L + M + 1 ) + L*M LX = L1 + L2 INI = 1 IF ( INITL ) THEN LPAR = L1 ELSEIF ( INITS ) THEN INI = L1 + 1 LPAR = L2 ELSEIF ( INITN ) THEN LPAR = LX END IF IF( INIT1 ) $ N = NS * Read the input-output data, initial parameters, and seed. READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,NSMP ) READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1,L ), I = 1,NSMP ) IF ( .NOT.INITB ) $ READ ( NIN, FMT = * ) ( X(I), I = INI,INI+LPAR-1 ) IF ( INITS .OR. INITB ) $ READ ( NIN, FMT = * ) ( DWORK(I), I = 1,4 ) * Solve a Wiener system identification problem. CALL IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, $ ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99987 ) IWARN ITER = DWORK(3) WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) ITER, IWORK(1), IWORK(2) * Recompute LX is necessary. IF ( INIT1 .AND. NS.LT.0 ) $ LX = L1 + N*( L + M + 1 ) + L*M WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, LX ) END IF END IF END IF END IF STOP * 99999 FORMAT (' IB03BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from IB03BD = ',I4) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' Number of iterations = ', I7, $ /' Number of function evaluations = ', I7, $ /' Number of Jacobian evaluations = ', I7) 99995 FORMAT (10(1X,F9.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' NOBR is out of range.',/' NOBR = ',I5) 99990 FORMAT (/' NSMP is out of range.',/' NSMP = ',I5) 99989 FORMAT (/' N is out of range.',/' N = ',I5) 99988 FORMAT (/' NN is out of range.',/' NN = ',I5) 99987 FORMAT (' IWARN on exit from IB03BD = ',I4) END slicot-5.0+20101122/examples77/TMB01TD.f000077500000000000000000000031501201767322700167260ustar00rootroot00000000000000* MB01TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDB PARAMETER ( LDA = NMAX, LDB = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX-1 ) * .. Local Scalars .. INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,NMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL MB01TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) * Compute the matrix product A*B. CALL MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB01TD = ',I2) 99997 FORMAT (' The matrix product A*B is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB02CD.f000077500000000000000000000064651201767322700167220ustar00rootroot00000000000000* MB02CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 20, NMAX = 20 ) INTEGER LCS, LDG, LDL, LDR, LDT, LDWORK PARAMETER ( LDG = 2*KMAX, LDL = NMAX*KMAX, LDR = NMAX*KMAX, $ LDT = KMAX, LDWORK = ( NMAX - 1 )*KMAX ) PARAMETER ( LCS = 3*LDWORK ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N CHARACTER JOB, TYPET * .. Local Arrays .. (Dimensioned for TYPET = 'R'.) DOUBLE PRECISION CS(LCS), DWORK(LDWORK), G(LDG, NMAX*KMAX), $ L(LDL, NMAX*KMAX), R(LDR, NMAX*KMAX), $ T(LDT, NMAX*KMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLASET, MB02CD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, JOB TYPET = 'R' M = N*K IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99992 ) K ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) * Compute the Cholesky factor(s) and/or the generator. CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, $ LDL, CS, LCS, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'A' ) .OR. $ LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'R' ) ) THEN WRITE ( NOUT, FMT = 99997 ) CALL DLASET( 'Full', K, K, ZERO, ZERO, G(K+1,1), LDG ) DO 10 I = 1, 2*K WRITE ( NOUT, FMT = 99994 ) ( G(I,J), J = 1, M ) 10 CONTINUE END IF IF ( LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( L(I,J), J = 1, M ) 20 CONTINUE END IF IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) $ .OR. LSAME( JOB, 'O' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M ) 30 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' MB02CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02CD = ',I2) 99997 FORMAT (' The generator of the inverse of block Toeplitz matrix', $ ' is ') 99996 FORMAT (/' The lower Cholesky factor of the inverse is ') 99995 FORMAT (/' The upper Cholesky factor of block Toeplitz matrix is ' $ ) 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples77/TMB02DD.f000077500000000000000000000147651201767322700167250ustar00rootroot00000000000000* MB02DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, MMAX, NMAX PARAMETER ( KMAX = 20, MMAX = 20, NMAX = 20 ) INTEGER LCS, LDG, LDL, LDR, LDT, LDWORK PARAMETER ( LDG = KMAX*( MMAX + NMAX ), $ LDL = KMAX*( MMAX + NMAX ), $ LDR = KMAX*( MMAX + NMAX ), $ LDT = KMAX*( MMAX + NMAX ), $ LDWORK = ( MMAX + NMAX - 1 )*KMAX ) PARAMETER ( LCS = 3*LDWORK ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N, S CHARACTER JOB, TYPET * .. Local Arrays .. * The arrays are dimensioned for both TYPET = 'R' and TYPET = 'C'. * Arrays G and T could be smaller. * For array G, it is assumed that MMAX + NMAX >= 2. * The matrix TA is also stored in the array T. DOUBLE PRECISION CS(LCS), DWORK(LDWORK), $ G(LDG, KMAX*( MMAX + NMAX )), $ L(LDL, KMAX*( MMAX + NMAX )), $ R(LDR, KMAX*( MMAX + NMAX )), $ T(LDT, KMAX*( MMAX + NMAX )) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLACPY, MB02CD, MB02DD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, M, JOB, TYPET S = ( N + M )*K IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99989 ) N ELSE IF ( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99988 ) K ELSE IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE IF ( LSAME( TYPET, 'R' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,S ), I = 1,K ) ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,S ) END IF * Compute the Cholesky factors. CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, $ LDL, CS, LCS, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N*K WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, N*K ) 10 CONTINUE IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99995 ) IF ( LSAME( TYPET, 'R' ) ) THEN DO 20 I = 1, 2*K WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, N*K ) 20 CONTINUE ELSE DO 30 I = 1, N*K WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, 2*K ) 30 CONTINUE END IF END IF IF ( LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N*K WRITE ( NOUT, FMT = 99990 ) $ ( L(I,J), J = 1, N*K ) 40 CONTINUE END IF * Update the Cholesky factors. IF ( LSAME( TYPET, 'R' ) ) THEN * Copy the last block column of R. CALL DLACPY( 'All', N*K, K, R(1,(N-1)*K+1), LDR, $ R(K+1,N*K+1), LDR ) CALL MB02DD( JOB, TYPET, K, M, N, T(1,N*K+1), LDT, $ T, LDT, G, LDG, R(1,N*K+1), LDR, $ L(N*K+1,1), LDL, CS, LCS, DWORK, $ LDWORK, INFO ) ELSE * Copy the last block row of R. CALL DLACPY( 'All', K, N*K, R((N-1)*K+1,1), LDR, $ R(N*K+1,K+1), LDR ) CALL MB02DD( JOB, TYPET, K, M, N, T(N*K+1,1), LDT, $ T, LDT, G, LDG, R(N*K+1,1), LDR, $ L(1,N*K+1), LDL, CS, LCS, DWORK, $ LDWORK, INFO ) END IF IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99993 ) DO 50 I = 1, S WRITE ( NOUT, FMT = 99990 ) ( R(I,J), J = 1, S ) 50 CONTINUE IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) ) $ THEN WRITE ( NOUT, FMT = 99992 ) IF ( LSAME( TYPET, 'R' ) ) THEN DO 60 I = 1, 2*K WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, S ) 60 CONTINUE ELSE DO 70 I = 1, S WRITE ( NOUT, FMT = 99990 ) $ ( G(I,J), J = 1, 2*K ) 70 CONTINUE END IF END IF IF ( LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, S WRITE ( NOUT, FMT = 99990 ) $ ( L(I,J), J = 1, S ) 80 CONTINUE END IF END IF END IF END IF END IF END IF STOP * 99999 FORMAT ( ' MB02DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT ( ' INFO on exit from MB02CD = ',I2) 99997 FORMAT ( ' INFO on exit from MB02DD = ',I2) 99996 FORMAT ( ' The Cholesky factor is ') 99995 FORMAT (/' The inverse generator is ') 99994 FORMAT (/' The inverse Cholesky factor is ') 99993 FORMAT (/' The updated Cholesky factor is ') 99992 FORMAT (/' The updated inverse generator is ') 99991 FORMAT (/' The updated inverse Cholesky factor is ') 99990 FORMAT (20(1X,F8.4)) 99989 FORMAT (/' N is out of range.',/' N = ',I5) 99988 FORMAT (/' K is out of range.',/' K = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TMB02ED.f000077500000000000000000000063741201767322700167230ustar00rootroot00000000000000* MB02ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 20, NMAX = 20 ) INTEGER LDB, LDT, LDWORK PARAMETER ( LDB = KMAX*NMAX, LDT = KMAX*NMAX, $ LDWORK = NMAX*KMAX*KMAX + ( NMAX+2 )*KMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N, NRHS CHARACTER TYPET * .. Local Arrays .. * The arrays B and T are dimensioned for both TYPET = 'R' and * TYPET = 'C'. * NRHS is assumed to be not larger than KMAX*NMAX. DOUBLE PRECISION B(LDB, KMAX*NMAX), DWORK(LDWORK), $ T(LDT, KMAX*NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02ED * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, NRHS, TYPET M = N*K IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99993 ) K ELSE IF ( NRHS.LE.0 .OR. NRHS.GT.KMAX*NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NRHS ELSE IF ( LSAME( TYPET, 'R' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,M ) END IF IF ( LSAME( TYPET, 'R' ) ) THEN READ (NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, $ NRHS ) ELSE READ (NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1, $ M ) END IF * Compute the solution of X T = B or T X = B. CALL MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( TYPET, 'R' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, NRHS WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 10 CONTINUE ELSE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, $ NRHS ) 20 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' MB02ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02ED = ',I2) 99997 FORMAT (' The solution of X*T = B is ') 99996 FORMAT (' The solution of T*X = B is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' K is out of range.',/' K = ',I5) 99992 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5) END slicot-5.0+20101122/examples77/TMB02FD.f000077500000000000000000000134211201767322700167130ustar00rootroot00000000000000* MB02FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER ITMAX, KMAX, NMAX PARAMETER ( ITMAX = 10, KMAX = 20, NMAX = 20 ) INTEGER LDR, LDT, LDWORK PARAMETER ( LDR = NMAX*KMAX, LDT = KMAX, $ LDWORK = ( NMAX + 1 )*KMAX ) * .. Local Scalars .. INTEGER I, INFO, IT, J, K, LEN, M, N, P, PIT, POS, POSR, $ S1, SCIT CHARACTER TYPET DOUBLE PRECISION NNRM * .. Local Arrays .. (Dimensioned for TYPET = 'R'.) INTEGER S(ITMAX) DOUBLE PRECISION DWORK(LDWORK), R(LDR, NMAX*KMAX), $ T(LDT, NMAX*KMAX), V(NMAX*KMAX), W(NMAX*KMAX), $ Z(NMAX*KMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DNRM2 EXTERNAL DNRM2, LSAME * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLASET, DSCAL, DTRMV, MB02FD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, K, IT TYPET = 'R' M = N*K IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99992 ) K ELSE IF( IT.LE.0 .OR. IT.GT.ITMAX ) THEN WRITE ( NOUT, FMT = 99991 ) IT ELSE READ ( NIN, FMT = * ) ( S(I), I = 1, IT ) READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) P = 0 POS = 1 WRITE ( NOUT, FMT = 99997 ) DO 90 SCIT = 1, IT CALL MB02FD( TYPET, K, N, P, S(SCIT), T(1,POS), LDT, $ R(POS,POS), LDR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO STOP END IF S1 = S(SCIT) + P IF ( S1.EQ.0 ) THEN * Estimate the 2-norm of the Toeplitz matrix with 5 power * iterations. LEN = N*K CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 ) DO 30 PIT = 1, 5 DO 10 I = 1, N CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE, T, $ LDT, V((I-1)*K+1), 1, ZERO, $ W((I-1)*K+1), 1 ) 10 CONTINUE DO 20 I = 1, N-1 CALL DGEMV( 'Transpose', K, (N-I)*K, ONE, $ T(1,K+1), LDT, V((I-1)*K+1), 1, $ ONE, W(I*K+1), 1 ) 20 CONTINUE CALL DCOPY( LEN, W, 1, V, 1 ) NNRM = DNRM2( LEN, V, 1 ) CALL DSCAL( LEN, ONE/NNRM, V, 1 ) 30 CONTINUE ELSE * Estimate the 2-norm of the Schur complement with 5 power * iterations. LEN = ( N - S1 )*K CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 ) DO 80 PIT = 1, 5 POSR = ( S1 - 1 )*K + 1 DO 40 I = 1, N - S1 CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE, $ T(1,POSR+K), LDT, V((I-1)*K+1), 1, $ ZERO, W((I-1)*K+1), 1 ) 40 CONTINUE DO 50 I = 1, N - S1 CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', K, $ R(POSR,POSR), LDR, V((I-1)*K+1), 1 ) CALL DGEMV( 'NoTranspose', K, LEN-I*K, ONE, $ R(POSR,POSR+K), LDR, V(I*K+1), 1, ONE, $ V((I-1)*K+1), 1 ) 50 CONTINUE CALL DLASET( 'All', LEN, 1, ZERO, ZERO, Z, 1 ) DO 60 I = 1, N - S1 CALL DGEMV( 'Transpose', K, LEN-I*K, ONE, $ R(POSR,POSR+K), LDR, V((I-1)*K+1), 1, $ ONE, Z(I*K+1), 1 ) CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', K, $ R(POSR,POSR), LDR, V((I-1)*K+1), 1 ) CALL DAXPY( K, ONE, V((I-1)*K+1), 1, Z((I-1)*K+1), $ 1 ) 60 CONTINUE CALL DLASET( 'All', LEN, 1, ZERO, ZERO, V, 1 ) DO 70 I = 1, N - S1 CALL DGEMV( 'Transpose', K, LEN-(I-1)*K, ONE, $ T(1,POSR+K), LDT, W((I-1)*K+1), 1, $ ONE, V((I-1)*K+1), 1 ) 70 CONTINUE CALL DAXPY( LEN, -ONE, Z, 1, V, 1 ) NNRM = DNRM2( LEN, V, 1 ) CALL DSCAL( LEN, -ONE/NNRM, V, 1 ) 80 CONTINUE POS = ( S1 - 1 )*K + 1 P = S1 END IF WRITE ( NOUT, FMT = 99995 ) P*K, NNRM 90 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 100 I = 1, P*K WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M ) 100 CONTINUE END IF STOP * 99999 FORMAT (' MB02FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02FD = ',I2) 99997 FORMAT (' Incomplete Cholesky factorization ', $ //' rows norm(Schur complement)',/) 99996 FORMAT (/' The upper ICC factor of the block Toeplitz matrix is ' $ ) 99995 FORMAT (I4,5X,F8.4) 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' K is out of range.',/' K = ',I5) 99991 FORMAT (/' IT is out of range.',/' IT = ',I5) END slicot-5.0+20101122/examples77/TMB02GD.f000077500000000000000000000046221201767322700167170ustar00rootroot00000000000000* MB02GD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX, NLMAX PARAMETER ( KMAX = 20, NMAX = 20, NLMAX = 20 ) INTEGER LDRB, LDT, LDWORK PARAMETER ( LDRB = ( NLMAX + 1 )*KMAX, LDT = KMAX*NMAX, $ LDWORK = ( NLMAX + 1 )*KMAX*KMAX + $ ( 3 + NLMAX )*KMAX ) * .. Local Scalars .. INTEGER I, J, INFO, K, M, N, NL, SIZR CHARACTER TRIU, TYPET * .. Local Arrays dimensioned for TYPET = 'R' .. DOUBLE PRECISION DWORK(LDWORK), RB(LDRB, NMAX*KMAX), $ T(LDT, NMAX*KMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02GD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, N, NL, TRIU TYPET = 'R' M = ( NL + 1 )*K IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE IF( NL.LE.0 .OR. NL.GT.NLMAX ) THEN WRITE ( NOUT, FMT = 99994 ) NL ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99993 ) K ELSE READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K ) * Compute the banded Cholesky factor. CALL MB02GD( TYPET, TRIU, K, N, NL, 0, N, T, LDT, RB, LDRB, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) IF ( LSAME( TRIU, 'T' ) ) THEN SIZR = NL*K + 1 ELSE SIZR = ( NL + 1 )*K END IF DO 10 I = 1, SIZR WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1, N*K ) 10 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB02GD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02GD = ',I2) 99997 FORMAT (/' The upper Cholesky factor in banded storage format ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' NL is out of range.',/' NL = ',I5) 99993 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples77/TMB02HD.f000077500000000000000000000062711201767322700167220ustar00rootroot00000000000000* MB02HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, MLMAX, NMAX, NUMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, MLMAX = 10, $ NMAX = 20, NUMAX = 10 ) INTEGER LDRB, LDTC, LDTR, LDWORK PARAMETER ( LDRB = ( MLMAX + NUMAX + 1 )*LMAX, $ LDTC = ( MLMAX + 1 )*KMAX, LDTR = KMAX ) PARAMETER ( LDWORK = LDRB*LMAX + ( 2*NUMAX + 1 )*LMAX*KMAX $ + 2*LDRB*( KMAX + LMAX ) + LDRB $ + 6*LMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, LENR, M, ML, N, NU, S CHARACTER TRIU * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,NMAX*LMAX), $ TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02HD * .. Intrinsic Functions .. INTRINSIC MIN * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, ML, N, NU, TRIU IF( K.LT.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99990 ) K ELSE IF( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99991 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( ML.LT.0 .OR. ML.GT.MLMAX ) THEN WRITE ( NOUT, FMT = 99993 ) ML ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF( NU.LT.0 .OR. NU.GT.NUMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NU ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,(ML+1)*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,NU*L ), I = 1,K ) S = ( MIN( M*K, N*L ) + L - 1 ) / L * Compute the banded R factor. CALL MB02HD( TRIU, K, L, M, ML, N, NU, 0, S, TC, LDTC, TR, $ LDTR, RB, LDRB, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) LENR = ( ML + NU + 1 )*L IF ( LSAME( TRIU, 'T' ) ) LENR = ( ML + NU )*L + 1 LENR = MIN( LENR, N*L ) DO 10 I = 1, LENR WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1, $ MIN( N*L, M*K ) ) 10 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB02HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02HD = ',I2) 99997 FORMAT (/' The lower triangular factor R in banded storage ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' NU is out of range.',/' NU = ',I5) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' ML is out of range.',/' ML = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' L is out of range.',/' L = ',I5) 99990 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples77/TMB02ID.f000077500000000000000000000073161201767322700167240ustar00rootroot00000000000000* MB02ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX, RBMAX, RCMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20, $ RBMAX = 20, RCMAX = 20 ) INTEGER LDB, LDC, LDTC, LDTR, LDWORK PARAMETER ( LDB = KMAX*MMAX, LDC = KMAX*MMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = 2*NMAX*LMAX*( LMAX + KMAX ) + $ ( 6 + NMAX )*LMAX + $ MMAX*KMAX*( LMAX + 1 ) + $ RBMAX + RCMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, M, N, RB, RC CHARACTER JOB DOUBLE PRECISION B(LDB,RBMAX), C(LDC,RCMAX), DWORK(LDWORK), $ TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02ID * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, RB, RC, JOB IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99994 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99993 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) $ .AND. ( ( RB.LE.0 ) .OR. ( RB.GT.RBMAX ) ) ) THEN WRITE ( NOUT, FMT = 99990 ) RB ELSE IF ( ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) $ .AND. ( ( RC.LE.0 ) .OR. ( RC.GT.RCMAX ) ) ) THEN WRITE ( NOUT, FMT = 99989 ) RC ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,(N-1)*L ), I = 1,K ) IF ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,RB ), I = 1,M*K ) END IF IF ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) THEN READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,RC ), I = 1,N*L ) END IF CALL MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B, $ LDB, C, LDC, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N*L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, RB ) 10 CONTINUE END IF IF ( LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, M*K WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, RC ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB02ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02ID = ',I2) 99997 FORMAT (' The least squares solution of T * X = B is ') 99996 FORMAT (' The minimum norm solution of T^T * X = C is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' K is out of range.',/' K = ',I5) 99993 FORMAT (/' L is out of range.',/' L = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' RB is out of range.',/' RB = ',I5) 99989 FORMAT (/' RC is out of range.',/' RC = ',I5) END slicot-5.0+20101122/examples77/TMB02JD.f000077500000000000000000000060211201767322700167150ustar00rootroot00000000000000* MB02JD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX PARAMETER ( KMAX = 10, LMAX = 10, MMAX = 20, NMAX = 20 ) INTEGER LDR, LDQ, LDTC, LDTR, LDWORK PARAMETER ( LDR = NMAX*LMAX, LDQ = MMAX*KMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = ( MMAX*KMAX + NMAX*LMAX ) $ *( LMAX + 2*KMAX ) + 6*LMAX $ + MMAX*KMAX + NMAX*LMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, M, N, S CHARACTER JOB * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,NMAX*LMAX), $ R(LDR,NMAX*LMAX), TC(LDTC,LMAX), $ TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02JD * .. Intrinsic Functions .. INTRINSIC MIN * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, JOB IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99994 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99993 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,( N - 1 )*L ), $ I = 1,K ) S = ( MIN( M*K, N*L ) + L - 1 ) / L * Compute the required part of the QR factorization. CALL MB02JD( JOB, K, L, M, N, 0, S, TC, LDTC, TR, LDTR, Q, LDQ, $ R, LDR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( JOB, 'Q' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M*K WRITE ( NOUT, FMT = 99995 ) $ ( Q(I,J), J = 1, MIN( N*L, M*K ) ) 10 CONTINUE END IF WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N*L WRITE ( NOUT, FMT = 99995 ) $ ( R(I,J), J = 1, MIN( N*L, M*K ) ) 20 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MB02JD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02JD = ',I2) 99997 FORMAT (/' The factor Q is ') 99996 FORMAT (/' The factor R is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' K is out of range.',/' K = ',I5) 99993 FORMAT (/' L is out of range.',/' L = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB02JX.f000077500000000000000000000065071201767322700167520ustar00rootroot00000000000000* MB02JX EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20 ) INTEGER LDR, LDQ, LDTC, LDTR, LDWORK PARAMETER ( LDR = NMAX*LMAX, LDQ = MMAX*KMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = ( MMAX*KMAX + NMAX*LMAX ) $ *( LMAX + 2*KMAX ) + 5*LMAX $ + MMAX*KMAX + NMAX*LMAX ) * .. Local Scalars .. CHARACTER JOB INTEGER I, INFO, J, K, L, M, N, RNK DOUBLE PRECISION TOL1, TOL2 * .. Local Arrays .. INTEGER JPVT(NMAX*LMAX) DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,NMAX*LMAX), $ R(LDR,NMAX*LMAX), TC(LDTC,LMAX), $ TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02JX * .. Intrinsic Functions .. INTRINSIC MIN * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, TOL1, TOL2, JOB IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99991 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99990 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,( N - 1 )*L ), $ I = 1,K ) * Compute the required part of the QR factorization. CALL MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, LDQ, $ R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RNK IF ( LSAME( JOB, 'Q' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M*K WRITE ( NOUT, FMT = 99993 ) ( Q(I,J), J = 1, RNK ) 10 CONTINUE END IF WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N*L WRITE ( NOUT, FMT = 99993 ) ( R(I,J), J = 1, RNK ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) WRITE ( NOUT, FMT = 99992 ) ( JPVT(I), $ I = 1, MIN( M*K, N*L ) ) END IF END IF STOP * 99999 FORMAT (' MB02JX EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02JX = ',I2) 99997 FORMAT (/' The factor Q is ') 99996 FORMAT (/' The factor R is ') 99995 FORMAT (/' The column permutation is ') 99994 FORMAT (/' Numerical rank ',/' RNK = ',I5) 99993 FORMAT (20(1X,F8.4)) 99992 FORMAT (20(1X,I4)) 99991 FORMAT (/' K is out of range.',/' K = ',I5) 99990 FORMAT (/' L is out of range.',/' L = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB02KD.f000077500000000000000000000071761201767322700167320ustar00rootroot00000000000000* MB02KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, LMAX, MMAX, NMAX, RMAX PARAMETER ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20, $ RMAX = 20 ) INTEGER LDB, LDC, LDTC, LDTR, LDWORK PARAMETER ( LDB = LMAX*NMAX, LDC = KMAX*MMAX, $ LDTC = MMAX*KMAX, LDTR = KMAX, $ LDWORK = 2*( KMAX*LMAX + KMAX*RMAX $ + LMAX*RMAX + 1 )*( MMAX + NMAX ) ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, M, N, R CHARACTER LDBLK, TRANS DOUBLE PRECISION ALPHA, BETA * .. Local Arrays .. (Dimensioned for TRANS = 'N'.) DOUBLE PRECISION B(LDB,RMAX), C(LDC,RMAX), DWORK(LDWORK), $ TC(LDTC,LMAX), TR(LDTR,NMAX*LMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02KD * * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K, L, M, N, R, LDBLK, TRANS IF( K.LE.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99994 ) K ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99993 ) L ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF( R.LE.0 .OR. R.GT.RMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( LSAME( LDBLK, 'R' ) ) THEN READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), $ I = 1,(M-1)*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,N*L ), I = 1,K ) ELSE READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K ) READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,(N-1)*L ), $ I = 1,K ) END IF IF ( LSAME( TRANS, 'N' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,R ), I = 1,N*L ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,R ), I = 1,M*K ) END IF ALPHA = ONE BETA = ZERO CALL MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, TC, $ LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, LDWORK, $ INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( TRANS, 'N' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M*K WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,R ) 10 CONTINUE ELSE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N*L WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,R ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB02KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02KD = ',I2) 99997 FORMAT (' The product C = T * B is ') 99996 FORMAT (' The product C = T^T * B is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' K is out of range.',/' K = ',I5) 99993 FORMAT (/' L is out of range.',/' L = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' R is out of range.',/' R = ',I5) END slicot-5.0+20101122/examples77/TMB02MD.f000077500000000000000000000071751201767322700167330ustar00rootroot00000000000000* MB02MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, LMAX PARAMETER ( MMAX = 20, NMAX = 20, LMAX = 20 ) INTEGER LDC, LDX PARAMETER ( LDC = ( MMAX + NMAX + LMAX ), LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = MMAX*(NMAX + LMAX) + $ ( 3*(MMAX + NMAX + LMAX) + $ (MMAX + NMAX + LMAX) + $ 5*(MMAX + NMAX + LMAX) + $ 3*LMAX ) ) INTEGER LIWORK PARAMETER ( LIWORK = LMAX ) INTEGER LENGS PARAMETER ( LENGS = ( MMAX + NMAX+LMAX ) ) * .. Local Scalars .. DOUBLE PRECISION SDEV, TOL INTEGER I, INFO, IWARN, J, L, M, N, RANK CHARACTER*1 JOB * .. Local Arrays .. DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK), S(LENGS), $ X(LDX,LMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02MD * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, L, JOB * IF ( LSAME( JOB, 'R' ) ) THEN READ ( NIN, FMT = * ) TOL ELSE IF ( LSAME( JOB, 'T' ) ) THEN READ ( NIN, FMT = * ) RANK, SDEV TOL = SDEV ELSE IF ( LSAME( JOB, 'N' ) ) THEN READ ( NIN, FMT = * ) RANK, TOL ELSE READ ( NIN, FMT = * ) SDEV TOL = SDEV END IF * IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M ) * Compute the solution to the TLS problem Ax = b. CALL MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) RANK ELSE IF ( ( LSAME( JOB, 'R' ) ) .OR. ( LSAME( JOB, 'B' ) ) ) $ WRITE ( NOUT, FMT = 99996 ) RANK END IF WRITE ( NOUT, FMT = 99995 ) DO 40 J = 1, L DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) X(I,J) 20 CONTINUE IF ( J.LT.L ) WRITE ( NOUT, FMT = 99993 ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) ( S(J),J = 1, MIN( M, N+L ) ) END IF END IF STOP * 99999 FORMAT (' MB02MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02MD = ',I2) 99997 FORMAT (' IWARN on exit from MB02MD = ',I2,/) 99996 FORMAT (' The computed rank of the TLS approximation = ',I3,/) 99995 FORMAT (' The solution X to the TLS problem is ',/) 99994 FORMAT (1X,F8.4) 99993 FORMAT (' ') 99992 FORMAT (/' The singular values of C are ',//(1X,F8.4)) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' L is out of range.',/' L = ',I5) END slicot-5.0+20101122/examples77/TMB02ND.f000077500000000000000000000121561201767322700167270ustar00rootroot00000000000000* MB02ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, LMAX PARAMETER ( MMAX = 20, NMAX = 20, LMAX = 20 ) INTEGER LDC, LDX PARAMETER ( LDC = ( MMAX + NMAX + LMAX ), LDX = NMAX ) INTEGER LENGQ PARAMETER ( LENGQ = 2*(MMAX + NMAX+LMAX)-1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX+2*LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = (2 + ( MMAX + NMAX+LMAX ) + $ 2*( MMAX + NMAX+LMAX ) + $ ( MMAX + NMAX+LMAX ) + $ ( ( NMAX+LMAX )*( NMAX+LMAX-1 )/2 + $ MMAX*( NMAX+LMAX-( MMAX-1 )/2 ) ) + $ ( 6*(NMAX+LMAX)-5 + LMAX*LMAX + NMAX $ + LMAX + 3*LMAX ) ) ) INTEGER LBWORK PARAMETER ( LBWORK = NMAX+LMAX ) * .. Local Scalars .. DOUBLE PRECISION RELTOL, THETA, THETA1, TOL INTEGER I, INFO, IWARN, J, K, L, LOOP, M, MINMNL, N, $ RANK, RANK1 * .. Local Arrays .. DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK), $ Q(LENGQ), X(LDX,LMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LBWORK), INUL(NMAX+LMAX) * .. External Subroutines .. EXTERNAL MB02ND * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, L, RANK, THETA, TOL, RELTOL IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99982 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99983 ) N ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99981 ) L ELSE IF ( RANK.GT.MIN( MMAX, NMAX ) ) THEN WRITE ( NOUT, FMT = 99980 ) RANK ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99979 ) THETA ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M ) RANK1 = RANK THETA1 = THETA * Compute the solution to the TLS problem Ax = b. CALL MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL, $ TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, IWARN, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) RANK ELSE IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK END IF IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA WRITE ( NOUT, FMT = 99994 ) MINMNL = MIN( M, N+L ) LOOP = MINMNL - 1 DO 20 I = 1, LOOP K = I + MINMNL WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K) 20 CONTINUE WRITE ( NOUT, FMT = 99992 ) MINMNL, MINMNL, Q(MINMNL) WRITE ( NOUT, FMT = 99991 ) DO 60 J = 1, L DO 40 I = 1, N WRITE ( NOUT, FMT = 99990 ) X(I,J) 40 CONTINUE IF ( J.LT.L ) WRITE ( NOUT, FMT = 99989 ) 60 CONTINUE WRITE ( NOUT, FMT = 99987 ) N + L, N + L WRITE ( NOUT, FMT = 99985 ) DO 80 I = 1, MAX( M, N + L ) WRITE ( NOUT, FMT = 99984 ) ( C(I,J), J = 1,N+L ) 80 CONTINUE WRITE ( NOUT, FMT = 99986 ) DO 100 J = 1, N + L WRITE ( NOUT, FMT = 99988 ) J, INUL(J) 100 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB02ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02ND = ',I2) 99997 FORMAT (' IWARN on exit from MB02ND = ',I2,/) 99996 FORMAT (' The computed rank of the TLS approximation = ',I3,/) 99995 FORMAT (' The computed value of THETA = ',F7.4,/) 99994 FORMAT (' The elements of the partially diagonalized bidiagonal ', $ 'matrix are',/) 99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/) 99991 FORMAT (' The solution X to the TLS problem is ',/) 99990 FORMAT (1X,F8.4) 99989 FORMAT (' ') 99988 FORMAT (I3,L8) 99987 FORMAT (/' Right singular subspace corresponds to the first ',I2, $ ' components of the j-th ',/' column of C for which INUL(', $ 'j) = .TRUE., j = 1,...,',I2,/) 99986 FORMAT (/' j INUL(j)',/) 99985 FORMAT (' Matrix C',/) 99984 FORMAT (20(1X,F8.4)) 99983 FORMAT (/' N is out of range.',/' N = ',I5) 99982 FORMAT (/' M is out of range.',/' M = ',I5) 99981 FORMAT (/' L is out of range.',/' L = ',I5) 99980 FORMAT (/' RANK is out of range.',/' RANK = ',I5) 99979 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4) END slicot-5.0+20101122/examples77/TMB02QD.f000077500000000000000000000057141201767322700167340ustar00rootroot00000000000000* MB02QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, NRHSMX PARAMETER ( NMAX = 20, MMAX = 20, NRHSMX = 20 ) INTEGER LDA, LDB PARAMETER ( LDA = MMAX, LDB = ( MMAX + NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = ( ( MMAX + NMAX) + 3*NMAX + 1 + $ 2*( MMAX + NMAX) + NRHSMX ) ) * .. Local Scalars .. DOUBLE PRECISION RCOND, SVLMAX INTEGER I, INFO, J, M, N, NRHS, RANK CHARACTER*1 INIPER, JOB * .. Local Arrays .. INTEGER JPVT(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,NRHSMX), DWORK(LDWORK), $ SVAL(3), Y(NMAX*NRHSMX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB02QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, NRHS, RCOND, SVLMAX, JOB, INIPER IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF ( NRHS.LT.0 .OR. NRHS.GT.NRHSMX ) THEN WRITE ( NOUT, FMT = 99992 ) NRHS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,M ) IF ( LSAME( JOB, 'F' ) ) $ READ ( NIN, FMT = * ) ( Y(I), I = 1,N*NRHS ) IF ( LSAME( INIPER, 'P' ) ) $ READ ( NIN, FMT = * ) ( JPVT(I), I = 1,N ) * Find the least squares solution. CALL MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, $ LDA, B, LDB, Y, JPVT, RANK, SVAL, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RANK, SVAL WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,NRHS ) 10 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' MB02QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02QD =',I2) 99997 FORMAT (' The effective rank of A =',I2,/ $ ' Estimates of the singular values SVAL = '/3(1X,F8.4)) 99996 FORMAT (' The least squares solution is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5) END slicot-5.0+20101122/examples77/TMB02SD.f000077500000000000000000000055261201767322700167370ustar00rootroot00000000000000* MB02SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NRHMAX PARAMETER ( NMAX = 20, NRHMAX = 20 ) INTEGER LDB, LDH PARAMETER ( LDB = NMAX, LDH = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) * .. Local Scalars .. DOUBLE PRECISION HNORM, RCOND INTEGER I, INFO, INFO1, J, N, NRHS CHARACTER*1 NORM, TRANS * .. Local Arrays .. DOUBLE PRECISION H(LDH,NMAX), B(LDB,NRHMAX), DWORK(LDWORK) INTEGER IPIV(NMAX), IWORK(LIWORK) * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS * .. External Subroutines .. EXTERNAL DLASET, MB02RD, MB02SD, MB02TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NRHS, NORM, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( H(I,J), J = 1,N ), I = 1,N ) IF ( NRHS.LT.0 .OR. NRHS.GT.NRHMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NRHS ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,N ) IF ( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, H(3,1), LDH ) * Compute the LU factorization of the upper Hessenberg matrix. CALL MB02SD( N, H, LDH, IPIV, INFO ) * Estimate the reciprocal condition number of the matrix. HNORM = DLANHS( NORM, N, H, LDH, DWORK ) CALL MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, $ DWORK, INFO1 ) IF ( INFO.EQ.0 .AND. RCOND.GT.DLAMCH( 'Epsilon' ) ) THEN * Solve the linear system. CALL MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) * WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF DO 10 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,NRHS ) 10 CONTINUE WRITE ( NOUT, FMT = 99995 ) RCOND END IF END IF STOP * 99999 FORMAT (' MB02SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02SD = ',I2) 99997 FORMAT (' The solution matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' Reciprocal condition number = ',D12.4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5) END slicot-5.0+20101122/examples77/TMB02VD.f000077500000000000000000000034661201767322700167430ustar00rootroot00000000000000* MB02VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDB PARAMETER ( LDA = NMAX, LDB = MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N CHARACTER*1 TRANS * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,NMAX) INTEGER IPIV(NMAX) * .. External Subroutines .. EXTERNAL MB02VD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M ) * Solve the linear system using the LU factorization. CALL MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N ) 10 CONTINUE ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF END IF STOP * 99999 FORMAT (' MB02VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB02VD = ',I2) 99997 FORMAT (' The solution matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TMB03BD.f000077500000000000000000000113711201767322700167120ustar00rootroot00000000000000* MB03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 6, NMAX = 50 ) INTEGER LDA1, LDA2, LDQ1, LDQ2, LDWORK, LIWORK PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX, $ LDQ2 = NMAX, LDWORK = 9*KMAX + 2*NMAX, $ LIWORK = 2*KMAX ) * * .. Local Scalars .. CHARACTER COMPQ, DEFL, JOB INTEGER H, I, IHI, ILO, INFO, IWARN, J, K, L, N * * .. Local Arrays .. INTEGER IWORK( LIWORK ), QIND( KMAX ), S( KMAX ), $ SCAL( NMAX ) DOUBLE PRECISION A( LDA1, LDA2, KMAX ), ALPHAI( NMAX ), $ ALPHAR( NMAX ), BETA( NMAX ), DWORK( LDWORK), $ Q( LDQ1, LDQ2, KMAX ) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL MB03BD * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, DEFL, COMPQ, K, N, H, ILO, IHI IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE READ( NIN, FMT = * ) ( S( I ), I = 1, K ) READ( NIN, FMT = * ) ( ( ( A( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'U' ) ) $ READ( NIN, FMT = * ) ( ( ( Q( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'P' ) ) THEN READ( NIN, FMT = * ) ( QIND( I ), I = 1, K ) DO 10 L = 1, K IF( QIND( L ).GT.0 ) $ READ( NIN, FMT = * ) ( ( Q( I, J, QIND( L ) ), $ J = 1, N ), I = 1, N ) 10 CONTINUE END IF * Compute the eigenvalues and the transformed matrices, if * required. CALL MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, A, $ LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, BETA, $ SCAL, IWORK, LIWORK, DWORK, LDWORK, IWARN, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE IF( IWARN.EQ.0 ) THEN IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'T' ) ) THEN WRITE( NOUT, FMT = 99996 ) DO 30 L = 1, K WRITE( NOUT, FMT = 99988 ) L DO 20 I = 1, N WRITE( NOUT, FMT = 99995 ) ( A( I, J, L ), J = 1, N $ ) 20 CONTINUE 30 CONTINUE END IF IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN WRITE( NOUT, FMT = 99994 ) DO 50 L = 1, K WRITE( NOUT, FMT = 99988 ) L DO 40 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q( I, J, L ), J = 1, N $ ) 40 CONTINUE 50 CONTINUE ELSE IF( LSAME( COMPQ, 'P' ) ) THEN WRITE( NOUT, FMT = 99994 ) DO 70 L = 1, K IF( QIND( L ).GT.0 ) THEN WRITE( NOUT, FMT = 99988 ) QIND( L ) DO 60 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( Q( I, J, QIND( L ) ), J = 1, N ) 60 CONTINUE END IF 70 CONTINUE END IF WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, N ) WRITE( NOUT, FMT = 99992 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, N ) WRITE( NOUT, FMT = 99991 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, N ) WRITE( NOUT, FMT = 99990 ) WRITE( NOUT, FMT = 99989 ) ( SCAL( I ), I = 1, N ) ELSE WRITE( NOUT, FMT = 99987 ) IWARN END IF END IF STOP * 99999 FORMAT( 'MB03BD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB03BD = ', I2 ) 99996 FORMAT( 'The matrix A on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix Q on exit is ' ) 99993 FORMAT( 'The vector ALPHAR is ' ) 99992 FORMAT( 'The vector ALPHAI is ' ) 99991 FORMAT( 'The vector BETA is ' ) 99990 FORMAT( 'The vector SCAL is ' ) 99989 FORMAT( 50( 1X, I8 ) ) 99988 FORMAT( 'The factor ', I2, ' is ' ) 99987 FORMAT( 'IWARN on exit from MB03BD = ', I2 ) END slicot-5.0+20101122/examples77/TMB03KD.f000077500000000000000000000172451201767322700167310ustar00rootroot00000000000000* MB03KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX, NMAX PARAMETER ( KMAX = 6, NMAX = 50 ) INTEGER LDA1, LDA2, LDQ1, LDQ2, LDWORK, LIWORK PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX, $ LDQ2 = NMAX, LDWORK = 80*KMAX + 2*NMAX, $ LIWORK = 4*KMAX ) DOUBLE PRECISION HUND, ZERO PARAMETER ( HUND = 1.0D2, ZERO = 0.0D0 ) * * .. Local Scalars .. CHARACTER COMPQ, DEFL, JOB, STRONG INTEGER H, I, IHI, ILO, INFO, IWARN, J, K, L, M, N, P DOUBLE PRECISION TOL * * .. Local Arrays .. LOGICAL SELECT( NMAX ) INTEGER IWORK( LIWORK ), IXQ( KMAX ), IXT( KMAX ), $ LDQ( KMAX ), LDT( KMAX ), ND( KMAX ), $ NI( KMAX ), QIND( KMAX ), S( KMAX ), $ SCAL( NMAX ) DOUBLE PRECISION A( LDA1, LDA2, KMAX ), ALPHAI( NMAX ), $ ALPHAR( NMAX ), BETA( NMAX ), DWORK( LDWORK), $ Q( LDQ1, LDQ2, KMAX ), QK( NMAX*NMAX*KMAX ), $ T( NMAX*NMAX*KMAX ) * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL DLACPY, MB03BD, MB03KD * * .. Intrinsic Functions .. INTRINSIC INT, MAX * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, DEFL, COMPQ, STRONG, K, N, H, ILO, IHI IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE TOL = HUND READ( NIN, FMT = * ) ( S( I ), I = 1, K ) READ( NIN, FMT = * ) ( ( ( A( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'U' ) ) $ READ( NIN, FMT = * ) ( ( ( Q( I, J, L ), J = 1, N ), $ I = 1, N ), L = 1, K ) IF( LSAME( COMPQ, 'P' ) ) THEN READ( NIN, FMT = * ) ( QIND( I ), I = 1, K ) DO 10 L = 1, K IF( QIND( L ).GT.0 ) $ READ( NIN, FMT = * ) ( ( Q( I, J, QIND( L ) ), $ J = 1, N ), I = 1, N ) 10 CONTINUE END IF IF( LSAME( JOB, 'E' ) ) $ JOB = 'S' * Compute the eigenvalues and the transformed matrices. CALL MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, A, $ LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, BETA, $ SCAL, IWORK, LIWORK, DWORK, LDWORK, IWARN, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE IF( IWARN.EQ.0 ) THEN * Prepare the data for calling MB03KD, which uses different * data structures and reverse ordering of the factors. DO 20 L = 1, K ND( L ) = MAX( 1, N ) NI( L ) = 0 LDT( L ) = MAX( 1, N ) IXT( L ) = ( L - 1 )*LDT( L )*N + 1 LDQ( L ) = MAX( 1, N ) IXQ( L ) = IXT( L ) IF( L.LE.INT( K/2 ) ) THEN I = S( K - L + 1 ) S( K - L + 1 ) = S( L ) S( L ) = I END IF 20 CONTINUE DO 30 L = 1, K CALL DLACPY( 'Full', N, N, A( 1, 1, K-L+1 ), LDA1, $ T( IXT( L ) ), LDT( L ) ) 30 CONTINUE IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN COMPQ = 'U' DO 40 L = 1, K CALL DLACPY( 'Full', N, N, Q( 1, 1, K-L+1 ), LDQ1, $ QK( IXQ( L ) ), LDQ( L ) ) 40 CONTINUE ELSE IF( LSAME( COMPQ, 'P' ) ) THEN COMPQ = 'W' DO 50 L = 1, K IF( QIND( L ).LT.0 ) $ QIND( L ) = 2 P = QIND( L ) IF( P.NE.0 ) $ CALL DLACPY( 'Full', N, N, Q( 1, 1, K-P+1 ), LDQ1, $ QK( IXQ( P ) ), LDQ( P ) ) 50 CONTINUE END IF * Select eigenvalues with negative real part. DO 60 I = 1, N SELECT( I ) = ALPHAR( I ).LT.ZERO 60 CONTINUE WRITE( NOUT, FMT = 99996 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, N ) WRITE( NOUT, FMT = 99994 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, N ) WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, N ) WRITE( NOUT, FMT = 99992 ) WRITE( NOUT, FMT = 99991 ) ( SCAL( I ), I = 1, N ) * Compute the transformed matrices, after reordering the * eigenvalues. CALL MB03KD( COMPQ, QIND, STRONG, K, N, H, ND, NI, S, $ SELECT, T, LDT, IXT, QK, LDQ, IXQ, M, TOL, $ IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99990 ) INFO ELSE WRITE( NOUT, FMT = 99989 ) DO 80 L = 1, K P = K - L + 1 WRITE( NOUT, FMT = 99988 ) L DO 70 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( T( IXT( P ) + I - 1 + ( J - 1 )*LDT( P ) ), $ J = 1, N ) 70 CONTINUE 80 CONTINUE IF( LSAME( COMPQ, 'U' ) .OR. LSAME( COMPQ, 'I' ) ) THEN WRITE( NOUT, FMT = 99987 ) DO 100 L = 1, K P = K - L + 1 WRITE( NOUT, FMT = 99988 ) L DO 90 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( QK( IXQ( P ) + I - 1 + $ ( J - 1 )*LDQ( P ) ), J = 1, N ) 90 CONTINUE 100 CONTINUE ELSE IF( LSAME( COMPQ, 'W' ) ) THEN WRITE( NOUT, FMT = 99987 ) DO 120 L = 1, K IF( QIND( L ).GT.0 ) THEN P = K - QIND( L ) + 1 WRITE( NOUT, FMT = 99988 ) QIND( L ) DO 110 I = 1, N WRITE( NOUT, FMT = 99995 ) $ ( QK( IXQ( P ) + I - 1 + $ ( J - 1 )*LDQ( P ) ), J = 1, N ) 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE WRITE( NOUT, FMT = 99979 ) IWARN END IF END IF STOP * 99999 FORMAT( 'MB03KD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB03BD = ', I2 ) 99996 FORMAT( 'The vector ALPHAR is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The vector ALPHAI is ' ) 99993 FORMAT( 'The vector BETA is ' ) 99992 FORMAT( 'The vector SCAL is ' ) 99991 FORMAT( 50( 1X, I5 ) ) 99990 FORMAT( 'INFO on exit from MB03KD = ', I2 ) 99989 FORMAT( 'The matrix A on exit is ' ) 99988 FORMAT( 'The factor ', I2, ' is ' ) 99987 FORMAT( 'The matrix Q on exit is ' ) 99986 FORMAT( 'LDT', 3I5 ) 99985 FORMAT( 'IXT', 3I5 ) 99984 FORMAT( 'LDQ', 3I5 ) 99983 FORMAT( 'IXQ', 3I5 ) 99982 FORMAT( 'ND' , 3I5 ) 99981 FORMAT( 'NI' , 3I5) 99980 FORMAT( 'SELECT', 3L5 ) 99979 FORMAT( 'IWARN on exit from MB03BD = ', I2 ) END slicot-5.0+20101122/examples77/TMB03LD.f000077500000000000000000000075001201767322700167230ustar00rootroot00000000000000* MB03LD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 50 ) INTEGER LDA, LDB, LDDE, LDFG, LDQ, LDWORK, LIWORK PARAMETER ( LDA = NMAX/2, LDB = NMAX/2, LDDE = NMAX/2, $ LDFG = NMAX/2, LDQ = 2*NMAX, $ LDWORK = 8*NMAX*NMAX + 8*NMAX + 272, $ LIWORK = 2*NMAX + 32 ) * * .. Local Scalars .. CHARACTER COMPQ, ORTH INTEGER I, INFO, J, M, N, NEIG * * .. Local Arrays .. LOGICAL BWORK( NMAX/2 ) INTEGER IWORK( LIWORK ) DOUBLE PRECISION A( LDA, NMAX/2 ), ALPHAI( NMAX/2 ), $ ALPHAR( NMAX/2 ), B( LDB, NMAX/2 ), $ BETA( NMAX/2 ), DE( LDDE, NMAX/2+1 ), $ DWORK( LDWORK ), FG( LDFG, NMAX/2+1 ), $ Q( LDQ, 2*NMAX ) * * .. External Subroutines .. EXTERNAL MB03LD * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) COMPQ, ORTH, N IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE M = N/2 READ( NIN, FMT = * ) ( ( A( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( DE( I, J ), J = 1, M+1 ), I = 1, M ) READ( NIN, FMT = * ) ( ( B( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( FG( I, J ), J = 1, M+1 ), I = 1, M ) * Compute the eigenvalues and an orthogonal basis of the right * deflating subspace of a real skew-Hamiltonian/Hamiltonian * pencil, corresponding to the eigenvalues with strictly negative * real part. CALL MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, BWORK, $ IWORK, LIWORK, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE WRITE( NOUT, FMT = 99996 ) DO 10 I = 1, M WRITE( NOUT, FMT = 99995 ) ( A( I, J ), J = 1, M ) 10 CONTINUE WRITE( NOUT, FMT = 99994 ) DO 20 I = 1, M WRITE( NOUT, FMT = 99995 ) ( DE( I, J ), J = 1, M+1 ) 20 CONTINUE WRITE( NOUT, FMT = 99993 ) DO 30 I = 1, M WRITE( NOUT, FMT = 99995 ) ( B( I, J ), J = 1, M ) 30 CONTINUE WRITE( NOUT, FMT = 99992 ) DO 40 I = 1, M WRITE( NOUT, FMT = 99995 ) ( FG( I, J ), J = 2, M+1 ) 40 CONTINUE WRITE( NOUT, FMT = 99991 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M ) WRITE( NOUT, FMT = 99990 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M ) WRITE( NOUT, FMT = 99989 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, M ) WRITE( NOUT, FMT = 99988 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q( I, J ), J = 1, NEIG ) 50 CONTINUE END IF END IF STOP * 99999 FORMAT( 'MB03LD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB03LD = ', I2 ) 99996 FORMAT( 'The matrix A on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix DE on exit is ' ) 99993 FORMAT( 'The matrix C1 on exit is ' ) 99992 FORMAT( 'The matrix V on exit is ' ) 99991 FORMAT( 'The vector ALPHAR is ' ) 99990 FORMAT( 'The vector ALPHAI is ' ) 99989 FORMAT( 'The vector BETA is ' ) 99988 FORMAT( 'The matrix Q is ' ) END slicot-5.0+20101122/examples77/TMB03MD.f000077500000000000000000000055521201767322700167310ustar00rootroot00000000000000* MB03MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION PIVMIN, RELTOL, SAFMIN, THETA, TOL INTEGER I, INFO, IWARN, L, N * .. Local Arrays .. DOUBLE PRECISION E(NMAX-1), E2(NMAX-1), Q(NMAX), Q2(NMAX) * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. External Subroutines .. EXTERNAL MB03MD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, THETA, L, TOL, RELTOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( L.LT.0 .OR. L.GT.N ) THEN WRITE ( NOUT, FMT = 99990 ) L ELSE READ ( NIN, FMT = * ) ( Q(I), I = 1,N ) READ ( NIN, FMT = * ) ( E(I), I = 1,N-1 ) * Print out the bidiagonal matrix J. WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N - 1 WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) N, N, Q(N) * Compute Q**2, E**2, and PIVMIN. Q2(N) = Q(N)**2 PIVMIN = Q2(N) DO 40 I = 1, N - 1 Q2(I) = Q(I)**2 E2(I) = E(I)**2 PIVMIN = MAX( PIVMIN, Q2(I), E2(I) ) 40 CONTINUE SAFMIN = DLAMCH( 'Safe minimum' ) PIVMIN = MAX( PIVMIN*SAFMIN, SAFMIN ) TOL = MAX( TOL, ZERO ) IF ( RELTOL.LE.ZERO ) $ RELTOL = DLAMCH( 'Base' )*DLAMCH( 'Epsilon' ) * Compute an upper bound THETA such that J has 3 singular values * < = THETA. CALL MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL, $ IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99994 ) IWARN WRITE ( NOUT, FMT = 99993 ) THETA WRITE ( NOUT, FMT = 99992 ) L END IF END IF STOP * 99999 FORMAT (' MB03MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03MD = ',I2) 99997 FORMAT (' The Bidiagonal Matrix J is',/) 99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99995 FORMAT (' (',I1,',',I1,') = ',F7.4) 99994 FORMAT (' IWARN on exit from MB03MD = ',I2,/) 99993 FORMAT (/' The computed value of THETA is ',F7.4) 99992 FORMAT (/' J has ',I2,' singular values < = THETA') 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' L is out of range.',/' L = ',I5) END slicot-5.0+20101122/examples77/TMB03ND.f000077500000000000000000000044121201767322700167240ustar00rootroot00000000000000* MB03ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION PIVMIN, SAFMIN, THETA INTEGER I, INFO, N, NUMSV * .. Local Arrays .. DOUBLE PRECISION E(NMAX-1), E2(NMAX-1), Q(NMAX), Q2(NMAX) * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. External Functions .. INTEGER MB03ND EXTERNAL MB03ND * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, THETA IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( Q(I), I = 1,N ) READ ( NIN, FMT = * ) ( E(I), I = 1,N-1 ) * Print out the bidiagonal matrix J. WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N - 1 WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) N, N, Q(N) * Compute Q**2, E**2, and PIVMIN. Q2(N) = Q(N)**2 PIVMIN = Q2(N) DO 40 I = 1, N - 1 Q2(I) = Q(I)**2 E2(I) = E(I)**2 PIVMIN = MAX( PIVMIN, Q2(I), E2(I) ) 40 CONTINUE SAFMIN = DLAMCH( 'Safe minimum' ) PIVMIN = MAX( PIVMIN*SAFMIN, SAFMIN ) * Compute the number of singular values of J < = THETA. NUMSV = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NUMSV, THETA END IF END IF STOP * 99999 FORMAT (' MB03ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03ND = ',I2) 99997 FORMAT (' The Bidiagonal Matrix J is',/) 99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99995 FORMAT (' (',I1,',',I1,') = ',F7.4) 99994 FORMAT (/' J has ',I2,' singular values < = ',F7.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB03OD.f000077500000000000000000000044121201767322700167250ustar00rootroot00000000000000* MB03OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDTAU PARAMETER ( LDTAU = (MMAX + NMAX) ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX + 1 ) * .. Local Scalars .. CHARACTER*1 JOBQR INTEGER I, INFO, J, M, N, RANK DOUBLE PRECISION RCOND, SVAL(3), SVLMAX * .. * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU) INTEGER JPVT(NMAX) * .. External Subroutines .. EXTERNAL MB03OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, JOBQR, RCOND, SVLMAX IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) * QR with column pivoting. DO 10 I = 1, N JPVT(I) = 0 10 CONTINUE CALL MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, $ RANK, SVAL, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99995 ) RANK WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,N ) WRITE ( NOUT, FMT = 99993 ) ( SVAL(I), I = 1,3 ) END IF END IF END IF * STOP * 99999 FORMAT (' MB03OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03OD = ',I2) 99995 FORMAT (' The rank is ',I5) 99994 FORMAT (' Column permutations are ',/(20(I3,2X))) 99993 FORMAT (' SVAL vector is ',/(20(1X,F10.4))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TMB03PD.f000077500000000000000000000043701201767322700167310ustar00rootroot00000000000000* MB03PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER LDTAU PARAMETER ( LDTAU = (MMAX + NMAX) ) INTEGER LDWORK PARAMETER ( LDWORK = 3*MMAX ) * .. Local Scalars .. CHARACTER*1 JOBRQ INTEGER I, INFO, J, M, N, RANK DOUBLE PRECISION RCOND, SVAL(3), SVLMAX * .. * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU) INTEGER JPVT(MMAX) * .. External Subroutines .. EXTERNAL MB03PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, JOBRQ, RCOND, SVLMAX IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) * RQ with row pivoting. DO 10 I = 1, M JPVT(I) = 0 10 CONTINUE CALL MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, $ RANK, SVAL, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99995 ) RANK WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,M ) WRITE ( NOUT, FMT = 99993 ) ( SVAL(I), I = 1,3 ) END IF END IF END IF * STOP * 99999 FORMAT (' MB03PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03PD = ',I2) 99995 FORMAT (' The rank is ',I5) 99994 FORMAT (' Row permutations are ',/(20(I3,2X))) 99993 FORMAT (' SVAL vector is ',/(20(1X,F10.4))) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TMB03QD.f000077500000000000000000000050721201767322700167320ustar00rootroot00000000000000* MB03QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 10 ) INTEGER LDA, LDU PARAMETER ( LDA = NMAX, LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 DICO, JOBU, STDOM INTEGER I, INFO, J, N, NDIM, NLOW, NSUP DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), U(LDU,NMAX), $ WI(NMAX), WR(NMAX) LOGICAL BWORK(NMAX) * .. External Functions .. LOGICAL SELECT * .. External Subroutines .. EXTERNAL DGEES, MB03QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NLOW, NSUP, ALPHA, DICO, STDOM, JOBU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Compute Schur form, eigenvalues and Schur vectors. CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, NDIM, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE * Block reordering. CALL MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, $ A, LDA, U, LDU, NDIM, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) NDIM WRITE ( NOUT, FMT = 99994 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB03QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DGEES = ',I2) 99997 FORMAT (' INFO on exit from MB03QD = ',I2) 99996 FORMAT (' The number of eigenvalues in the domain is ',I5) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' The ordered Schur form matrix is ') 99993 FORMAT (/' The transformation matrix is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB03RD.f000077500000000000000000000052711201767322700167340ustar00rootroot00000000000000* MB03RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 10 ) INTEGER LDA, LDX PARAMETER ( LDA = NMAX, LDX = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 JOBX, SORT INTEGER I, INFO, J, N, NBLCKS, SDIM DOUBLE PRECISION PMAX, TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), WI(NMAX), WR(NMAX), $ X(LDX,NMAX) INTEGER BLSIZE(NMAX) LOGICAL BWORK(NMAX) * .. External Functions .. LOGICAL SELECT * .. External Subroutines .. EXTERNAL DGEES, MB03RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, PMAX, TOL, JOBX, SORT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Compute Schur form, eigenvalues and Schur vectors. CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, SDIM, $ WR, WI, X, LDX, DWORK, LDWORK, BWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE * Block-diagonalization. CALL MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, $ BLSIZE, WR, WI, TOL, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99995 ) NBLCKS WRITE ( NOUT, FMT = 99994 ) ( BLSIZE(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99993 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB03RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from DGEES = ',I2) 99997 FORMAT (' INFO on exit from MB03RD = ',I2) 99995 FORMAT (' The number of blocks is ',I5) 99994 FORMAT (' The orders of blocks are ',/(20(I3,2X))) 99993 FORMAT (' The block-diagonal matrix is ') 99992 FORMAT (8X,20(1X,F8.4)) 99991 FORMAT (' The transformation matrix is ') 99972 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB03SD.f000077500000000000000000000040531201767322700167320ustar00rootroot00000000000000* MB03SD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX+1 ) ) * .. Local Scalars .. INTEGER I, INFO, J, N CHARACTER*1 JOBSCL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), QG(LDQG,NMAX+1), $ WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL MB03SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. * NOTE: input must define a square-reduced Hamiltonian matrix. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOBSCL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99998 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), I = J,N ), J = 1,N ) * Compute the eigenvalues. CALL MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE * Show the computed eigenvalues. WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) WR(I), ' + (', WI(I), ')i' 10 CONTINUE DO 20 I = N, 1, -1 WRITE ( NOUT, FMT = 99995 ) -WR(I), ' + (', -WI(I), ')i' 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB03SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' N is out of range.',/' N = ',I5) 99997 FORMAT (' INFO on exit from MB03SD = ',I2) 99996 FORMAT (/' The eigenvalues are ') 99995 FORMAT (1X,F8.4,A,F8.4,A) END slicot-5.0+20101122/examples77/TMB03TD.f000077500000000000000000000070601201767322700167340ustar00rootroot00000000000000* MB03TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDG, LDRES, LDU1, LDU2, LDWORK PARAMETER ( LDA = NMAX, LDG = NMAX, LDRES = NMAX, $ LDU1 = NMAX, LDU2 = NMAX, LDWORK = 8*NMAX ) * .. Local Scalars .. CHARACTER*1 COMPU, TYP INTEGER I, INFO, J, N, M * .. Local Arrays .. LOGICAL LOWER(NMAX), SELECT(NMAX) DOUBLE PRECISION A(LDA, NMAX), DWORK(LDWORK), G(LDG, NMAX), $ RES(LDRES,NMAX), U1(LDU1,NMAX), U2(LDU2,NMAX), $ WR(NMAX), WI(NMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION MA02JD EXTERNAL LSAME, MA02JD * .. External Subroutines .. EXTERNAL MB03TD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TYP, COMPU IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( SELECT(J), J = 1,N ) READ ( NIN, FMT = * ) ( LOWER(J), J = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( COMPU, 'U' ) ) THEN READ ( NIN, FMT = * ) ( ( U1(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( U2(I,J), J = 1,N ), I = 1,N ) END IF CALL MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( COMPU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99992 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) END IF * WRITE ( NOUT, FMT = 99996 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N ) 30 CONTINUE * WRITE ( NOUT, FMT = 99995 ) IF ( LSAME( TYP, 'S' ) ) THEN DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( -G(J,I), J = 1,I-1 ), ZERO, ( G(I,J), J = I+1,N ) 40 CONTINUE ELSE DO 50 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( G(J,I), J = 1,I-1 ), ( G(I,J), J = I,N ) 50 CONTINUE END IF END IF END IF * 99999 FORMAT (' MB03TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03TD = ',I2) 99997 FORMAT (' The orthogonal symplectic factor U is ') 99996 FORMAT (/' The matrix A in reordered Schur canonical form is ') 99995 FORMAT (/' The matrix G is ') 99994 FORMAT (20(1X,F9.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB03UD.f000077500000000000000000000044151201767322700167360ustar00rootroot00000000000000* MB03UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 10 ) INTEGER LDA, LDQ PARAMETER ( LDA = NMAX, LDQ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + 5*NMAX ) ) * .. Local Scalars .. CHARACTER*1 JOBQ, JOBP INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), Q(LDQ,NMAX), $ SV(NMAX) * .. External Functions .. LOGICAL LSAME * .. External Subroutines .. EXTERNAL MB03UD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOBQ, JOBP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Compute the singular values and vectors. CALL MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99995 ) ( SV(I), I = 1,N ) IF ( LSAME( JOBP, 'V' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE END IF IF ( LSAME( JOBQ, 'V' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB03UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03UD = ',I2) 99997 FORMAT (' Singular values are ',I5) 99996 FORMAT (/' The transpose of the right singular vectors matrix is ' $ ) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' The left singular vectors matrix is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB03VD.f000077500000000000000000000113321201767322700167330ustar00rootroot00000000000000* MB03VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA1, LDA2, LDQ1, LDQ2, LDTAU PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX, $ LDQ2 = NMAX, LDTAU = NMAX-1 ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION SSQ INTEGER I, IHI, ILO, INFO, J, K, KP1, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA1,LDA2,PMAX), AS(LDA1,LDA2,PMAX), $ DWORK(LDWORK), Q(LDQ1,LDQ2,PMAX), $ QTA(LDQ1,NMAX), TAU(LDTAU,PMAX) * .. External Functions .. DOUBLE PRECISION DLANGE, DLAPY2 EXTERNAL DLANGE, DLAPY2 * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, MB03VD, MB03VY * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. WRITE (NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, ILO, IHI IF ( N.LT.0 .OR. N.GT.MIN( LDA1, LDA2 ) ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE * Read matrices A_1, ..., A_p from the input file. DO 10 K = 1, P READ ( NIN, FMT = * ) $ ( ( A(I,J,K), J = 1, N ), I = 1, N ) CALL DLACPY( 'F', N, N, A(1,1,K), LDA1, AS(1,1,K), LDA1 ) 10 CONTINUE * Reduce to the periodic Hessenberg form. CALL MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, $ DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 30 K = 1, P CALL DLACPY( 'L', N, N, A(1,1,K), LDA1, Q(1,1,K), $ LDQ1 ) IF ( N.GT.1 ) THEN IF ( N.GT.2 .AND. K.EQ.1 ) THEN CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, $ A(3,1,K), LDA1 ) ELSE IF ( K.GT.1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ A(2,1,K), LDA1 ) END IF END IF WRITE ( NOUT, FMT = 99995 ) K DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( A(I,J,K), J = 1, N ) 20 CONTINUE 30 CONTINUE * Accumulate the transformations. CALL MB03VY( N, P, ILO, IHI, Q, LDQ1, LDQ2, TAU, LDTAU, $ DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99993 ) DO 50 K = 1, P WRITE ( NOUT, FMT = 99995 ) K DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) $ ( Q(I,J,K), J = 1, N ) 40 CONTINUE 50 CONTINUE * Compute error. SSQ = ZERO DO 60 K = 1, P KP1 = K+1 IF( KP1.GT.P ) KP1 = 1 * Compute NORM (Z' * A * Z - Aout) CALL DGEMM( 'T', 'N', N, N, N, ONE, Q(1,1,K), LDQ1, $ AS(1,1,K), LDA1, ZERO, QTA, LDQ1 ) CALL DGEMM( 'N', 'N', N, N, N, ONE, QTA, LDQ1, $ Q(1,1,KP1), LDQ1, -ONE, A(1,1,K), $ LDA1 ) SSQ = DLAPY2( SSQ, $ DLANGE( 'Frobenius', N, N, A(1,1,K), $ LDA1, DWORK ) ) 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) SSQ END IF END IF END IF END IF STOP 99999 FORMAT (' MB03VD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from MB03VD = ', I2) 99997 FORMAT (' INFO on exit from MB03VY = ', I2) 99996 FORMAT (' Reduced matrices') 99995 FORMAT (/' K = ', I5) 99994 FORMAT (8F8.4) 99993 FORMAT (/' Transformation matrices') 99992 FORMAT (/,' NORM (Q''*A*Q - Aout) = ', 1PD12.5) 99991 FORMAT (/, ' N is out of range.',/' N = ', I5) 99990 FORMAT (/, ' P is out of range.',/' P = ', I5) END slicot-5.0+20101122/examples77/TMB03WD.f000077500000000000000000000147241201767322700167440ustar00rootroot00000000000000* MB03WD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA1, LDA2, LDTAU, LDZ1, LDZ2, LDZTA PARAMETER ( LDA1 = NMAX, LDA2 = NMAX, LDTAU = NMAX-1, $ LDZ1 = NMAX, LDZ2 = NMAX, LDZTA = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX + NMAX + PMAX - 2 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION SSQ INTEGER I, IHI, IHIZ, ILO, ILOZ, INFO, J, K, KP1, N, P CHARACTER COMPZ, JOB * .. Local Arrays .. DOUBLE PRECISION A(LDA1,LDA2,PMAX), AS(LDA1,LDA2,PMAX), $ DWORK(LDWORK), TAU(LDTAU,PMAX), WI(NMAX), $ WR(NMAX), Z(LDZ1,LDZ2,PMAX), ZTA(LDZTA,NMAX) * .. External Functions .. DOUBLE PRECISION DLANGE, DLAPY2 LOGICAL LSAME EXTERNAL DLANGE, DLAPY2, LSAME * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, MB03VD, MB03VY, MB03WD, MB03WX * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. WRITE (NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, ILO, IHI, ILOZ, IHIZ, JOB, COMPZ IF ( N.LT.0 .OR. N.GT.MIN( LDA1, LDA2 ) ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99987 ) P ELSE * Read matrices A_1, ..., A_p from the input file. DO 10 K = 1, P READ ( NIN, FMT = * ) $ ( ( A(I,J,K), J = 1, N ), I = 1, N ) CALL DLACPY( 'F', N, N, A(1,1,K), LDA1, AS(1,1,K), LDA1 ) 10 CONTINUE * Reduce to the periodic Hessenberg form. CALL MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, $ DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE IF ( LSAME( COMPZ, 'V' ) ) THEN DO 20 K = 1, P CALL DLACPY( 'L', N, N, A(1,1,K), LDA1, Z(1,1,K), $ LDZ1 ) 20 CONTINUE * Accumulate the transformations. CALL MB03VY( N, P, ILO, IHI, Z, LDZ1, LDZ2, TAU, $ LDTAU, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) INFO STOP ELSE * Reduce to the periodic Schur form. CALL MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, $ IHIZ, A, LDA1, LDA2, Z, LDZ1, LDZ2, $ WR, WI, DWORK, LDWORK, INFO ) IF ( INFO.GT.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO WRITE ( NOUT, FMT = 99991 ) DO 30 I = MAX( ILO, INFO + 1 ), IHI WRITE ( NOUT, FMT = 99990 ) WR(I), WI(I) 30 CONTINUE STOP END IF IF ( INFO.LT.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE * Store the isolated eigenvalues. CALL MB03WX( ILO-1, P, A, LDA1, LDA2, WR, WI, $ INFO ) IF ( IHI.LT.N ) $ CALL MB03WX( N-IHI, P, A(IHI+1,IHI+1,1), $ LDA1, LDA2, WR(IHI+1), $ WI(IHI+1), INFO ) WRITE ( NOUT, FMT = 99991 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99990 ) WR(I), WI(I) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 K = 1, P WRITE ( NOUT, FMT = 99994 ) K DO 50 I = 1, N WRITE ( NOUT, FMT = 99993 ) $ ( A(I,J,K), J = 1, N ) 50 CONTINUE 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 80 K = 1, P WRITE ( NOUT, FMT = 99994 ) K DO 70 I = 1, N WRITE ( NOUT, FMT = 99993 ) $ ( Z(I,J,K), J = 1, N ) 70 CONTINUE 80 CONTINUE * Compute error. SSQ = ZERO DO 90 K = 1, P KP1 = K+1 IF( KP1.GT.P ) KP1 = 1 * Compute NORM (Z' * A * Z - Aout) CALL DGEMM( 'T', 'N', N, N, N, ONE, Z(1,1,K), $ LDZ1, AS(1,1,K), LDA1, ZERO, ZTA, $ LDZTA ) CALL DGEMM( 'N', 'N', N, N, N, ONE, ZTA, $ LDZTA, Z(1,1,KP1), LDZ1, -ONE, $ A(1,1,K), LDA1 ) SSQ = DLAPY2( SSQ, $ DLANGE( 'Frobenius', N, N, $ A(1,1,K), LDA1, $ DWORK ) ) 90 CONTINUE WRITE ( NOUT, FMT = 99989 ) SSQ END IF END IF END IF END IF END IF END IF STOP 99999 FORMAT (' MB03WD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from MB03WD = ', I2) 99997 FORMAT (' INFO on exit from MB03VD = ', I2) 99996 FORMAT (' INFO on exit from MB03VY = ', I2) 99995 FORMAT (/' Reduced matrices') 99994 FORMAT (/' K = ', I5) 99993 FORMAT (8F8.4) 99992 FORMAT (/' Transformation matrices') 99991 FORMAT ( ' Computed eigenvalues'/) 99990 FORMAT (4X,'( ', F17.6,' ,', F17.6,' )') 99989 FORMAT (/,' NORM (Z''*A*Z - Aout) = ', 1PD12.5) 99988 FORMAT (/, ' N is out of range.',/' N = ', I5) 99987 FORMAT (/, ' P is out of range.',/' P = ', I5) END slicot-5.0+20101122/examples77/TMB03XD.f000077500000000000000000000177031201767322700167450ustar00rootroot00000000000000* MB03XD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG, LDRES, LDT, LDU1, LDU2, LDV1, LDV2, $ LDWORK PARAMETER ( LDA = NMAX, LDQG = NMAX, LDRES = NMAX, $ LDT = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDV1 = NMAX, LDV2 = NMAX, $ LDWORK = 3*NMAX*NMAX + 7*NMAX ) * .. Local Scalars .. CHARACTER*1 BALANC, JOB, JOBU, JOBV INTEGER I, ILO, INFO, J, N DOUBLE PRECISION TEMP * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), DWORK(LDWORK), QG(LDQG, NMAX+1), $ RES(LDRES,3*NMAX+1), SCALE(NMAX), T(LDT,NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX), V1(LDV1,NMAX), $ V2(LDV2, NMAX), WI(NMAX), WR(NMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLAPY2, MA02JD EXTERNAL DLANGE, DLAPY2, LSAME, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, MB03XD, MB04DD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, BALANC, JOB, JOBU, JOBV IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES ) INFO = 0 CALL 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 ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, WR(I), WI(I) 20 CONTINUE IF ( LSAME( JOB, 'S' ).OR.LSAME( JOB, 'G' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99990 ) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99990 ) ( T(I,J), J = 1,N ) 40 CONTINUE END IF IF ( LSAME( JOB, 'G' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99990 ) ( QG(I,J+1), J = 1,N ) 50 CONTINUE END IF C IF ( LSAME( JOB, 'G' ).AND.LSAME( JOBU, 'U' ).AND. $ LSAME( JOBV, 'V' ) ) THEN CALL MB04DD( BALANC, N, RES(1,N+1), LDRES, RES(1,2*N+1), $ LDRES, I, DWORK, INFO ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, V1, LDV1, ZERO, RES, $ LDRES ) CALL DSYMM ( 'Left', 'Upper', N, N, -ONE, RES(1,2*N+2), $ LDRES, V2, LDV2, ONE, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ -ONE, U1, LDU1, T, LDT, ONE, RES, LDRES ) TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DWORK ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, V2, LDV2, ZERO, RES, $ LDRES ) CALL DSYMM( 'Left', 'Upper', N, N, ONE, RES(1,2*N+2), $ LDRES, V1, LDV1, ONE, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ -ONE, U1, LDU1, QG(1,2), LDQG, ONE, RES, $ LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, U2, LDU2, A, LDA, ONE, RES, LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) ) CALL DSYMM( 'Left', 'Lower', N, N, ONE, RES(1,2*N+1), $ LDRES, V1, LDV1, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, V2, LDV2, ONE, RES, $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, T, LDT, ONE, RES, LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) ) CALL DSYMM( 'Left', 'Lower', N, N, ONE, RES(1,2*N+1), $ LDRES, V2, LDV2, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, -ONE, $ RES(1,N+1), LDRES, V1, LDV1, ONE, RES, $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, QG(1,2), LDQG, ONE, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, U1, LDU1, A, LDA, ONE, RES, LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) ) WRITE ( NOUT, FMT = 99987 ) TEMP END IF C IF ( LSAME( JOBU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 60 CONTINUE DO 70 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 70 CONTINUE WRITE ( NOUT, FMT = 99986 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) END IF IF ( LSAME( JOBV, 'V' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( V1(I,J), J = 1,N ), ( V2(I,J), J = 1,N ) 80 CONTINUE DO 90 I = 1, N WRITE ( NOUT, FMT = 99990 ) $ ( -V2(I,J), J = 1,N ), ( V1(I,J), J = 1,N ) 90 CONTINUE WRITE ( NOUT, FMT = 99985 ) MA02JD( .FALSE., .FALSE., N, $ V1, LDV1, V2, LDV2, RES, LDRES ) END IF IF ( LSAME( BALANC, 'S' ).OR.LSAME( BALANC, 'B' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, SCALE(I) 100 CONTINUE END IF END IF END IF * 99999 FORMAT (' MB03XD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03XD = ',I2) 99997 FORMAT (' The stable eigenvalues are',//' i',6X, $ 'WR(i)',6X,'WI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' The matrix S of the reduced matrix is') 99994 FORMAT (/' The matrix T of the reduced matrix is') 99993 FORMAT (/' The matrix G of the reduced matrix is') 99992 FORMAT (/' The orthogonal symplectic factor U is') 99991 FORMAT (/' The orthogonal symplectic factor V is') 99990 FORMAT (20(1X,F19.16)) 99989 FORMAT (/' The diagonal scaling factors are ',//' i',6X, $ 'SCALE(i)',/) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2) 99986 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2) 99985 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB03XP.f000077500000000000000000000112461201767322700167550ustar00rootroot00000000000000* MB03XP EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 200 ) INTEGER LDA, LDB, LDQ, LDRES, LDZ, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDQ = NMAX, $ LDRES = NMAX, LDWORK = NMAX, LDZ = NMAX ) * .. Local Scalars .. INTEGER I, IHI, ILO, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX), $ B(LDA,NMAX), BETA(NMAX), DWORK(LDWORK), $ Q(LDQ,NMAX), RES(LDRES,3*NMAX), Z(LDZ,NMAX) * .. External Functions .. DOUBLE PRECISION DLANGE EXTERNAL DLANGE * .. External Subroutines .. EXTERNAL DGEMM, MB03XP * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, ILO, IHI IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, B, LDB, RES(1,2*N+1), LDRES ) CALL MB03XP( 'S', 'I', 'I', N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, LDWORK, $ INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE (NOUT, FMT = 99991) ( A(I,J), J = 1,N ) 10 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,N+1), LDRES, Z, LDZ, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ Q, LDQ, A, LDA, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99989 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99995 ) DO 20 I = 1, N WRITE (NOUT, FMT = 99991) ( B(I,J), J = 1,N ) 20 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ RES(1,2*N+1), LDRES, Q, LDQ, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ Z, LDZ, B, LDB, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99988 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99991) ( Q(I,J), J = 1,N ) 30 CONTINUE CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q, $ LDQ, Q, LDQ, ONE, RES, LDRES ) DO 40 I = 1, N RES(I,I) = RES(I,I) - ONE 40 CONTINUE WRITE ( NOUT, FMT = 99987 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99993 ) DO 50 I = 1, N WRITE (NOUT, FMT = 99991) ( Z(I,J), J = 1,N ) 50 CONTINUE CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Z, $ LDZ, Z, LDZ, ONE, RES, LDRES ) DO 60 I = 1, N RES(I,I) = RES(I,I) - ONE 60 CONTINUE WRITE ( NOUT, FMT = 99986 ) DLANGE( 'Frobenius', N, N, RES, $ LDRES, DWORK ) WRITE ( NOUT, FMT = 99992 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99991 ) $ ALPHAR(I), ALPHAI(I), BETA(I) 70 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MB03XP EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03XP = ',I2) 99996 FORMAT (' The reduced matrix A is ') 99995 FORMAT (/' The reduced matrix B is ') 99994 FORMAT (/' The orthogonal factor Q is ') 99993 FORMAT (/' The orthogonal factor Z is ') 99992 FORMAT (/4X,'ALPHAR',4X,'ALPHAI',4X,'BETA') 99991 FORMAT (1000(1X,F9.4)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' Residual: || A*Z - Q*S ||_F = ',G7.2) 99988 FORMAT (/' Residual: || B*Q - Z*T ||_F = ',G7.2) 99987 FORMAT (/' Orthogonality of Q: || Q''*Q - I ||_F = ',G7.2) 99986 FORMAT (/' Orthogonality of Z: || Z''*Z - I ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB03ZD.f000077500000000000000000000140621201767322700167420ustar00rootroot00000000000000* MB03ZD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 200 ) INTEGER LDG, LDRES, LDS, LDT, LDU1, LDU2, LDUS, LDUU, $ LDV1, LDV2, LDWORK PARAMETER ( LDG = NMAX, LDRES = 2*NMAX, LDS = NMAX, $ LDT = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDUS = 2*NMAX, LDUU = 2*NMAX, LDV1 = NMAX, $ LDV2 = NMAX, LDWORK = 3*NMAX*NMAX + 7*NMAX ) * .. Local Scalars .. CHARACTER*1 BALANC, METH, ORTBAL, STAB, WHICH INTEGER I, ILO, INFO, J, M, N * .. Local Arrays .. LOGICAL LWORK(2*NMAX), SELECT(NMAX) INTEGER IWORK(2*NMAX) DOUBLE PRECISION DWORK(LDWORK), G(LDG, NMAX), RES(LDRES,NMAX), $ S(LDS, NMAX), SCALE(NMAX), T(LDT,NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX), US(LDUS,2*NMAX), $ UU(LDUU,2*NMAX), V1(LDV1,NMAX), V2(LDV2, NMAX), $ WI(NMAX), WR(NMAX) * .. External Functions .. EXTERNAL DLANGE, LSAME LOGICAL LSAME DOUBLE PRECISION DLANGE * .. External Subroutines .. EXTERNAL MB03ZD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, ILO, WHICH, METH, STAB, BALANC, ORTBAL IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE * IF ( LSAME( WHICH, 'S' ) ) $ READ ( NIN, FMT = * ) ( SELECT(I), I = 1,N ) READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( WHICH, 'A' ).AND.LSAME( METH, 'L' ) ) $ READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( BALANC, 'P' ).OR.LSAME( BALANC, 'S' ).OR. $ LSAME( BALANC, 'B' ) ) $ READ ( NIN, FMT = * ) ( SCALE(I), I = 1,N ) READ ( NIN, FMT = * ) ( ( U1(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( U2(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( V1(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( V2(I,J), J = 1,N ), I = 1,N ) * CALL MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, 2*N, $ 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) I, WR(I), WI(I) 20 CONTINUE * IF ( LSAME( STAB, 'S' ).OR.LSAME( STAB, 'B' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, 2*N WRITE ( NOUT, FMT = 99993 ) ( US(I,J), J = 1,M ) 30 CONTINUE IF ( LSAME( ORTBAL, 'B' ).OR.LSAME( BALANC, 'N' ).OR. $ LSAME( BALANC, 'P' ) ) THEN CALL DGEMM( 'Transpose', 'No Transpose', M, M, 2*N, $ ONE, US, LDUS, US, LDUS, ZERO, RES, $ LDRES ) DO 40 I = 1, M RES(I,I) = RES(I,I) - ONE 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, ONE, $ US, LDUS, US(N+1,1), LDUS, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, -ONE, $ US(N+1,1), LDUS, US, LDUS, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99990 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF * IF ( LSAME( STAB, 'U' ).OR.LSAME( STAB, 'B' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 50 I = 1, 2*N WRITE ( NOUT, FMT = 99993 ) ( UU(I,J), J = 1,M ) 50 CONTINUE IF ( LSAME( ORTBAL, 'B' ).OR.LSAME( BALANC, 'N' ).OR. $ LSAME( BALANC, 'P' ) ) THEN CALL DGEMM( 'Transpose', 'No Transpose', M, M, 2*N, $ ONE, UU, LDUU, UU, LDUU, ZERO, RES, $ LDRES ) DO 60 I = 1, M RES(I,I) = RES(I,I) - ONE 60 CONTINUE WRITE ( NOUT, FMT = 99989 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, ONE, $ UU, LDUU, UU(N+1,1), LDUU, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, N, -ONE, $ UU(N+1,1), LDUU, UU, LDUU, ONE, RES, LDRES ) WRITE ( NOUT, FMT = 99988 ) DLANGE( 'Frobenius', M, M, $ RES, LDRES, DWORK ) END IF END IF END IF * 99999 FORMAT (' MB03ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB03ZD = ',I2) 99997 FORMAT (' The stable eigenvalues are',//' i',6X, $ 'WR(i)',6X,'WI(i)',/) 99996 FORMAT (I4,3X,F8.4,3X,F8.4) 99995 FORMAT (/' A basis for the stable invariant subspace is') 99994 FORMAT (/' A basis for the unstable invariant subspace is') 99993 FORMAT (20(1X,F9.3)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of US: || US''*US - I ||_F = ',G7.2) 99990 FORMAT (/' Symplecticity of US: || US''*J*US ||_F = ',G7.2) 99989 FORMAT (/' Orthogonality of UU: || UU''*UU - I ||_F = ',G7.2) 99988 FORMAT (/' Symplecticity of UU: || UU''*J*UU ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB04AD.f000077500000000000000000000124061201767322700167120ustar00rootroot00000000000000* MB04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 50 ) INTEGER LDH, LDQ1, LDQ2, LDT, LDU11, LDU12, LDU21, $ LDU22, LDWORK, LDZ, LIWORK PARAMETER ( LDH = NMAX, LDQ1 = NMAX, LDQ2 = NMAX, $ LDT = NMAX, LDU11 = NMAX/2, LDU12 = NMAX/2, $ LDU21 = NMAX/2, LDU22 = NMAX/2, $ LDWORK = 3*NMAX*NMAX + NMAX + 48, $ LDZ = NMAX, LIWORK = NMAX/2 + 18 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * * .. Local Scalars .. CHARACTER COMPQ1, COMPQ2, COMPU1, COMPU2, JOB INTEGER I, INFO, J, M, N * * .. Local Arrays .. INTEGER IWORK( LIWORK ) DOUBLE PRECISION ALPHAI( NMAX/2 ), ALPHAR( NMAX/2 ), $ BETA( NMAX/2 ), DWORK( LDWORK ), $ H( LDH, NMAX ), Q1( LDQ1, NMAX ), $ Q2( LDQ2, NMAX ), T( LDT, NMAX ), $ U11( LDU11, NMAX/2 ), U12( LDU12, NMAX/2 ), $ U21( LDU21, NMAX/2 ), U22( LDU22, NMAX/2 ), $ Z( LDZ, NMAX ) * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL DLASET, MB04AD * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE READ( NIN, FMT = * ) ( ( Z( I, J ), J = 1, N ), I = 1, N ) READ( NIN, FMT = * ) ( ( H( I, J ), J = 1, N ), I = 1, N ) * Compute the eigenvalues of a real skew-Hamiltonian/Hamiltonian * pencil (factored version). CALL MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ, H, $ LDH, T, LDT, Q1, LDQ1, Q2, LDQ2, U11, LDU11, U12, $ LDU12, U21, LDU21, U22, LDU22, ALPHAR, ALPHAI, $ BETA, IWORK, LIWORK, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE M = N/2 CALL DLASET( 'Full', M, M, ZERO, ZERO, Z( M+1, 1 ), LDZ ) WRITE( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE( NOUT, FMT = 99995 ) ( T( I, J ), J = 1, N ) 10 CONTINUE WRITE( NOUT, FMT = 99994 ) DO 20 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Z( I, J ), J = 1, N ) 20 CONTINUE WRITE( NOUT, FMT = 99993 ) DO 30 I = 1, N WRITE( NOUT, FMT = 99995 ) ( H( I, J ), J = 1, N ) 30 CONTINUE IF( LSAME( COMPQ1, 'C' ) ) THEN WRITE( NOUT, FMT = 99992 ) DO 40 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q1( I, J ), J = 1, N ) 40 CONTINUE END IF IF( LSAME( COMPQ2, 'C' ) ) THEN WRITE( NOUT, FMT = 99991 ) DO 50 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q2( I, J ), J = 1, N ) 50 CONTINUE END IF IF( LSAME( COMPU1, 'C' ) ) THEN WRITE( NOUT, FMT = 99990 ) DO 60 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U11( I, J ), J = 1, M ) 60 CONTINUE WRITE( NOUT, FMT = 99989 ) DO 70 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U12( I, J ), J = 1, M ) 70 CONTINUE END IF IF( LSAME( COMPU2, 'C' ) ) THEN WRITE( NOUT, FMT = 99988 ) DO 80 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U21( I, J ), J = 1, M ) 80 CONTINUE WRITE( NOUT, FMT = 99987 ) DO 90 I = 1, M WRITE( NOUT, FMT = 99995 ) ( U22( I, J ), J = 1, M ) 90 CONTINUE END IF WRITE( NOUT, FMT = 99986 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M ) WRITE( NOUT, FMT = 99985 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M ) WRITE( NOUT, FMT = 99984 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, M ) END IF END IF STOP * 99999 FORMAT( 'MB04AD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB04AD = ', I2 ) 99996 FORMAT( 'The matrix T on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix Z on exit is ' ) 99993 FORMAT( 'The matrix H is ' ) 99992 FORMAT( 'The matrix Q1 is ' ) 99991 FORMAT( 'The matrix Q2 is ' ) 99990 FORMAT( 'The upper left block of the matrix U1 is ' ) 99989 FORMAT( 'The upper right block of the matrix U1 is ' ) 99988 FORMAT( 'The upper left block of the matrix U2 is ' ) 99987 FORMAT( 'The upper right block of the matrix U2 is ' ) 99986 FORMAT( 'The vector ALPHAR is ' ) 99985 FORMAT( 'The vector ALPHAI is ' ) 99984 FORMAT( 'The vector BETA is ' ) END slicot-5.0+20101122/examples77/TMB04BD.f000077500000000000000000000117231201767322700167140ustar00rootroot00000000000000* MB04BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 50 ) INTEGER LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1, LDQ2, $ LDVW, LDWORK, LIWORK PARAMETER ( LDA = NMAX/2, LDB = NMAX/2, LDC1 = NMAX/2, $ LDC2 = NMAX/2, LDDE = NMAX/2, LDF = NMAX/2, $ LDQ1 = NMAX, LDQ2 = NMAX, LDVW = NMAX/2, $ LDWORK = 2*NMAX*NMAX + NMAX + 32, $ LIWORK = NMAX/2 + 12 ) * * .. Local Scalars .. CHARACTER COMPQ1, COMPQ2, JOB INTEGER I, INFO, J, M, N * * .. Local Arrays .. INTEGER IWORK( LIWORK ) DOUBLE PRECISION A( LDA, NMAX/2 ), ALPHAI( NMAX/2 ), $ ALPHAR( NMAX/2 ), B( LDB, NMAX/2 ), $ BETA( NMAX/2 ), C1( LDC1, NMAX/2 ), $ C2( LDC2, NMAX/2 ), DE( LDDE, NMAX/2+1 ), $ DWORK( LDWORK ), F( LDF, NMAX/2 ), $ Q1( LDQ1, NMAX ), Q2( LDQ2, NMAX ), $ VW( LDVW, NMAX/2+1 ) * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL MB04BD * * .. Executable Statements .. * WRITE( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ( NIN, FMT = * ) READ( NIN, FMT = * ) JOB, COMPQ1, COMPQ2, N IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE( NOUT, FMT = 99998 ) N ELSE M = N/2 READ( NIN, FMT = * ) ( ( A( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( DE( I, J ), J = 1, M+1 ), I = 1, M ) READ( NIN, FMT = * ) ( ( C1( I, J ), J = 1, M ), I = 1, M ) READ( NIN, FMT = * ) ( ( VW( I, J ), J = 1, M+1 ), I = 1, M ) * Compute the eigenvalues of a real skew-Hamiltonian/Hamiltonian * pencil. CALL MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1, $ LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F, $ LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK, $ LIWORK, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE( NOUT, FMT = 99997 ) INFO ELSE WRITE( NOUT, FMT = 99996 ) DO 10 I = 1, M WRITE( NOUT, FMT = 99995 ) ( A( I, J ), J = 1, M ) 10 CONTINUE WRITE( NOUT, FMT = 99994 ) DO 20 I = 1, M WRITE( NOUT, FMT = 99995 ) ( DE( I, J ), J = 2, M+1 ) 20 CONTINUE WRITE( NOUT, FMT = 99993 ) DO 30 I = 1, M WRITE( NOUT, FMT = 99995 ) ( B( I, J ), J = 1, M ) 30 CONTINUE WRITE( NOUT, FMT = 99992 ) DO 40 I = 1, M WRITE( NOUT, FMT = 99995 ) ( F( I, J ), J = 1, M ) 40 CONTINUE WRITE( NOUT, FMT = 99991 ) DO 50 I = 1, M WRITE( NOUT, FMT = 99995 ) ( C1( I, J ), J = 1, M ) 50 CONTINUE WRITE( NOUT, FMT = 99990 ) DO 60 I = 1, M WRITE( NOUT, FMT = 99995 ) ( C2( I, J ), J = 1, M ) 60 CONTINUE WRITE( NOUT, FMT = 99989 ) DO 70 I = 1, M WRITE( NOUT, FMT = 99995 ) ( VW( I, J ), J = 2, M+1 ) 70 CONTINUE WRITE( NOUT, FMT = 99988 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAR( I ), I = 1, M ) WRITE( NOUT, FMT = 99987 ) WRITE( NOUT, FMT = 99995 ) ( ALPHAI( I ), I = 1, M ) WRITE( NOUT, FMT = 99986 ) WRITE( NOUT, FMT = 99995 ) ( BETA( I ), I = 1, M ) WRITE( NOUT, FMT = 99985 ) IF( .NOT.LSAME( COMPQ1, 'N' ) ) THEN DO 80 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q1( I, J ), J = 1, N ) 80 CONTINUE END IF IF( .NOT.LSAME( COMPQ2, 'N' ) ) THEN WRITE( NOUT, FMT = 99984 ) DO 90 I = 1, N WRITE( NOUT, FMT = 99995 ) ( Q2( I, J ), J = 1, N ) 90 CONTINUE END IF END IF END IF STOP * 99999 FORMAT( 'MB04BD EXAMPLE PROGRAM RESULTS', 1X ) 99998 FORMAT( 'N is out of range.', /, 'N = ', I5 ) 99997 FORMAT( 'INFO on exit from MB04BD = ', I2 ) 99996 FORMAT( 'The matrix A on exit is ' ) 99995 FORMAT( 50( 1X, F8.4 ) ) 99994 FORMAT( 'The matrix D on exit is ' ) 99993 FORMAT( 'The matrix B on exit is ' ) 99992 FORMAT( 'The matrix F on exit is ' ) 99991 FORMAT( 'The matrix C1 on exit is ' ) 99990 FORMAT( 'The matrix C2 on exit is ' ) 99989 FORMAT( 'The matrix V on exit is ' ) 99988 FORMAT( 'The vector ALPHAR is ' ) 99987 FORMAT( 'The vector ALPHAI is ' ) 99986 FORMAT( 'The vector BETA is ' ) 99985 FORMAT( 'The matrix Q1 is ' ) 99984 FORMAT( 'The matrix Q2 is ' ) END slicot-5.0+20101122/examples77/TMB04DD.f000077500000000000000000000044601201767322700167160ustar00rootroot00000000000000* MB04DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, ILO, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), DUMMY(1), QG(LDQG, NMAX+1), $ SCALE(NMAX) * .. External Functions .. DOUBLE PRECISION DLANTR, DLAPY2 EXTERNAL DLANTR, DLAPY2 * .. External Subroutines .. EXTERNAL MB04DD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99995) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99995) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE WRITE (NOUT, FMT = 99993) ILO IF ( ILO.GT.1 ) THEN WRITE (NOUT, FMT = 99992) DLAPY2( DLANTR( 'Frobenius', $ 'Lower', 'No Unit', N-1, ILO-1, A(2,1), LDA, $ DUMMY ), DLANTR( 'Frobenius', 'Lower', 'No Unit', $ N, ILO-1, QG(1,1), LDQG, DUMMY ) ) END IF END IF END IF * 99999 FORMAT (' MB04DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04DD = ',I2) 99997 FORMAT (' The balanced matrix A is ') 99996 FORMAT (/' The balanced matrix QG is ') 99995 FORMAT (20(1X,F12.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' ILO = ',I4) 99992 FORMAT (/' Norm of subdiagonal blocks: ',G7.2) END slicot-5.0+20101122/examples77/TMB04DS.f000077500000000000000000000044611201767322700167360ustar00rootroot00000000000000* MB04DS EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, ILO, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), DUMMY(1), QG(LDQG, NMAX+1), $ SCALE(NMAX) * .. External Functions .. DOUBLE PRECISION DLANTR, DLAPY2 EXTERNAL DLANTR, DLAPY2 * .. External Subroutines .. EXTERNAL MB04DS * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99995) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99995) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE WRITE (NOUT, FMT = 99993) ILO IF ( ILO.GT.1 ) THEN WRITE (NOUT, FMT = 99992) DLAPY2( DLANTR( 'Frobenius', $ 'Lower', 'No Unit', N-1, ILO-1, A(2,1), LDA, $ DUMMY ), DLANTR( 'Frobenius', 'Lower', 'No Unit', $ N-1, ILO-1, QG(2,1), LDQG, DUMMY ) ) END IF END IF END IF * 99999 FORMAT (' MB04DS EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04DS = ',I2) 99997 FORMAT (' The balanced matrix A is ') 99996 FORMAT (/' The balanced matrix QG is ') 99995 FORMAT (20(1X,F9.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' ILO = ',I4) 99992 FORMAT (/' Norm of subdiagonal blocks: ',G7.2) END slicot-5.0+20101122/examples77/TMB04DY.f000077500000000000000000000051471201767322700167460ustar00rootroot00000000000000* MB04DY EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDQG PARAMETER ( LDA = NMAX, LDQG = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N CHARACTER*1 JOBSCL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), D(NMAX), DWORK(LDWORK), $ QG(LDQG,NMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04DY * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOBSCL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99998 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), I = J,N ), J = 1,N ) * Scale the Hamiltonian matrix. CALL MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE * Show the scaled Hamiltonian matrix. WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99993 ) ( A(I,J), J = 1,N ), $ ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N ) 10 CONTINUE DO 20 I = 1, N WRITE ( NOUT, FMT = 99993 ) ( QG(I,J), J = 1,I-1 ), $ ( QG(J,I), J = I,N ), ( -A(J,I), J = 1,N ) 20 CONTINUE * Show the scaling factors. IF ( LSAME( JOBSCL, 'S' ) ) THEN WRITE ( NOUT, FMT = 99995 ) WRITE ( NOUT, FMT = 99993 ) ( D(I), I = 1,N ) ELSE IF ( LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) ) $ THEN WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99993 ) D(1) END IF ENDIF END IF STOP * 99999 FORMAT (' MB04DY EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' N is out of range.',/' N = ',I5) 99997 FORMAT (' INFO on exit from MB04DY = ',I2) 99996 FORMAT (/' The scaled Hamiltonian is ') 99995 format (/' The scaling factors are ') 99994 format (/' The scaling factor tau is ') 99993 FORMAT (1X,8(F10.4)) END slicot-5.0+20101122/examples77/TMB04GD.f000077500000000000000000000047411201767322700167230ustar00rootroot00000000000000* MB04GD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 10, MMAX = 10 ) INTEGER LDA PARAMETER ( LDA = MMAX ) INTEGER LDTAU PARAMETER ( LDTAU = (MMAX + NMAX) ) INTEGER LDWORK PARAMETER ( LDWORK = 3*MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), TAU(LDTAU) INTEGER JPVT(MMAX) * .. External Subroutines .. EXTERNAL DLASET, MB04GD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99972 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99971 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( JPVT(I), I = 1,M ) * RQ with row pivoting. CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) ( JPVT(I), I = 1,M ) WRITE ( NOUT, FMT = 99990 ) IF ( M.GE.N ) THEN IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, $ A(M-N+2,1), LDA ) ELSE CALL DLASET( 'Full', M, N-M-1, ZERO, ZERO, A, LDA ) CALL DLASET( 'Lower', M, M, ZERO, ZERO, A(1,N-M), $ LDA ) END IF DO 20 I = 1, M WRITE ( NOUT, FMT = 99989 ) ( A(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MB04GD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04GD = ',I2) 99994 FORMAT (' Row permutations are ',/(20(I3,2X))) 99990 FORMAT (/' The matrix A is ') 99989 FORMAT (20(1X,F8.4)) 99972 FORMAT (/' N is out of range.',/' N = ',I5) 99971 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TMB04MD.f000077500000000000000000000030741201767322700167270ustar00rootroot00000000000000* MB04MD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N DOUBLE PRECISION MAXRED * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), SCALE(NMAX) * .. External Subroutines .. EXTERNAL MB04MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, MAXRED IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Balance matrix A. CALL MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) ( SCALE(I), I = 1,N ) END IF END IF STOP * 99999 FORMAT (' MB04MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04MD = ',I2) 99997 FORMAT (' The balanced matrix is ') 99996 FORMAT (20(1X,F10.4)) 99994 FORMAT (/' SCALE is ',/20(1X,F10.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB04OD.f000077500000000000000000000056631201767322700167370ustar00rootroot00000000000000* MB04OD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 20, NMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDR PARAMETER ( LDA = PMAX, LDB = NMAX, LDC = PMAX, $ LDR = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX-1 + MMAX ) ) * .. Local Scalars .. CHARACTER*1 UPLO INTEGER I, J, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK), R(LDR,NMAX), TAU(NMAX) * .. External Subroutines .. EXTERNAL MB04OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,P ) * Compute and apply QR factorization. CALL MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, $ LDC, TAU, DWORK ) * WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, N DO 20 J = 1, I-1 R(I,J) = ZERO 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) ( R(I,J), J = 1,N ) 40 CONTINUE IF ( M.GT.0 ) THEN WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE IF ( P.GT.0 ) THEN WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' MB04OD EXAMPLE PROGRAM RESULTS',/1X) 99997 FORMAT (' The updated matrix R is ') 99996 FORMAT (20(1X,F10.4)) 99995 FORMAT (' The updated matrix B is ') 99994 FORMAT (' The updated matrix C is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TMB04PB.f000077500000000000000000000155631201767322700167360ustar00rootroot00000000000000* MB04PB/MB04WP EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NBMAX PARAMETER ( NMAX = 7, NBMAX = 3 ) INTEGER LDA, LDQG, LDRES, LDU1, LDU2, LDWORK PARAMETER ( LDA = NMAX, LDQG = NMAX, LDRES = NMAX, $ LDU1 = NMAX, LDU2 = NMAX, $ LDWORK = 8*NBMAX*NMAX + 3*NBMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), CS(2*NMAX), DWORK(LDWORK), $ QG(LDQG, NMAX+1), RES(LDRES,3*NMAX+1), TAU(NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX) * .. External Functions .. DOUBLE PRECISION MA02ID, MA02JD EXTERNAL MA02ID, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DSYMM, DSYR, $ DSYR2K, DTRMM, MB04PB, MB04WP * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES ) CALL MB04PB( N, 1, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, $ INFO ) INFO = 0 IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'Lower', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'Lower', N, N, QG, LDQG, U2, LDU2 ) CALL MB04WP( N, 1, U1, LDU1, U2, LDU2, CS, TAU, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE 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, QG(2,1), $ LDQG ) WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99993) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99993) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE C CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DSYMM ( 'Right', 'Upper', N, N, ONE, QG(1,2), LDQG, $ U1, LDU1, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DLACPY( 'All', N, N, U2, LDU2, RES, LDRES ) DO 50 I = 1, N CALL DSCAL( N, QG(I,I), RES(1,I), 1 ) 50 CONTINUE CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+1), LDRES ) CALL DSCAL( N, ONE/TWO, QG(1,2), LDQG+1 ) CALL DLACPY( 'Full', N, N, U2, LDU2, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+1), LDRES ) DO 60 I = 1, N CALL DSYR( 'Lower', N, -QG(I,I), U1(1,I), 1, $ RES(1,2*N+1), LDRES ) 60 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+2), LDRES ) CALL DLACPY( 'Full', N, N, U1, LDU1, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, -ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+2), LDRES ) DO 70 I = 1, N CALL DSYR( 'Upper', N, QG(I,I), U2(1,I), 1, $ RES(1,2*N+2), LDRES ) 70 CONTINUE C WRITE ( NOUT, FMT = 99990 ) MA02ID( 'Hamiltonian', $ 'Frobenius', N, RES(1,N+1), LDRES, RES(1,2*N+1), $ LDRES, DWORK ) END IF END IF END IF * 99999 FORMAT (' TMB04PB EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04PB = ',I2) 99997 FORMAT (' INFO on exit from MB04WP = ',I2) 99996 FORMAT (' The symplectic orthogonal factor U is ') 99995 FORMAT (/' The reduced matrix A is ') 99994 FORMAT (/' The reduced matrix QG is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H - U*R*U'' ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB04PU.f000077500000000000000000000154731201767322700167610ustar00rootroot00000000000000* MB04PU/MB04WP EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 100 ) INTEGER LDA, LDQG, LDRES, LDU1, LDU2, LDWORK PARAMETER ( LDA = NMAX, LDQG = NMAX, LDRES = NMAX, $ LDU1 = NMAX, LDU2 = NMAX, LDWORK = 2*NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), CS(2*NMAX), DWORK(LDWORK), $ QG(LDQG, NMAX+1), RES(LDRES,3*NMAX+1), TAU(NMAX), $ U1(LDU1,NMAX), U2(LDU2, NMAX) * .. External Functions .. DOUBLE PRECISION MA02ID, MA02JD EXTERNAL MA02ID, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DSYMM, DSYR, $ DSYR2K, DTRMM, MB04PU, MB04WP * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N ) CALL DLACPY( 'All', N, N+1, QG, LDQG, RES(1,2*N+1), LDRES ) CALL MB04PU( N, 1, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, $ INFO ) INFO = 0 IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'Lower', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'Lower', N, N, QG, LDQG, U2, LDU2 ) CALL MB04WP( N, 1, U1, LDU1, U2, LDU2, CS, TAU, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE 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, QG(2,1), $ LDQG ) WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., .FALSE., N, $ U1, LDU1, U2, LDU2, RES, LDRES ) WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, N WRITE (NOUT, FMT = 99993) ( A(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE (NOUT, FMT = 99993) ( QG(I,J), J = 1,N+1 ) 40 CONTINUE C CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DSYMM ( 'Right', 'Upper', N, N, ONE, QG(1,2), LDQG, $ U1, LDU1, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U2, LDU2, ONE, RES(1,N+1), $ LDRES ) CALL DLACPY( 'All', N, N, U2, LDU2, RES, LDRES ) DO 50 I = 1, N CALL DSCAL( N, QG(I,I), RES(1,I), 1 ) 50 CONTINUE CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, -ONE, $ RES, LDRES, U1, LDU1, ONE, RES(1,N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U2, LDU2, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+1), LDRES ) CALL DSCAL( N, ONE/TWO, QG(1,2), LDQG+1 ) CALL DLACPY( 'Full', N, N, U2, LDU2, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Lower', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+1), LDRES ) DO 60 I = 1, N CALL DSYR( 'Lower', N, -QG(I,I), U1(1,I), 1, $ RES(1,2*N+1), LDRES ) 60 CONTINUE CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, A, LDA, ZERO, RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, ONE, RES, $ LDRES, U2, LDU2, ONE, RES(1,2*N+2), LDRES ) CALL DLACPY( 'Full', N, N, U1, LDU1, RES, LDRES ) CALL DTRMM( 'Right', 'Upper' , 'No Transpose', $ 'Not unit', N, N, ONE, QG(1,2), LDQG, $ RES, LDRES ) CALL DSYR2K( 'Upper', 'No Transpose', N, N, -ONE, RES, $ LDRES, U1, LDU1, ONE, RES(1,2*N+2), LDRES ) DO 70 I = 1, N CALL DSYR( 'Upper', N, QG(I,I), U2(1,I), 1, $ RES(1,2*N+2), LDRES ) 70 CONTINUE C WRITE ( NOUT, FMT = 99990 ) MA02ID( 'Hamiltonian', $ 'Frobenius', N, RES(1,N+1), LDRES, RES(1,2*N+1), $ LDRES, DWORK ) END IF END IF END IF * 99999 FORMAT (' TMB04PU EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04PU = ',I2) 99997 FORMAT (' INFO on exit from MB04WP = ',I2) 99996 FORMAT (' The symplectic orthogonal factor U is ') 99995 FORMAT (/' The reduced matrix A is ') 99994 FORMAT (/' The reduced matrix QG is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U''*U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H - U*R*U'' ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB04TB.f000077500000000000000000000255721201767322700167430ustar00rootroot00000000000000* MB04TB/MB04WR EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NBMAX, NMAX PARAMETER ( NBMAX = 64, NMAX = 421 ) INTEGER LDA, LDB, LDG, LDQ, LDRES, LDU1, LDU2, LDV1, $ LDV2, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDG = NMAX, LDQ = NMAX, $ LDRES = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDV1 = NMAX, LDV2 = NMAX, $ LDWORK = NBMAX*( 16*NMAX + 1 ) ) * .. Local Scalars .. CHARACTER*1 TRANA, TRANB, TRANV1 INTEGER I, INFO, J, N DOUBLE PRECISION TEMP * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, NMAX), CSL(2*NMAX), $ CSR(2*NMAX), DWORK(LDWORK), G(LDG, NMAX), $ Q(LDQ, NMAX), RES(LDRES,5*NMAX), TAUL(NMAX), $ TAUR(NMAX), U1(LDU1, NMAX), U2(LDU2, NMAX), $ V1(LDV1, NMAX), V2(LDV2, NMAX) * .. External Functions .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLAPY2, MA02JD EXTERNAL DLANGE, DLAPY2, LSAME, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, MB04TB, MB04WR * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TRANA, TRANB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES, LDRES ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, B, LDB, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, G, LDG, RES(1,2*N+1), LDRES ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, Q, LDQ, RES(1,3*N+1), LDRES ) CALL MB04TB( TRANA, TRANB, N, 1, A, LDA, B, LDB, G, LDG, Q, $ LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'All', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'All', N, N, Q, LDQ, U2, LDU2 ) CALL MB04WR( 'U', TRANA, N, 1, U1, LDU1, U2, LDU2, CSL, $ TAUL, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE CALL DLACPY( 'All', N, N, Q, LDQ, V2, LDV2 ) CALL DLACPY( 'All', N, N, B, LDB, V1, LDV1 ) CALL MB04WR( 'V', TRANB, N, 1, V1, LDV1, V2, LDV2, $ CSR, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) IF ( LSAME( TRANA, 'N' ) ) THEN DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) ELSE DO 30 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(J,I), J = 1,N ), ( U2(I,J), J = 1,N ) 30 CONTINUE DO 40 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(J,I), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .TRUE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) END IF WRITE ( NOUT, FMT = 99995 ) CALL DLASET( 'All', N, N, ZERO, ZERO, Q, LDQ ) IF ( LSAME( TRANA, 'N' ) ) THEN CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, $ A(2,1), LDA ) DO 50 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(I,J), J = 1,N ), ( G(I,J), J = 1,N ) 50 CONTINUE ELSE CALL DLASET( 'Upper', N-1, N-1, ZERO, ZERO, $ A(1,2), LDA ) DO 60 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(J,I), J = 1,N ), ( G(I,J), J = 1,N ) 60 CONTINUE END IF IF ( LSAME( TRANB, 'N' ) ) THEN IF ( N.GT.1 ) THEN CALL DLASET( 'Upper', N-2, N-2, ZERO, ZERO, $ B(1,3), LDB ) END IF DO 70 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(I,J), J = 1,N ) 70 CONTINUE ELSE IF ( N.GT.1 ) THEN C CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, C $ B(3,1), LDB ) END IF DO 80 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(J,I), J = 1,N ) 80 CONTINUE END IF C IF ( LSAME( TRANB, 'N' ) ) THEN TRANV1 = 'T' ELSE TRANV1 = 'N' END IF CALL DGEMM( TRANA, TRANV1, N, N, N, ONE, RES, LDRES, $ V1, LDV1, ZERO, RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, RES(1,2*N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, TRANA, N, N, N, -ONE, U1, LDU1, $ A, LDA, ONE, RES(1,4*N+1), LDRES ) TEMP = DLANGE( 'Frobenius', N, N, RES(1,4*N+1), $ LDRES, DWORK ) CALL DGEMM( TRANA, 'Transpose', N, N, N, ONE, RES, $ LDRES, V2, LDV2, ZERO, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,2*N+1), LDRES, V1, LDV1, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, 'No Transpose', N, N, N, -ONE, $ U1, LDU1, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANB, N, N, N, -ONE, $ U2, LDU2, B, LDB, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,3*N+1), LDRES, V1, LDV1, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, 'Transpose', N, N, N, -ONE, $ RES(1,N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', TRANA, N, N, N, ONE, $ U2, LDU2, A, LDA, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES(1,3*N+1), LDRES, V2, LDV2, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, TRANV1, N, N, N, ONE, RES(1,N+1), $ LDRES, V1, LDV1, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ ONE, U2, LDU2, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( TRANA, TRANB, N, N, N, -ONE, U1, LDU1, $ B, LDB, ONE, RES(1,4*N+1), LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) WRITE ( NOUT, FMT = 99990 ) TEMP C WRITE ( NOUT, FMT = 99994 ) IF ( LSAME( TRANB, 'N' ) ) THEN DO 90 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(J,I), J = 1,N ), ( V2(J,I), J = 1,N ) 90 CONTINUE DO 100 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(J,I), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .TRUE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) ELSE DO 110 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(I,J), J = 1,N ), ( V2(J,I), J = 1,N ) 110 CONTINUE DO 120 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(I,J), J = 1,N ) 120 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .FALSE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) END IF END IF END IF END IF END IF * STOP * 99999 FORMAT (' MB04TB EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04TB = ',I2) 99997 FORMAT (' INFO on exit from MB04WR = ',I2) 99996 FORMAT (' The orthogonal symplectic factor U is ') 99995 FORMAT (/' The factor R is ') 99994 FORMAT (/' The orthogonal symplectic factor V is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2) 99989 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB04TS.f000077500000000000000000000254301201767322700167550ustar00rootroot00000000000000* MB04TS/MB04WR EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 200 ) INTEGER LDA, LDB, LDG, LDQ, LDRES, LDU1, LDU2, LDV1, $ LDV2, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDG = NMAX, LDQ = NMAX, $ LDRES = NMAX, LDU1 = NMAX, LDU2 = NMAX, $ LDV1 = NMAX, LDV2 = NMAX, LDWORK = NMAX ) * .. Local Scalars .. CHARACTER*1 TRANA, TRANB, TRANV1 INTEGER I, INFO, J, N DOUBLE PRECISION TEMP * .. Local Arrays .. DOUBLE PRECISION A(LDA, NMAX), B(LDB, NMAX), CSL(2*NMAX), $ CSR(2*NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), RES(LDRES,5*NMAX), TAUL(NMAX), $ TAUR(NMAX), U1(LDU1,NMAX), U2(LDU2, NMAX), $ V1(LDV1, NMAX), V2(LDV2,NMAX) * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLAPY2, MA02JD EXTERNAL DLANGE, DLAPY2, LSAME, MA02JD * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, MB04TS, MB04WR * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TRANA, TRANB IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, A, LDA, RES, LDRES ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, B, LDB, RES(1,N+1), LDRES ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, G, LDG, RES(1,2*N+1), LDRES ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'All', N, N, Q, LDQ, RES(1,3*N+1), LDRES ) CALL MB04TS( TRANA, TRANB, N, 1, A, LDA, B, LDB, G, LDG, Q, $ LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL DLACPY( 'All', N, N, A, LDA, U1, LDU1 ) CALL DLACPY( 'All', N, N, Q, LDQ, U2, LDU2 ) CALL MB04WR( 'U', TRANA, N, 1, U1, LDU1, U2, LDU2, CSL, $ TAUL, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE CALL DLACPY( 'All', N, N, Q, LDQ, V2, LDV2 ) CALL DLACPY( 'All', N, N, B, LDB, V1, LDV1 ) CALL MB04WR( 'V', TRANB, N, 1, V1, LDV1, V2, LDV2, $ CSR, TAUR, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) IF ( LSAME( TRANA, 'N' ) ) THEN DO 10 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(I,J), J = 1,N ), ( U2(I,J), J = 1,N ) 10 CONTINUE DO 20 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .FALSE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) ELSE DO 30 I = 1, N WRITE (NOUT, FMT = 99993) $ ( U1(J,I), J = 1,N ), ( U2(I,J), J = 1,N ) 30 CONTINUE DO 40 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -U2(I,J), J = 1,N ), ( U1(J,I), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) MA02JD( .TRUE., $ .FALSE., N, U1, LDU1, U2, LDU2, $ RES(1,4*N+1), LDRES ) END IF WRITE ( NOUT, FMT = 99995 ) CALL DLASET( 'All', N, N, ZERO, ZERO, Q, LDQ ) IF ( LSAME( TRANA, 'N' ) ) THEN CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, $ A(2,1), LDA ) DO 50 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(I,J), J = 1,N ), ( G(I,J), J = 1,N ) 50 CONTINUE ELSE CALL DLASET( 'Upper', N-1, N-1, ZERO, ZERO, $ A(1,2), LDA ) DO 60 I = 1, N WRITE (NOUT, FMT = 99993) $ ( A(J,I), J = 1,N ), ( G(I,J), J = 1,N ) 60 CONTINUE END IF IF ( LSAME( TRANB, 'N' ) ) THEN IF ( N.GT.1 ) THEN CALL DLASET( 'Upper', N-2, N-2, ZERO, ZERO, $ B(1,3), LDB ) END IF DO 70 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(I,J), J = 1,N ) 70 CONTINUE ELSE IF ( N.GT.1 ) THEN CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, $ B(3,1), LDB ) END IF DO 80 I = 1, N WRITE (NOUT, FMT = 99993) $ ( Q(I,J), J = 1,N ), ( B(J,I), J = 1,N ) 80 CONTINUE END IF C IF ( LSAME( TRANB, 'N' ) ) THEN TRANV1 = 'T' ELSE TRANV1 = 'N' END IF CALL DGEMM( TRANA, TRANV1, N, N, N, ONE, RES, LDRES, $ V1, LDV1, ZERO, RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, $ -ONE, RES(1,2*N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, TRANA, N, N, N, -ONE, U1, LDU1, $ A, LDA, ONE, RES(1,4*N+1), LDRES ) TEMP = DLANGE( 'Frobenius', N, N, RES(1,4*N+1), $ LDRES, DWORK ) CALL DGEMM( TRANA, 'Transpose', N, N, N, ONE, RES, $ LDRES, V2, LDV2, ZERO, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,2*N+1), LDRES, V1, LDV1, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANA, 'No Transpose', N, N, N, -ONE, $ U1, LDU1, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', TRANB, N, N, N, -ONE, $ U2, LDU2, B, LDB, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', TRANV1, N, N, N, ONE, $ RES(1,3*N+1), LDRES, V1, LDV1, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, 'Transpose', N, N, N, -ONE, $ RES(1,N+1), LDRES, V2, LDV2, ONE, $ RES(1,4*N+1), LDRES ) CALL DGEMM( 'No Transpose', TRANA, N, N, N, ONE, $ U2, LDU2, A, LDA, ONE, RES(1,4*N+1), $ LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, $ RES(1,3*N+1), LDRES, V2, LDV2, ZERO, $ RES(1,4*N+1), LDRES ) CALL DGEMM( TRANB, TRANV1, N, N, N, ONE, RES(1,N+1), $ LDRES, V1, LDV1, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, $ ONE, U2, LDU2, G, LDG, ONE, RES(1,4*N+1), $ LDRES ) CALL DGEMM( TRANA, TRANB, N, N, N, -ONE, U1, LDU1, $ B, LDB, ONE, RES(1,4*N+1), LDRES ) TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, $ RES(1,4*N+1), LDRES, DWORK ) ) WRITE ( NOUT, FMT = 99990 ) TEMP C WRITE ( NOUT, FMT = 99994 ) IF ( LSAME( TRANB, 'N' ) ) THEN DO 90 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(J,I), J = 1,N ), ( V2(J,I), J = 1,N ) 90 CONTINUE DO 100 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(J,I), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .TRUE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) ELSE DO 110 I = 1, N WRITE (NOUT, FMT = 99993) $ ( V1(I,J), J = 1,N ), ( V2(J,I), J = 1,N ) 110 CONTINUE DO 120 I = 1, N WRITE (NOUT, FMT = 99993) $ ( -V2(J,I), J = 1,N ), ( V1(I,J), J = 1,N ) 120 CONTINUE WRITE ( NOUT, FMT = 99989 ) MA02JD( .FALSE., $ .TRUE., N, V1, LDV1, V2, LDV2, $ RES(1,4*N+1), LDRES ) END IF END IF END IF END IF END IF * STOP * 99999 FORMAT (' MB04TS EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04TS = ',I2) 99997 FORMAT (' INFO on exit from MB04WR = ',I2) 99996 FORMAT (' The orthogonal symplectic factor U is ') 99995 FORMAT (/' The factor R is ') 99994 FORMAT (/' The orthogonal symplectic factor V is ') 99993 FORMAT (20(1X,F9.4)) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' Orthogonality of U: || U^T U - I ||_F = ',G7.2) 99990 FORMAT (/' Residual: || H*V - U*R ||_F = ',G7.2) 99989 FORMAT (/' Orthogonality of V: || V^T V - I ||_F = ',G7.2) END slicot-5.0+20101122/examples77/TMB04UD.f000077500000000000000000000047621201767322700167440ustar00rootroot00000000000000* MB04UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDE, LDQ, LDZ PARAMETER ( LDA = MMAX, LDE = MMAX, LDQ = MMAX, $ LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX+MMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, RANKE CHARACTER*1 JOBQ, JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX), $ Q(LDQ,MMAX), Z(LDZ,NMAX) INTEGER ISTAIR(MMAX) * .. External Subroutines .. EXTERNAL MB04UD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, TOL IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M ) JOBQ = 'N' JOBZ = 'N' * Reduce E to column echelon form and compute Q'*A*Z. CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ, $ RANKE, ISTAIR, TOL, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99991 ) DO 10 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99997 ) DO 100 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( E(I,J), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99995 ) RANKE WRITE ( NOUT, FMT = 99994 ) ( ISTAIR(I), I = 1,M ) END IF END IF STOP * 99999 FORMAT (' MB04UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04UD = ',I2) 99997 FORMAT (' The transformed matrix E is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The computed rank of E = ',I2) 99994 FORMAT (/' ISTAIR is ',/20(1X,I5)) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (' The transformed matrix A is ') END slicot-5.0+20101122/examples77/TMB04VD.f000077500000000000000000000122441201767322700167370ustar00rootroot00000000000000* MB04VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDE, LDQ, LDZ PARAMETER ( LDA = MMAX, LDE = MMAX, LDQ = MMAX, $ LDZ = NMAX ) INTEGER LINUK PARAMETER ( LINUK = NMAX+MMAX+1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX+MMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NBLCKI, NBLCKS, RANKE CHARACTER*1 JOBQ, JOBZ, MODE * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX), $ Q(LDQ,MMAX), Z(LDZ,NMAX) INTEGER IMUK(LINUK), IMUK0(NMAX), INUK(LINUK), $ ISTAIR(MMAX), IWORK(LIWORK), MNEI(3) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04UD, MB04VD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, TOL, MODE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99984 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99983 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M ) JOBQ = 'I' JOBZ = 'I' * Reduce E to column echelon form and compute Q'*A*Z. CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ, $ RANKE, ISTAIR, TOL, DWORK, INFO ) JOBQ = 'U' JOBZ = 'U' * IF ( INFO.EQ.0 ) THEN * Compute a unitary transformed pencil Q'*(s*E-A)*Z. CALL 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 ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) WRITE ( NOUT, FMT = 99995 ) DO 140 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( Q(I,J), J = 1,M ) 140 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 160 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( E(I,J), J = 1,N ) 160 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 180 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N ) 180 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 200 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N ) 200 CONTINUE WRITE ( NOUT, FMT = 99990 ) NBLCKS IF ( .NOT. LSAME( MODE, 'S' ) ) THEN WRITE ( NOUT, FMT = 99989 ) ( IMUK(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99988 ) ( INUK(I), I = 1,NBLCKS ) ELSE WRITE ( NOUT, FMT = 99987 ) ( IMUK(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99986 ) ( INUK(I), I = 1,NBLCKS ) WRITE ( NOUT, FMT = 99982 ) ( IMUK0(I), I = 1,NBLCKI ) WRITE ( NOUT, FMT = 99985 ) ( MNEI(I), I = 1,3 ) END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF ELSE WRITE ( NOUT, FMT = 99997 ) INFO END IF END IF STOP * 99999 FORMAT (' MB04VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04VD = ',I2) 99997 FORMAT (' INFO on exit from MB04UD = ',I2) 99996 FORMAT (' The unitary transformed pencil is Q''*(s*E-A)*Z, where', $ /) 99995 FORMAT (' Matrix Q',/) 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' Matrix E',/) 99992 FORMAT (/' Matrix A',/) 99991 FORMAT (/' Matrix Z',/) 99990 FORMAT (/' The number of submatrices having full row rank detect', $ 'ed in matrix A = ',I3) 99989 FORMAT (/' The column dimensions of the submatrices having full ', $ 'column rank in the pencil',/' sE(eps,inf) - A(eps,inf) a', $ 're',/20(1X,I5)) 99988 FORMAT (/' The row dimensions of the submatrices having full row', $ ' rank in the pencil',/' sE(eps,inf) - A(eps,inf) are', $ /20(1X,I5)) 99987 FORMAT (/' The column dimensions of the submatrices having full ', $ 'column rank in the pencil',/' sE(eps) - A(eps) are', $ /20(1X,I5)) 99986 FORMAT (/' The row dimensions of the submatrices having full row', $ ' rank in the pencil',/' sE(eps) - A(eps) are',/20(1X,I5)) 99985 FORMAT (/' MNEI is ',/20(1X,I5)) 99984 FORMAT (/' M is out of range.',/' M = ',I5) 99983 FORMAT (/' N is out of range.',/' N = ',I5) 99982 FORMAT (/' The orders of the diagonal submatrices in the pencil ', $ 'sE(inf) - A(inf) are',/20(1X,I5)) END slicot-5.0+20101122/examples77/TMB04XD.f000077500000000000000000000126041201767322700167410ustar00rootroot00000000000000* MB04XD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDU, LDV PARAMETER ( LDA = MMAX, LDU = MMAX, LDV = NMAX ) INTEGER MAXMN, MNMIN PARAMETER ( MAXMN = ( MMAX + NMAX ), $ MNMIN = ( MMAX + NMAX ) ) INTEGER LENGQ PARAMETER ( LENGQ = 2*MNMIN-1 ) INTEGER LDWORK PARAMETER ( LDWORK = ( 2*NMAX + NMAX*( NMAX+1 )/2 ) $ + ( 2*MNMIN + MAXMN + 8*MNMIN - 5 ) ) * .. Local Scalars .. DOUBLE PRECISION RELTOL, THETA, THETA1, TOL INTEGER I, INFO, IWARN, J, K, LOOP, M, MINMN, N, NCOLU, $ NCOLV, RANK, RANK1 CHARACTER*1 JOBU, JOBV LOGICAL LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), Q(LENGQ), $ U(LDU,MMAX), V(LDV,NMAX) LOGICAL INUL(MAXMN) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04XD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, RANK, THETA, TOL, RELTOL, JOBU, JOBV IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99983 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99982 ) N ELSE IF ( RANK.GT.MNMIN ) THEN WRITE ( NOUT, FMT = 99981 ) RANK ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99980 ) THETA ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) RANK1 = RANK THETA1 = THETA * Compute a basis for the left and right singular subspace of A. CALL MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, V, $ LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) RANK ELSE IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK END IF IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA LJOBUA = LSAME( JOBU, 'A' ) LJOBUS = LSAME( JOBU, 'S' ) LJOBVA = LSAME( JOBV, 'A' ) LJOBVS = LSAME( JOBV, 'S' ) WANTU = LJOBUA.OR.LJOBUS WANTV = LJOBVA.OR.LJOBVS WRITE ( NOUT, FMT = 99994 ) MINMN = MIN( M, N ) LOOP = MINMN - 1 DO 20 I = 1, LOOP K = I + MINMN WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K) 20 CONTINUE WRITE ( NOUT, FMT = 99992 ) MINMN, MINMN, Q(MINMN) IF ( WANTU ) THEN NCOLU = M IF ( LJOBUS ) NCOLU = MINMN WRITE ( NOUT, FMT = 99986 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99985 ) ( U(I,J), J = 1,NCOLU ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) NCOLU WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, NCOLU WRITE ( NOUT, FMT = 99989 ) I, INUL(I) 60 CONTINUE END IF IF ( WANTV ) THEN NCOLV = N IF ( LJOBVS ) NCOLV = MINMN WRITE ( NOUT, FMT = 99984 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99985 ) ( V(I,J), J = 1,NCOLV ) 80 CONTINUE WRITE ( NOUT, FMT = 99988 ) NCOLV WRITE ( NOUT, FMT = 99987 ) DO 100 J = 1, NCOLV WRITE ( NOUT, FMT = 99989 ) J, INUL(J) 100 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB04XD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04XD = ',I2) 99997 FORMAT (' IWARN on exit from MB04XD = ',I2,/) 99996 FORMAT (' The computed rank of matrix A = ',I3,/) 99995 FORMAT (' The computed value of THETA = ',F7.4,/) 99994 FORMAT (' The elements of the partially diagonalized bidiagonal ', $ 'matrix are',/) 99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/) 99991 FORMAT (/' Left singular subspace corresponds to the i-th column', $ '(s) of U for which ',/' INUL(i) = .TRUE., i = 1,...,',I1, $ /) 99990 FORMAT (' i INUL(i)',/) 99989 FORMAT (I3,L8) 99988 FORMAT (/' Right singular subspace corresponds to the j-th colum', $ 'n(s) of V for which ',/' INUL(j) = .TRUE., j = 1,...,',I1, $ /) 99987 FORMAT (' j INUL(j)',/) 99986 FORMAT (' Matrix U',/) 99985 FORMAT (20(1X,F8.4)) 99984 FORMAT (/' Matrix V',/) 99983 FORMAT (/' M is out of range.',/' M = ',I5) 99982 FORMAT (/' N is out of range.',/' N = ',I5) 99981 FORMAT (/' RANK is out of range.',/' RANK = ',I5) 99980 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4) END slicot-5.0+20101122/examples77/TMB04YD.f000077500000000000000000000111761201767322700167450ustar00rootroot00000000000000* MB04YD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER MNMIN PARAMETER ( MNMIN = ( MMAX + NMAX ) ) INTEGER LDU, LDV PARAMETER ( LDU = MMAX, LDV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 6*MNMIN - 5 ) * .. Local Scalars .. DOUBLE PRECISION RELTOL, THETA, TOL INTEGER I, INFO, IWARN, J, M, MINMN, N, RANK, RANK1 CHARACTER*1 JOBU, JOBV LOGICAL LJOBUU, LJOBVU * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), E(MNMIN-1), Q(MNMIN), $ U(LDU,MNMIN), V(LDV,MNMIN) LOGICAL INUL(MNMIN) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MB04YD * .. Intrinsic Functions .. INTRINSIC MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, THETA, RANK, TOL, RELTOL, JOBU, JOBV MINMN = MIN( M, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99988 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99987 ) N ELSE IF ( RANK.GT.MINMN ) THEN WRITE ( NOUT, FMT = 99986 ) RANK ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN WRITE ( NOUT, FMT = 99985 ) THETA ELSE READ ( NIN, FMT = * ) ( Q(I), I = 1,MINMN ) READ ( NIN, FMT = * ) ( E(I), I = 1,MINMN-1 ) RANK1 = RANK LJOBUU = LSAME( JOBU, 'U' ) LJOBVU = LSAME( JOBV, 'U' ) IF ( LJOBUU ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,MINMN ), I = 1,M ) IF ( LJOBVU ) READ ( NIN, FMT = * ) $ ( ( V(I,J), J = 1,MINMN ), I = 1,N ) * Initialise the array INUL. DO 20 I = 1, MINMN INUL(I) = .FALSE. 20 CONTINUE IF ( LJOBUU.OR.LJOBVU ) READ ( NIN, FMT = * ) $ ( INUL(I), I = 1,MINMN ) * Compute the number of singular values of J > THETA. CALL MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V, $ LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99993 ) IWARN WRITE ( NOUT, FMT = 99984 ) RANK END IF WRITE ( NOUT, FMT = 99997 ) DO 160 I = 1, MINMN - 1 WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I) 160 CONTINUE WRITE ( NOUT, FMT = 99995 ) MINMN, MINMN, Q(MINMN) IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99994 ) RANK, THETA IF ( .NOT.LSAME( JOBV, 'N' ) ) THEN WRITE ( NOUT, FMT = 99992 ) DO 180 I = 1, N WRITE ( NOUT, FMT = 99991 ) ( V(I,J), J = 1,MINMN ) 180 CONTINUE END IF IF ( ( .NOT.LSAME( JOBU, 'N' ) ) .AND. $ ( .NOT.LSAME( JOBV, 'N' ) ) ) $ WRITE ( NOUT, FMT = 99990 ) IF ( .NOT.LSAME( JOBU, 'N' ) ) THEN WRITE ( NOUT, FMT = 99989 ) DO 200 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( U(I,J), J = 1,MINMN ) 200 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' MB04YD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB04YD = ',I2) 99997 FORMAT (' The transformed bidiagonal matrix J is',/) 99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X)) 99995 FORMAT (' (',I1,',',I1,') = ',F7.4) 99994 FORMAT (/' J has ',I2,' singular values >',F7.4,/) 99993 FORMAT (' IWARN on exit from MB04YD = ',I2,/) 99992 FORMAT (' The product of the right-hand Givens rotation matrices', $ ' equals ') 99991 FORMAT (20(1X,F8.4)) 99990 FORMAT (' ') 99989 FORMAT (' The product of the left-hand Givens rotation matrices ', $ 'equals ') 99988 FORMAT (/' M is out of range.',/' M = ',I5) 99987 FORMAT (/' N is out of range.',/' N = ',I5) 99986 FORMAT (/' RANK is out of range.',/' RANK = ',I5) 99985 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4) 99984 FORMAT (/' The computed rank of matrix J = ',I3,/) END slicot-5.0+20101122/examples77/TMB04ZD.f000077500000000000000000000077231201767322700167510ustar00rootroot00000000000000* MB04ZD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDQG, LDU PARAMETER ( LDA = NMAX, LDQG = NMAX, LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX+NMAX )*( NMAX+NMAX+1 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. INTEGER I, INFO, IJ, J, JI, N, POS, WPOS CHARACTER*1 COMPU * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), QG(LDQG,NMAX+1), $ U(LDU,NMAX) * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DSYMV, MB04ZD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, COMPU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99998 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N ) READ ( NIN, FMT = * ) ( ( QG(I,J), I = J,N ), J = 1,N ) * Square-reduce by symplectic orthogonal similarity. CALL MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE * Show the square-reduced Hamiltonian. WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,N ), $ ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N ) 10 CONTINUE DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( QG(I,J), J = 1,I-1 ), $ ( QG(J,I), J = I,N ), ( -A(J,I), J = 1,N ) 20 CONTINUE * Show the square of H. WRITE ( NOUT, FMT = 99995 ) WPOS = ( NMAX+NMAX )*( NMAX+NMAX ) * T * Compute N11 = A*A + G*Q and set N22 = N11 . CALL DGEMM( 'N', 'N', N, N, N, ONE, A, LDA, A, LDA, ZERO, $ DWORK, N+N ) DO 30 I = 1, N CALL DCOPY( N-I+1, QG(I,I), 1, DWORK(WPOS+I), 1 ) CALL DCOPY( I-1, QG(I,1), LDQG, DWORK(WPOS+1), 1 ) CALL DSYMV( 'U', N, ONE, QG(1,2), LDQG, DWORK(WPOS+1), 1, $ ONE, DWORK((I-1)*(N+N)+1), 1 ) POS = N*( N+N ) + N + I CALL DCOPY( N, DWORK((I-1)*(N+N)+1), 1, DWORK(POS), N+N ) 30 CONTINUE DO 40 I = 1, N CALL DSYMV( 'U', N, -ONE, QG(1,2), LDQG, A(I,1), LDA, $ ZERO, DWORK((N+I-1)*(N+N)+1), 1 ) CALL DSYMV( 'L', N, ONE, QG, LDQG, A(1,I), 1, ZERO, $ DWORK((I-1)*(N+N)+N+1), 1 ) 40 CONTINUE DO 60 J = 1, N DO 50 I = J, N IJ = ( N+J-1 )*( N+N ) + I JI = ( N+I-1 )*( N+N ) + J DWORK(IJ) = DWORK(IJ) - DWORK(JI) DWORK(JI) = -DWORK(IJ) IJ = N + I + ( J-1 )*( N+N ) JI = N + J + ( I-1 )*( N+N ) DWORK(IJ) = DWORK(IJ) - DWORK(JI) DWORK(JI) = -DWORK(IJ) 50 CONTINUE 60 CONTINUE DO 70 I = 1, N+N WRITE ( NOUT, FMT = 99994 ) $ ( DWORK(I+(J-1)*(N+N) ), J = 1,N+N ) 70 CONTINUE ENDIF END IF STOP * 99999 FORMAT (' MB04ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' N is out of range.',/' N = ',I5) 99997 FORMAT (' INFO on exit from MB04ZD = ',I2) 99996 FORMAT (/' The square-reduced Hamiltonian is ') 99995 FORMAT (/' The square of the square-reduced Hamiltonian is ') 99994 FORMAT (1X,8(F10.4)) END slicot-5.0+20101122/examples77/TMB05MD.f000077500000000000000000000046651201767322700167370ustar00rootroot00000000000000* MB05MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDV, LDY PARAMETER ( LDA = NMAX, LDV = NMAX, LDY = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX ) * .. Local Scalars .. DOUBLE PRECISION DELTA INTEGER I, INFO, J, N CHARACTER*1 BALANC * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), V(LDV,NMAX), $ VALI(NMAX), VALR(NMAX), Y(LDY,NMAX) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL MB05MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) BALANC = 'N' READ ( NIN, FMT = * ) N, DELTA IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Find the exponential of the real non-defective matrix A*DELTA. CALL MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR, $ VALI, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) ( VALR(I), VALI(I), I = 1,N ) WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( V(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( Y(I,J), J = 1,N ) 60 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB05MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB05MD = ',I2) 99997 FORMAT (' The solution matrix exp(A*DELTA) is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The eigenvalues of A are ',/20(2F5.1,'*j ')) 99994 FORMAT (/' The eigenvector matrix for A is ') 99993 FORMAT (/' The inverse eigenvector matrix for A (premultiplied by' $ ,' exp(Lambda*DELTA)) is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB05ND.f000077500000000000000000000037301201767322700167300ustar00rootroot00000000000000* MB05ND EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDEX, LDEXIN, LDWORK PARAMETER ( LDA = NMAX, LDEX = NMAX, LDEXIN = NMAX, $ LDWORK = NMAX*( NMAX+1 ) ) * .. Local Scalars .. DOUBLE PRECISION DELTA, TOL INTEGER I, INFO, J, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), EX(LDEX,NMAX), $ EXINT(LDEXIN,NMAX) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL MB05ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DELTA, TOL IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Find the matrix exponential of A*DELTA and its integral. CALL MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, TOL, $ IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( EX(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( EXINT(I,J), J = 1,N ) 40 CONTINUE END IF END IF STOP * 99999 FORMAT (' MB05ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB05ND = ',I2) 99997 FORMAT (' The solution matrix exp(A*DELTA) is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' and its integral is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TMB05OD.f000077500000000000000000000043301201767322700167260ustar00rootroot00000000000000* MB05OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = NMAX ) INTEGER NDIAG PARAMETER ( NDIAG = 9 ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( 2*NMAX+NDIAG+1 )+NDIAG ) * .. Local Scalars .. DOUBLE PRECISION DELTA INTEGER I, IDIG, INFO, IWARN, J, MDIG, N CHARACTER*1 BALANC * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK) INTEGER IWORK(NMAX) * .. External Subroutines .. EXTERNAL MB05OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DELTA, BALANC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) * Find the exponential of the real defective matrix A*DELTA. CALL MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG, $ IWORK, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) $ WRITE ( NOUT, FMT = 99993 ) IWARN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) MDIG, IDIG END IF END IF STOP * 99999 FORMAT (' MB05OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MB05OD = ',I2) 99997 FORMAT (' The solution matrix E = exp(A*DELTA) is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' Minimal number of accurate digits in the norm of E =', $ I4,/' Number of accurate digits in the norm of E',/' ', $ ' at 95 per cent confidence interval =',I4) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (' IWARN on exit from MB05OD = ',I2) END slicot-5.0+20101122/examples77/TMC01MD.f000077500000000000000000000030321201767322700167170ustar00rootroot00000000000000* MC01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA INTEGER DP, I, INFO, K * .. Local Arrays .. DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1) * .. External Subroutines .. EXTERNAL MC01MD * .. Executable Statements .. WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP, ALPHA, K IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Compute the leading K coefficients of the shifted polynomial. CALL MC01MD( DP, ALPHA, K, P, Q, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) ALPHA DO 20 I = 1, K WRITE ( NOUT, FMT = 99996 ) I - 1, Q(I) 20 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MC01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01MD = ',I2) 99997 FORMAT (' ALPHA = ',F8.4,//' The coefficients of the shifted pol', $ 'ynomial are ',//' power of (x-ALPHA) coefficient ') 99996 FORMAT (5X,I5,15X,F9.4) 99995 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples77/TMC01ND.f000077500000000000000000000027001201767322700167210ustar00rootroot00000000000000* MC01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION VI, VR, XI, XR INTEGER DP, I, INFO * .. Local Arrays .. DOUBLE PRECISION P(DPMAX+1) * .. External Subroutines .. EXTERNAL MC01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP, XR, XI IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Evaluate the polynomial at the given (complex) point. CALL MC01ND( DP, XR, XI, P, VR, VI, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) XR, XI, VR WRITE ( NOUT, FMT = 99996 ) XR, XI, VI END IF END IF * STOP * 99999 FORMAT (' MC01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01ND = ',I2) 99997 FORMAT (' Real part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4) 99996 FORMAT (/' Imaginary part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4) 99995 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples77/TMC01OD.f000077500000000000000000000030241201767322700167220ustar00rootroot00000000000000* MC01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX PARAMETER ( KMAX = 10 ) * .. Local Scalars .. INTEGER I, INFO, K * .. Local Arrays .. DOUBLE PRECISION DWORK(2*KMAX+2), IMP(KMAX+1), IMZ(KMAX), $ REP(KMAX+1), REZ(KMAX) * .. External Subroutines .. EXTERNAL MC01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K IF ( K.LT.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99995 ) K ELSE READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K ) * Compute the coefficients of P(x) from the given zeros. CALL MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99996 ) $ ( I, REP(I+1), IMP(I+1), I = 0,K ) END IF END IF STOP * 99999 FORMAT (' MC01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01OD = ',I2) 99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe', $ 'r of x real part imag part ') 99996 FORMAT (2X,I5,8X,F9.4,5X,F9.4) 99995 FORMAT (/' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples77/TMC01PD.f000077500000000000000000000026621201767322700167320ustar00rootroot00000000000000* MC01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER KMAX PARAMETER ( KMAX = 10 ) * .. Local Scalars .. INTEGER I, INFO, K * .. Local Arrays .. DOUBLE PRECISION DWORK(KMAX+1), IMZ(KMAX), P(KMAX+1), REZ(KMAX) * .. External Subroutines .. EXTERNAL MC01PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) K IF ( K.LT.0 .OR. K.GT.KMAX ) THEN WRITE ( NOUT, FMT = 99995 ) K ELSE READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K ) * Compute the coefficients of P(x) from the given zeros. CALL MC01PD( K, REZ, IMZ, P, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99996 ) ( I, P(I+1), I = 0,K ) END IF END IF STOP * 99999 FORMAT (' MC01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01PD = ',I2) 99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe', $ 'r of x coefficient ') 99996 FORMAT (2X,I5,9X,F9.4) 99995 FORMAT (' K is out of range.',/' K = ',I5) END slicot-5.0+20101122/examples77/TMC01QD.f000077500000000000000000000052721201767322700167330ustar00rootroot00000000000000* MC01QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DAMAX, DBMAX PARAMETER ( DAMAX = 10, DBMAX = 10 ) * .. Local Scalars .. INTEGER DA, DB, DBB, DQ, DR, I, IMAX, INFO, IWARN * .. Local Arrays .. DOUBLE PRECISION A(DAMAX+1), B(DBMAX+1), RQ(DAMAX+1) * .. External Subroutines .. EXTERNAL MC01QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DA IF ( DA.LE.-2 .OR. DA.GT.DAMAX ) THEN WRITE ( NOUT, FMT = 99991 ) DA ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 ) READ ( NIN, FMT = * ) DB DBB = DB IF ( DB.LE.-1 .OR. DB.GT.DBMAX ) THEN WRITE ( NOUT, FMT = 99990 ) DB ELSE READ ( NIN, FMT = * ) ( B(I), I = 1,DB+1 ) * Compute Q(x) and R(x) from the given A(x) and B(x). CALL MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) DBB, DB END IF WRITE ( NOUT, FMT = 99995 ) DQ = DA - DB DR = DB - 1 IMAX = DQ IF ( DR.GT.IMAX ) IMAX = DR DO 20 I = 0, IMAX IF ( I.LE.DQ .AND. I.LE.DR ) THEN WRITE ( NOUT, FMT = 99994 ) I, RQ(DB+I+1), RQ(I+1) ELSE IF ( I.LE.DQ ) THEN WRITE ( NOUT, FMT = 99993 ) I, RQ(DB+I+1) ELSE WRITE ( NOUT, FMT = 99992 ) I, RQ(I+1) END IF 20 CONTINUE END IF END IF END IF * STOP * 99999 FORMAT (' MC01QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01QD = ',I2) 99997 FORMAT (' IWARN on exit from MC01QD = ',I2,/) 99996 FORMAT (' The degree of the denominator polynomial B(x) has been', $ ' reduced from ',I2,' to ',I2,/) 99995 FORMAT (' The coefficients of the polynomials Q(x) and R(x) are ', $ //' Q(x) R(x) ',/' power of', $ ' x coefficient coefficient ') 99994 FORMAT (2X,I5,9X,F9.4,7X,F9.4) 99993 FORMAT (2X,I5,9X,F9.4) 99992 FORMAT (2X,I5,25X,F9.4) 99991 FORMAT (/' DA is out of range.',/' DA = ',I5) 99990 FORMAT (/' DB is out of range.',/' DB = ',I5) END slicot-5.0+20101122/examples77/TMC01RD.f000077500000000000000000000047411201767322700167340ustar00rootroot00000000000000* MC01RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DP1MAX, DP2MAX, DP3MAX PARAMETER ( DP1MAX = 10, DP2MAX = 10, DP3MAX = 10 ) INTEGER LENP3 PARAMETER ( LENP3 = (DP1MAX+DP2MAX+DP3MAX)+1 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA INTEGER DP1, DP2, DP3, I, INFO * .. Local Arrays .. DOUBLE PRECISION P1(DP1MAX+1), P2(DP2MAX+1), P3(LENP3) * $ P3(DP1MAX+DP2MAX+DP3MAX+1) * .. External Subroutines .. EXTERNAL MC01RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP1 IF ( DP1.LE.-2 .OR. DP1.GT.DP1MAX ) THEN WRITE ( NOUT, FMT = 99994 ) DP1 ELSE READ ( NIN, FMT = * ) ( P1(I), I = 1,DP1+1 ) READ ( NIN, FMT = * ) DP2 IF ( DP2.LE.-2 .OR. DP2.GT.DP2MAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP2 ELSE READ ( NIN, FMT = * ) ( P2(I), I = 1,DP2+1 ) READ ( NIN, FMT = * ) DP3 IF ( DP3.LE.-2 .OR. DP3.GT.DP3MAX ) THEN WRITE ( NOUT, FMT = 99992 ) DP3 ELSE READ ( NIN, FMT = * ) ( P3(I), I = 1,DP3+1 ) END IF READ ( NIN, FMT = * ) ALPHA * Compute the coefficients of the polynomial P(x). CALL MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DP3 IF ( DP3.GE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 20 I = 0, DP3 WRITE ( NOUT, FMT = 99995 ) I, P3(I+1) 20 CONTINUE END IF END IF END IF END IF * STOP * 99999 FORMAT (' MC01RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01RD = ',I2) 99997 FORMAT (' Degree of the resulting polynomial P(x) = ',I2) 99996 FORMAT (/' The coefficients of P(x) are ',//' power of x coe', $ 'fficient ') 99995 FORMAT (2X,I5,9X,F9.4) 99994 FORMAT (/' DP1 is out of range.',/' DP1 = ',I5) 99993 FORMAT (/' DP2 is out of range.',/' DP2 = ',I5) 99992 FORMAT (/' DP3 is out of range.',/' DP3 = ',I5) END slicot-5.0+20101122/examples77/TMC01SD.f000077500000000000000000000035411201767322700167320ustar00rootroot00000000000000* MC01SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 10 ) * .. Local Scalars .. INTEGER BETA, DP, I, INFO, S, T * .. Local Arrays .. DOUBLE PRECISION MANT(DPMAX+1), P(DPMAX+1) INTEGER E(DPMAX+1), IWORK(DPMAX+1) C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. External Subroutines .. EXTERNAL MC01SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Compute the coefficients of the scaled polynomial Q(x). CALL MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE BETA = DLAMCH( 'Base' ) WRITE ( NOUT, FMT = 99995 ) BETA, S, T WRITE ( NOUT,FMT = 99997 ) DO 20 I = 0, DP WRITE ( NOUT, FMT = 99996 ) I, P(I+1) 20 CONTINUE END IF END IF * STOP * 99999 FORMAT (' MC01SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01SD = ',I2) 99997 FORMAT (/' The coefficients of the scaled polynomial Q(x) = s*P(', $ 'tx) are ',//' power of x coefficient ') 99996 FORMAT (2X,I5,9X,F9.4) 99995 FORMAT (' The base of the machine (BETA) = ',I2,//' The scaling ', $ 'factors are s = BETA**(',I3,') and t = BETA**(',I3,')') 99994 FORMAT (/' DP is out of range.',/' DP =',I5) END slicot-5.0+20101122/examples77/TMC01TD.f000077500000000000000000000044541201767322700167370ustar00rootroot00000000000000* MC01TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 10 ) * .. Local Scalars .. INTEGER DP, DPP, I, INFO, IWARN, NZ LOGICAL STABLE CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION DWORK(2*DPMAX+2), P(DPMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MC01TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = * ) READ ( NIN, FMT = * ) DP, DICO IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE DPP = DP READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) * Determine whether or not the given polynomial P(x) is stable. CALL MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( IWARN.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) IWARN WRITE ( NOUT, FMT = 99996 ) DPP, DP END IF IF ( STABLE ) THEN WRITE ( NOUT, FMT = 99995 ) ELSE WRITE ( NOUT, FMT = 99994 ) IF ( LSAME( DICO, 'D' ) ) THEN WRITE ( NOUT, FMT = 99992 ) NZ ELSE WRITE ( NOUT, FMT = 99991 ) NZ END IF END IF END IF END IF STOP * 99999 FORMAT (' MC01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01TD = ',I2) 99997 FORMAT (' IWARN on exit from MC01TD = ',I2,/) 99996 FORMAT (' The degree of the polynomial P(x) has been reduced fro', $ 'm ',I2,' to ',I2,/) 99995 FORMAT (' The polynomial P(x) is stable ') 99994 FORMAT (' The polynomial P(x) is unstable ') 99993 FORMAT (/' DP is out of range. ',/' DP = ',I5) 99992 FORMAT (/' The number of zeros of P(x) outside the unit ', $ 'circle = ',I2) 99991 FORMAT (/' The number of zeros of P(x) in the right ', $ 'half-plane = ',I2) END slicot-5.0+20101122/examples77/TMC01VD.f000077500000000000000000000021571201767322700167370ustar00rootroot00000000000000* MC01VD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) * .. Local Scalars .. DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE INTEGER INFO * .. External Subroutines .. EXTERNAL MC01VD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) A, B, C * Solve the quadratic equation A*x**2 + B*x + C = 0. CALL MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) WRITE ( NOUT, FMT = 99996 ) Z1RE, Z1IM, Z2RE, Z2IM END IF * STOP * 99999 FORMAT (' MC01VD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01VD = ',I2) 99997 FORMAT (' The roots of the quadratic equation are ') 99996 FORMAT (/' x = ',F8.4,2X,SP,F8.4,'*j',SS,/' x = ',F8.4,2X,SP,F8.4, $ '*j') END slicot-5.0+20101122/examples77/TMC01WD.f000077500000000000000000000034171201767322700167400ustar00rootroot00000000000000* MC01WD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX PARAMETER ( DPMAX = 10 ) * .. Local Scalars .. DOUBLE PRECISION U1, U2 INTEGER DP, I, INFO * .. Local Arrays .. DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1) * .. External Subroutines .. EXTERNAL MC01WD * .. Executable Statements .. * WRITE ( NOUT,FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) DP IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) DP ELSE READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 ) READ ( NIN, FMT = * ) U1, U2 * Compute Q(x) and R(x) from P(x) = (x**2+U2*x+U1) * Q(x) + R(x). CALL MC01WD( DP, P, U1, U2, Q, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 0, DP - 2 WRITE ( NOUT, FMT = 99996 ) I, Q(I+3) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) Q(1) + Q(2)*U2, Q(2) END IF END IF * STOP * 99999 FORMAT (' MC01WD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC01WD = ',I2) 99997 FORMAT (' The coefficients of the quotient polynomial Q(x) are ', $ //' power of x coefficient ') 99996 FORMAT (2X,I5,9X,F9.4) 99995 FORMAT (/' The coefficients of the remainder polynomial R(x) are ' $ ,//' power of x coefficient ',/' 0 ',F9.4, $ /' 1 ',F9.4) 99994 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples77/TMC03MD.f000077500000000000000000000077161201767322700167360ustar00rootroot00000000000000* MC03MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER CP1MAX, CP2MAX, DP1MAX, DP2MAX, DP3MAX, RP1MAX PARAMETER ( CP1MAX = 10, CP2MAX = 10, DP1MAX = 10, $ DP2MAX = 10, DP3MAX = 20, RP1MAX = 10 ) INTEGER LDP11, LDP12, LDP21, LDP22, LDP31, LDP32 PARAMETER ( LDP11 = RP1MAX, LDP12 = CP1MAX, $ LDP21 = CP1MAX, LDP22 = CP2MAX, $ LDP31 = RP1MAX, LDP32 = CP2MAX ) * .. Local Scalars .. DOUBLE PRECISION ALPHA INTEGER CP1, CP2, DP1, DP2, DP3, I, INFO, J, K, RP1 * .. Local Arrays .. DOUBLE PRECISION DWORK(CP1MAX), $ P1(LDP11,LDP12,DP1MAX+1), $ P2(LDP21,LDP22,DP2MAX+1), $ P3(LDP31,LDP32,DP3MAX+1) * .. External Subroutines .. EXTERNAL MC03MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) RP1, CP1, CP2 IF ( RP1.LT.0 .OR. RP1.GT.RP1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) RP1 ELSE IF ( CP1.LT.0 .OR. CP1.GT.CP1MAX ) THEN WRITE ( NOUT, FMT = 99994 ) CP1 ELSE IF ( CP2.LT.0 .OR. CP2.GT.CP2MAX ) THEN WRITE ( NOUT, FMT = 99993 ) CP2 ELSE READ ( NIN, FMT = * ) DP1 IF ( DP1.LE.-2 .OR. DP1.GT.DP1MAX ) THEN WRITE ( NOUT, FMT = 99992 ) DP1 ELSE DO 40 K = 1, DP1 + 1 DO 20 J = 1, CP1 READ ( NIN, FMT = * ) ( P1(I,J,K), I = 1,RP1 ) 20 CONTINUE 40 CONTINUE READ ( NIN, FMT = * ) DP2 IF ( DP2.LE.-2 .OR. DP2.GT.DP2MAX ) THEN WRITE ( NOUT, FMT = 99991 ) DP2 ELSE DO 80 K = 1, DP2 + 1 DO 60 J = 1, CP2 READ ( NIN, FMT = * ) ( P2(I,J,K), I = 1,CP1 ) 60 CONTINUE 80 CONTINUE READ ( NIN, FMT = * ) DP3 IF ( DP3.LE.-2 .OR. DP3.GT.DP3MAX ) THEN WRITE ( NOUT, FMT = 99990 ) DP3 ELSE DO 120 K = 1, DP3 + 1 DO 100 J = 1, CP2 READ ( NIN, FMT = * ) ( P3(I,J,K), I = 1,RP1 ) 100 CONTINUE 120 CONTINUE READ ( NIN, FMT = * ) ALPHA * Compute the coefficients of the polynomial matrix P(x) CALL MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1, $ LDP11, LDP12, P2, LDP21, LDP22, P3, $ LDP31, LDP32, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DP3, $ ( I-1, I = 1,DP3+1 ) DO 160 I = 1, RP1 DO 140 J = 1, CP2 WRITE ( NOUT, FMT = 99996 ) I, J, $ ( P3(I,J,K), K = 1,DP3+1 ) 140 CONTINUE 160 CONTINUE END IF END IF END IF END IF END IF * STOP * 99999 FORMAT (' MC03MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC03MD = ',I2) 99997 FORMAT (' The polynomial matrix P(x) (of degree ',I2,') is ', $ //' power of x ',20I8) 99996 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F7.2)) 99995 FORMAT (/' RP1 is out of range.',/' RP1 = ',I5) 99994 FORMAT (/' CP1 is out of range.',/' CP1 = ',I5) 99993 FORMAT (/' CP2 is out of range.',/' CP2 = ',I5) 99992 FORMAT (/' DP1 is out of range.',/' DP1 = ',I5) 99991 FORMAT (/' DP2 is out of range.',/' DP2 = ',I5) 99990 FORMAT (/' DP3 is out of range.',/' DP3 = ',I5) END slicot-5.0+20101122/examples77/TMC03ND.f000077500000000000000000000066071201767322700167350ustar00rootroot00000000000000* MC03ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DPMAX, MPMAX, NPMAX * PARAMETER ( DPMAX = 5, MPMAX = 5, NPMAX = 5 ) PARAMETER ( DPMAX = 2, MPMAX = 5, NPMAX = 4 ) INTEGER LDP1, LDP2, LDNULL, LDKER1, LDKER2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX, LDNULL = NPMAX, $ LDKER1 = NPMAX, LDKER2 = NPMAX ) INTEGER M, N PARAMETER ( M = DPMAX*MPMAX, N = ( DPMAX-1 )*MPMAX+NPMAX ) INTEGER LIWORK, LDWORK PARAMETER ( LIWORK = M+2*( N+M+1 )+N, $ LDWORK = M*N**2+2*M*N+2*N**2 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER DK, DP, I, INFO, J, K, M1, MP, NK, NP * .. Local Arrays .. DOUBLE PRECISION DWORK(LDWORK), KER(LDKER1,LDKER2,M+1), $ NULLSP(LDNULL,(M+1)*NPMAX), P(LDP1,LDP2,DPMAX+1) INTEGER GAM(M+1), IWORK(LIWORK) * .. External Subroutines .. EXTERNAL MC03ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP, TOL IF ( MP.LT.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99990 ) MP ELSE IF ( NP.LT.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NP ELSE IF ( DP.LE.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99992 ) DP ELSE DO 40 K = 1, DP + 1 DO 20 I = 1, MP READ ( NIN, FMT = * ) ( P(I,J,K), J = 1,NP ) 20 CONTINUE 40 CONTINUE * Compute a minimal polynomial basis K(s) of the given P(s). CALL MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP, $ LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( DK.LT.0 ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE NK = 0 M1 = 0 DO 60 I = 1, DK + 1 NK = NK + GAM(I) M1 = M1 + GAM(I)*I 60 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 80 I = 1, NP WRITE ( NOUT, FMT = 99995 ) ( NULLSP(I,J), J = 1,M1 ) 80 CONTINUE WRITE ( NOUT, FMT = 99994 ) DK, ( I-1, I = 1,DK+1 ) DO 120 I = 1, NP DO 100 J = 1, NK WRITE ( NOUT, FMT = 99993 ) $ I, J, ( KER(I,J,K), K = 1,DK+1 ) 100 CONTINUE 120 CONTINUE END IF END IF STOP * 99999 FORMAT (' MC03ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MC03ND = ',I2) 99997 FORMAT (' The polynomial matrix P(s) has no right nullspace') 99996 FORMAT (' The right nullspace vectors of P(s) are ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The minimal polynomial basis K(s) (of degree ',I2,') ', $ 'for the right nullspace is ',//' power of s ', $ 20I8) 99993 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F7.2)) 99992 FORMAT (/' DP is out of range.',/' DP = ',I5) 99991 FORMAT (/' NP is out of range.',/' NP = ',I5) 99990 FORMAT (/' MP is out of range.',/' MP = ',I5) END slicot-5.0+20101122/examples77/TMD03AD.f000077500000000000000000000151261201767322700167150ustar00rootroot00000000000000* MD03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDWORK PARAMETER ( LDWORK = MMAX + 2*NMAX + MMAX*NMAX + $ NMAX*NMAX + 3*NMAX + MMAX ) * .. The lengths of DPAR1, DPAR2, IPAR are set to 1, 1, and 5 .. INTEGER LDPAR1, LDPAR2, LIPAR PARAMETER ( LDPAR1 = 1, LDPAR2 = 1, LIPAR = 5 ) * .. Local Scalars .. CHARACTER*1 ALG, STOR, UPLO, XINIT INTEGER I, INFO, ITMAX, IWARN, M, N, NFEV, NJEV, NPRINT DOUBLE PRECISION CGTOL, TOL * .. Array Arguments .. INTEGER IPAR(LIPAR) DOUBLE PRECISION DPAR1(LDPAR1), DPAR2(LDPAR2), DWORK(LDWORK), $ X(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MD03AD, MD03AF, NF01BV, NF01BX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, ITMAX, NPRINT, TOL, CGTOL, XINIT, $ ALG, STOR, UPLO IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE IF ( LSAME( XINIT, 'G' ) ) $ READ ( NIN, FMT = * ) ( X(I), I = 1,N ) * Solve a standard nonlinear least squares problem. IPAR(1) = M IF ( LSAME( ALG, 'D' ) ) THEN CALL MD03AD( XINIT, ALG, STOR, UPLO, MD03AF, NF01BV, M, $ N, ITMAX, NPRINT, IPAR, LIPAR, DPAR1, $ LDPAR1, DPAR2, LDPAR2, X, NFEV, NJEV, TOL, $ CGTOL, DWORK, LDWORK, IWARN, INFO ) ELSE CALL MD03AD( XINIT, ALG, STOR, UPLO, MD03AF, NF01BX, M, $ N, ITMAX, NPRINT, IPAR, LIPAR, DPAR1, $ LDPAR1, DPAR2, LDPAR2, X, NFEV, NJEV, TOL, $ CGTOL, DWORK, LDWORK, IWARN, INFO ) END IF * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0 ) WRITE ( NOUT, FMT = 99991 ) IWARN WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) NFEV, NJEV WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, N ) END IF END IF END IF STOP * 99999 FORMAT (' MD03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MD03AD = ',I2) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' The number of function and Jacobian evaluations = ', $ 2I7) 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (' IWARN on exit from MD03AD = ',I2) END C SUBROUTINE MD03AF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEVL, E, J, LDJ, JTE, DWORK, $ LDWORK, INFO ) C C This is the FCN routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03AD. See the C argument FCN in the routine MD03AD 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 ZERO, ONE PARAMETER ( ZERO = 0.0D0, 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,*), $ JTE(*), X(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION ERR, TMP1, TMP2, TMP3, TMP4 C .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 C .. External Subroutines .. EXTERNAL DGEMV 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, e. 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 C Compute the product J'*e (the error e was computed in array E). C CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, E, 1, ZERO, JTE, $ 1 ) 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 MD03AF (IFLAG = 1 or 2), NF01BV and C NF01BX. C LDJ = M IPAR(1) = M*N IPAR(2) = 0 IPAR(3) = 0 IPAR(4) = M ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( M, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR C END IF C DWORK(1) = ZERO RETURN C C *** Last line of MD03AF *** END slicot-5.0+20101122/examples77/TMD03BD.f000077500000000000000000000207201201767322700167120ustar00rootroot00000000000000* MD03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDWORK PARAMETER ( LDWORK = MMAX + $ MMAX*NMAX + 5*NMAX + 1 + $ NMAX*NMAX + NMAX + $ MMAX + 5*NMAX ) * .. Local Scalars .. CHARACTER*1 COND, SCALE, XINIT INTEGER I, INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LIPAR, M, $ N, NFEV, NJEV, NPRINT DOUBLE PRECISION FACTOR, FTOL, GTOL, TOL, XTOL * .. Array Arguments .. INTEGER IPAR(5), IWORK(NMAX+1) DOUBLE PRECISION DIAG(NMAX), DPAR1(1), DPAR2(1), DWORK(LDWORK), $ X(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL MD03BA, MD03BB, MD03BD, MD03BF * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, ITMAX, LIPAR, LDPAR1, LDPAR2, FACTOR, $ NPRINT, FTOL, XTOL, GTOL, TOL, XINIT, SCALE, $ COND IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE IF ( LSAME( SCALE, 'S' ) ) $ READ ( NIN, FMT = * ) ( DIAG(I), I = 1,N ) IF ( LSAME( XINIT, 'G' ) ) $ READ ( NIN, FMT = * ) ( X(I), I = 1,N ) * Solve a standard nonlinear least squares problem. IPAR(1) = M CALL MD03BD( XINIT, SCALE, COND, MD03BF, MD03BA, MD03BB, $ M, N, ITMAX, FACTOR, NPRINT, IPAR, LIPAR, $ DPAR1, LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV, $ NJEV, FTOL, XTOL, GTOL, TOL, IWORK, DWORK, $ LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99991 ) IWARN WRITE ( NOUT, FMT = 99997 ) DWORK(2) WRITE ( NOUT, FMT = 99996 ) NFEV, NJEV WRITE ( NOUT, FMT = 99994 ) WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, N ) END IF END IF END IF STOP * 99999 FORMAT (' MD03BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from MD03BD = ',I2) 99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7) 99996 FORMAT (/' The number of function and Jacobian evaluations = ', $ 2I7) 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' Final approximate solution is ' ) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (' IWARN on exit from MD03BD = ',I2) END C SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK, $ INFO ) C C This is the FCN routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03BD. See the C argument 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 .. External Subroutines .. EXTERNAL MD03BA, MD03BB 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 MD03BF (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 ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( M, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR C END IF C RETURN C C *** Last line of MD03BF *** END C SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, $ GNORM, IPVT, DWORK, LDWORK, INFO ) C C This is the QRFACT routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03BD. See the C argument QRFACT in the routine MD03BD for the description of C parameters. C C For efficiency, the arguments are not checked. This is done in C the routine MD03BX (except for LIPAR). 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(LDJ,*), 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 C SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, $ INFO ) C C This is the LMPARM routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03BD. See the C argument LMPARM in the routine MD03BD for the description of C parameters. C C For efficiency, the arguments are not checked. This is done in C the routine MD03BY (except for LIPAR). 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 slicot-5.0+20101122/examples77/TSB01BD.f000077500000000000000000000105721201767322700167200ustar00rootroot00000000000000* SB01BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDF, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDF = MMAX, $ LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 5*MMAX+5*NMAX+2*NMAX+4*MMAX ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, ANORM, NRM, TOL INTEGER I, INFO, IWARN, J, M, N, NAP, NFP, NP, NUP CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), AIN(LDA,NMAX), B(LDB,MMAX), $ DWORK(LDWORK), F(LDF,NMAX), WI(NMAX), WR(NMAX), $ Z(LDZ,NMAX), ZTA(LDZ,NMAX) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, MB03QX, SB01BD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, ALPHA, TOL, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF( NP.LT.0 .OR. NP.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NP ELSE DO 10 I = 1, NP READ ( NIN, FMT = * ) WR(I), WI(I) 10 CONTINUE * Perform "eigenvalue assignment" to compute F. CALL DLACPY( 'G', N, N, A, LDA, AIN, LDA ) CALL SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, $ WR, WI, NFP, NAP, NUP, F, LDF, Z, LDZ, $ TOL, DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 .AND. INFO.LT.3 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE IF ( INFO .NE. 0 ) WRITE ( NOUT, FMT = 99997 ) INFO IF ( IWARN .NE. 0 ) WRITE ( NOUT, FMT = 99991 ) IWARN WRITE ( NOUT, FMT = 99990 ) NAP WRITE ( NOUT, FMT = 99989 ) NFP WRITE ( NOUT, FMT = 99988 ) NUP WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,N ) 60 CONTINUE CALL MB03QX( N, A, LDA, WR, WI, INFO ) WRITE ( NOUT, FMT = 99998 ) ( WR(I), WI(I), I = 1,N ) * Compute NORM (Z*Aout*Z'-(A+B*F)) / (eps*NORM(A)) ANORM = DLANGE( 'F', N, N, AIN, LDA, DWORK ) CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, F, LDF, $ ONE, AIN, LDA ) CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, A, LDA, $ ZERO, ZTA, LDZ ) CALL DGEMM( 'N', 'T', N, N, N, ONE, ZTA, LDZ, Z, LDZ, $ -ONE, AIN, LDA ) NRM = DLANGE( 'F', N, N, AIN, LDA, DWORK ) / $ ( DLAMCH( 'E' )*ANORM ) WRITE ( NOUT, FMT = 99987 ) NRM END IF END IF END IF END IF STOP * 99999 FORMAT (' SB01BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/,' The eigenvalues of closed-loop matrix A+B*F',/ $ ( ' ( ',F8.4,',',F8.4,' )' ) ) 99997 FORMAT (' INFO on exit from SB01BD = ',I2) 99996 FORMAT (/,' The state feedback matrix F is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' NP is out of range.',/' NP = ',I5) 99991 FORMAT (/' IWARN on exit from SB01BD = ', I2) 99990 FORMAT ( ' Number of assigned eigenvalues: NAP = ', I2 ) 99989 FORMAT ( ' Number of fixed eigenvalues: NFP = ', I2) 99988 FORMAT ( ' Number of uncontrollable poles: NUP = ', I2) 99987 FORMAT (/,' NORM(A+B*F - Z*Aout*Z'') / (eps*NORM(A)) =',1PD12.5) END slicot-5.0+20101122/examples77/TSB01DD.f000077500000000000000000000056721201767322700167270ustar00rootroot00000000000000* SB01DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDG, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDG = MMAX, $ LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 3*NMAX + MMAX*NMAX + $ MMAX*MMAX + 2*NMAX + 4*MMAX + 1 ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER COUNT, I, INDCON, INFO1, INFO2, J, M, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. INTEGER IWORK(MMAX), NBLK(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(NMAX,MMAX), DWORK(LDWORK), $ G(LDG,NMAX), WI(NMAX), WR(NMAX), Y(MMAX*NMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL AB01ND, SB01DD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, JOBZ IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( WR(I), I = 1,N ) READ ( NIN, FMT = * ) ( WI(I), I = 1,N ) READ ( NIN, FMT = * ) ( Y(I), I = 1,M*N ) * First reduce the given system to canonical form. CALL AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, $ NBLK, Z, LDZ, DWORK, TOL, IWORK, DWORK(N+1), $ LDWORK-N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN * Find the state feedback matrix G. CALL SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI, $ Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK, $ LDWORK, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,N ) 10 CONTINUE END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF END IF STOP * 99999 FORMAT (' SB01DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01ND =',I2) 99997 FORMAT (' INFO on exit from SB01DD =',I2) 99996 FORMAT (' The state feedback matrix G is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TSB01MD.f000077500000000000000000000042631201767322700167330ustar00rootroot00000000000000* SB01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDZ PARAMETER ( LDA = NMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO1, INFO2, J, N, NCONT CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), G(NMAX), $ WI(NMAX), WR(NMAX), Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL AB01MD, SB01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, TOL, JOBZ IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( B(I), I = 1,N ) READ ( NIN, FMT = * ) ( WR(I), I = 1,N ) READ ( NIN, FMT = * ) ( WI(I), I = 1,N ) * First reduce the given system to canonical form. CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, DWORK, TOL, $ DWORK(N+1), LDWORK-N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN * Find the one-dimensional state feedback matrix G. CALL SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK, $ INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99996 ) ( G(I), I = 1,NCONT ) END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01MD =',I2) 99997 FORMAT (' INFO on exit from SB01MD =',I2) 99996 FORMAT (' The one-dimensional state feedback matrix G is', $ /20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TSB02MD.f000077500000000000000000000044041201767322700167310ustar00rootroot00000000000000* SB02MD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDS, LDU PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, $ LDS = 2*NMAX, LDU = 2*NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 6*NMAX ) * .. Local Scalars .. DOUBLE PRECISION RCOND INTEGER I, INFO, J, N CHARACTER DICO, HINV, SCAL, SORT, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), S(LDS,2*NMAX), U(LDU,2*NMAX), $ WI(2*NMAX), WR(2*NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB02MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DICO, HINV, UPLO, SCAL, SORT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RCOND DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( Q(I,J), J = 1,N ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' SB02MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02MD = ',I2) 99997 FORMAT (' RCOND = ',F4.2,//' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TSB02ND.f000077500000000000000000000105751201767322700167400ustar00rootroot00000000000000* SB02ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER NMAX2 PARAMETER ( NMAX2 = 2*NMAX ) INTEGER LDA, LDB, LDC, LDL, LDR, LDS, LDT, LDU, LDX, LDF PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDL = NMAX, $ LDR = (MMAX+PMAX), LDS = NMAX2+MMAX, $ LDT = NMAX2+MMAX, LDU = NMAX2, LDX = NMAX, $ LDF = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( NMAX2+MMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX+3*MMAX+2 + 14*NMAX+23 + $ 16*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL, RCOND, RNORM INTEGER I, INFO1, INFO2, J, M, N, P CHARACTER*1 DICO, FACT, JOBB, JOBL, SORT, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFAI(2*NMAX), ALFAR(2*NMAX), $ B(LDB,MMAX), BETA(2*NMAX), C(LDC,NMAX), $ DWORK(LDWORK), F(LDF,NMAX), L(LDL,MMAX), $ R(LDR,MMAX), S(LDS,NMAX2+MMAX), T(LDT,NMAX2), $ U(LDU,NMAX2), X(LDX,NMAX) INTEGER IPIV(LIWORK), IWORK(LIWORK), OUFACT(2) LOGICAL BWORK(NMAX2) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02ND, SB02OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, FACT, JOBL, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( FACT, 'D' ) ) THEN READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,P ) ELSE READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,M ) END IF * Find the solution matrix X. JOBB = 'B' SORT = 'S' CALL SB02OD( DICO, JOBB, 'Both', UPLO, JOBL, SORT, N, M, $ P, A, LDA, B, LDB, C, LDC, R, LDR, L, LDL, $ RCOND, X, LDX, ALFAR, ALFAI, BETA, S, LDS, $ T, LDT, U, LDU, TOL, IWORK, DWORK, LDWORK, $ BWORK, INFO1 ) * IF ( INFO1.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO1 ELSE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 20 CONTINUE * Compute the optimal feedback matrix F. CALL 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, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99994 ) ( F(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' SB02ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02OD = ',I2) 99997 FORMAT (' INFO on exit from SB02ND = ',I2) 99996 FORMAT (' The solution matrix X is ') 99995 FORMAT (/' The optimal feedback matrix F is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TSB02OD.f000077500000000000000000000106161201767322700167350ustar00rootroot00000000000000* SB02OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER NMAX2M, NMAX2 PARAMETER ( NMAX2M = 2*NMAX+MMAX, NMAX2 = 2*NMAX ) INTEGER LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDL = NMAX, $ LDQ = (NMAX+PMAX), LDR = (MMAX+PMAX), $ LDS = NMAX2M, LDT = NMAX2M, LDU = NMAX2, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = (MMAX+NMAX2) ) INTEGER LDWORK PARAMETER ( LDWORK = (14*NMAX+23+16*NMAX) ) INTEGER LBWORK PARAMETER ( LBWORK = NMAX2 ) * .. Local Scalars .. DOUBLE PRECISION RCOND, TOL INTEGER I, INFO, J, M, N, P CHARACTER*1 DICO, FACT, JOBB, JOBL, SORT, UPLO LOGICAL LJOBB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFAI(NMAX2), ALFAR(NMAX2), $ B(LDB,MMAX), BETA(NMAX2), DWORK(LDWORK), $ L(LDL,MMAX), Q(LDQ,NMAX), R(LDR,MMAX), $ S(LDS,NMAX2M), T(LDT,NMAX2), U(LDU,NMAX2), $ X(LDX,NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LBWORK) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBB, FACT, UPLO, JOBL, $ SORT IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE LJOBB = LSAME( JOBB, 'B' ) IF ( LJOBB ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) END IF IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99993 ) P ELSE IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'D' ) ) THEN READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,N ) ELSE READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,P ) END IF IF ( LJOBB ) THEN IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'C' ) ) THEN READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,M ) ELSE READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,P ) END IF IF ( LSAME( JOBL, 'N' ) ) $ READ ( NIN, FMT = * ) $ ( ( L(I,J), J = 1,M ), I = 1,N ) END IF * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB02OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02OD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TSB02PD.f000077500000000000000000000052161201767322700167360ustar00rootroot00000000000000* SB02PD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*NMAX + NMAX*NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = ( 4*NMAX*NMAX + 8*NMAX + $ 6*NMAX*NMAX ) + 1 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND INTEGER I, INFO, J, N CHARACTER JOB, TRANA, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), WI(NMAX), WR(NMAX), $ X(LDX,NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, TRANA, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X, $ LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO END IF IF ( INFO.EQ.0 .OR. INFO.EQ.2 .OR. INFO.EQ.4 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE IF ( LSAME( JOB, 'A' ) .AND. INFO.NE.4 ) THEN WRITE ( NOUT, FMT = 99994 ) RCOND WRITE ( NOUT, FMT = 99993 ) FERR END IF END IF END IF STOP * 99999 FORMAT (' SB02PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02PD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99993 FORMAT (/' Estimated error bound = ',F20.16) END slicot-5.0+20101122/examples77/TSB02QD.f000077500000000000000000000123651201767322700167420ustar00rootroot00000000000000* SB02QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 8*NMAX*NMAX + 10*NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCND, RCOND, SEP INTEGER I, INFO1, INFO2, INFO3, IS, IU, IW, J, N, N2, $ SDIM CHARACTER*1 FACT, JOB, JOBS, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), T(LDT,NMAX), U(LDU,NMAX), $ X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT * .. External Subroutines .. EXTERNAL DGEES, DLACPY, DSYMM, MA02ED, MB01RU, SB02MD, $ SB02QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( UPLO, N, N, Q, LDQ, X, LDX ) N2 = 2*N IS = 2*N2 + 1 IU = IS + N2*N2 IW = IU + N2*N2 * Solve the continuous-time Riccati equation. CALL SB02MD( 'continuous', 'direct', UPLO, 'no scaling', $ 'stable', N, A, LDA, G, LDG, X, LDX, RCND, $ DWORK(1), DWORK(N2+1), DWORK(IS), N2, DWORK(IU), $ N2, IWORK, DWORK(IW), LDWORK-IW+1, BWORK, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99995 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( FACT, 'F' ) .OR. LSAME( LYAPUN, 'R' ) ) THEN CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) IF ( LSAME( TRANA, 'N' ) ) THEN * Compute Ac = A-G*X. CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, $ ONE, T, LDT ) ELSE * Compute Ac = A-X*G. CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, $ ONE, T, LDT ) END IF * Compute the Schur factorization of Ac. JOBS = 'V' CALL DGEES( JOBS, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK(1), DWORK(N+1), U, LDU, DWORK(2*N+1), $ LDWORK-2*N, BWORK, INFO3 ) IF( INFO3.NE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) INFO3 STOP END IF END IF * IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF * CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, $ U, LDU, G, LDG, DWORK, N*N, INFO2 ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, $ U, LDU, Q, LDQ, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL 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, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 END IF IF ( INFO2.EQ.0 .OR. INFO2.EQ.N+1 ) THEN WRITE ( NOUT, FMT = 99992 ) SEP WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB02QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02MD =',I2) 99997 FORMAT (' INFO on exit from SB02QD =',I2) 99996 FORMAT (' INFO on exit from DGEES =',I2) 99995 FORMAT (' The solution matrix X is') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB02RD.f000077500000000000000000000072311201767322700167370ustar00rootroot00000000000000* SB02RD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDS, LDT, LDV, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, $ LDS = 2*NMAX, LDT = NMAX, LDV = NMAX, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*NMAX + NMAX*NMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 5 + 4*NMAX*NMAX + 8*NMAX ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SEP INTEGER I, INFO, J, N CHARACTER DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, TRANA, $ UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX), $ Q(LDQ,NMAX), S(LDS,2*NMAX), T(LDT,NMAX), $ V(LDV,NMAX), WI(2*NMAX), WR(2*NMAX), X(LDX,NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB02RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, $ FACT, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) .OR. $ LSAME( FACT, 'N' ) .OR. LSAME( LYAPUN, 'O' ) ) $ READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( .NOT.LSAME( JOB, 'X' ) .AND. LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N ) END IF READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO END IF IF ( INFO.EQ.0 .OR. INFO.EQ.7 ) THEN IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99994 ) SEP WRITE ( NOUT, FMT = 99993 ) RCOND END IF IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99992 ) FERR END IF END IF STOP * 99999 FORMAT (' SB02RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02RD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' Estimated separation = ',F8.4) 99993 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99992 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB02SD.f000077500000000000000000000131701201767322700167370ustar00rootroot00000000000000* SB02SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDG, LDQ, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDG = NMAX, LDQ = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 8*NMAX*NMAX + 10*NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCND, RCOND, SEPD INTEGER I, INFO1, INFO2, INFO3, IS, IU, IW, J, N, N2, $ SDIM CHARACTER*1 FACT, JOB, JOBS, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AS(LDA,NMAX), DWORK(LDWORK), $ G(LDG,NMAX), Q(LDQ,NMAX), T(LDT,NMAX), $ U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT * .. External Subroutines .. EXTERNAL DGEES, DGESV, DLACPY, DLASET, DSWAP, DSYMM, $ MA02AD, MA02ED, MB01RU, SB02MD, SB02SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'Full', N, N, A, LDA, AS, LDA ) CALL DLACPY( UPLO, N, N, Q, LDQ, X, LDX ) N2 = 2*N IS = 2*N2 + 1 IU = IS + N2*N2 IW = IU + N2*N2 * Solve the discrete-time Riccati equation. CALL SB02MD( 'discrete', 'direct', UPLO, 'no scaling', $ 'stable', N, AS, LDA, G, LDG, X, LDX, RCND, $ DWORK(1), DWORK(N2+1), DWORK(IS), N2, DWORK(IU), $ N2, IWORK, DWORK(IW), LDWORK-IW+1, BWORK, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99995 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( FACT, 'F' ) .OR. LSAME( LYAPUN, 'R' ) ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK, N ) CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, $ ONE, DWORK, N ) IF ( LSAME( TRANA, 'N' ) ) THEN * Compute Ac = inv(I_n + G*X)*A. CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 ) ELSE * Compute Ac = A*inv(I_n + X*G) CALL MA02AD( 'Full', N, N, A, LDA, T, LDT ) CALL DGESV( N, N, DWORK, N, IWORK, T, LDT, INFO3 ) DO 20 J = 2, N CALL DSWAP( J-1, T(1,J), 1, T(J,1), LDT ) 20 CONTINUE END IF * Compute the Schur factorization of Ac. JOBS = 'V' CALL DGEES( JOBS, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK(1), DWORK(N+1), U, LDU, DWORK(2*N+1), $ LDWORK-2*N, BWORK, INFO3 ) IF( INFO3.NE.0 ) THEN WRITE ( NOUT, FMT = 99996 ) INFO3 STOP END IF END IF * IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF * CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, $ U, LDU, G, LDG, DWORK, N*N, INFO2 ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, $ U, LDU, Q, LDQ, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL 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, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 END IF IF ( INFO2.EQ.0 .OR. INFO2.EQ.N+1 ) THEN WRITE ( NOUT, FMT = 99992 ) SEPD WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB02SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB02MD =',I2) 99997 FORMAT (' INFO on exit from SB02SD =',I2) 99996 FORMAT (' INFO on exit from DGEES =',I2) 99995 FORMAT (' The solution matrix X is') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB03MD.f000077500000000000000000000050651201767322700167360ustar00rootroot00000000000000* SB03MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDU PARAMETER ( LDA = NMAX, LDC = NMAX, LDU = NMAX ) INTEGER LDWORK, LIWORK PARAMETER ( LDWORK = 2*NMAX*NMAX + 3*NMAX, $ LIWORK = NMAX*NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N CHARACTER*1 DICO, FACT, JOB, TRANA DOUBLE PRECISION FERR, SCALE, SEP * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, DICO, FACT, JOB, TRANA IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X. CALL SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, $ SCALE, SEP, FERR, WR, WI, IWORK, DWORK, LDWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) SCALE IF ( .NOT.LSAME( JOB, 'X' ) ) $ WRITE ( NOUT, FMT = 99993 ) SEP IF ( LSAME( JOB, 'B' ) ) $ WRITE ( NOUT, FMT = 99992 ) FERR END IF END IF STOP * 99999 FORMAT (' SB03MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03MD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' Scaling factor = ',F8.4) 99993 FORMAT (/' Estimated separation = ',F8.4) 99992 FORMAT (/' Estimated forward error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB03OD.f000077500000000000000000000073271201767322700167430ustar00rootroot00000000000000* SB03OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDQ, LDX, LDWORK PARAMETER ( LDA = NMAX, LDB = ( MMAX+NMAX ), $ LDQ = NMAX, LDX = NMAX ) PARAMETER ( LDWORK = 4*NMAX+(MMAX+NMAX) ) * .. Local Scalars .. DOUBLE PRECISION SCALE, TEMP INTEGER I, INFO, J, K, M, N CHARACTER*1 DICO, FACT, TRANS * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,LDB), DWORK(LDWORK), $ Q(LDQ,NMAX), WR(NMAX), WI(NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE IF ( LSAME( TRANS, 'N' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) END IF * Find the Cholesky factor U. CALL SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 J = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), I = 1,J ) 20 CONTINUE * Form the solution matrix X = op(U)'*op(U). IF ( LSAME( TRANS, 'N' ) ) THEN DO 80 I = 1, N DO 60 J = I, N TEMP = ZERO DO 40 K = 1, I TEMP = TEMP + B(K,I)*B(K,J) 40 CONTINUE X(I,J) = TEMP X(J,I) = TEMP 60 CONTINUE 80 CONTINUE ELSE DO 140 I = 1, N DO 120 J = I, N TEMP = ZERO DO 100 K = J, N TEMP = TEMP + B(I,K)*B(J,K) 100 CONTINUE X(I,J) = TEMP X(J,I) = TEMP 120 CONTINUE 140 CONTINUE END IF WRITE ( NOUT, FMT = 99995 ) DO 160 J = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), I = 1,N ) 160 CONTINUE WRITE ( NOUT, FMT = 99992 ) SCALE END IF END IF END IF STOP * 99999 FORMAT (' SB03OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03OD = ',I2) 99997 FORMAT (' The transpose of the Cholesky factor U is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The solution matrix X = op(U)''*op(U) is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' Scaling factor = ',F8.4) END slicot-5.0+20101122/examples77/TSB03QD.f000077500000000000000000000077751201767322700167540ustar00rootroot00000000000000* SB03QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + 3*NMAX*NMAX + NMAX - 1 + $ 5*NMAX ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEP INTEGER I, INFO1, INFO2, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLACPY, MA02ED, MB01RU, SB03MD, SB03QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'C' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DLACPY( 'Full', N, N, C, LDC, X, LDX ) * Solve the continuous-time Lyapunov matrix equation. CALL SB03MD( DICO, 'X', FACT, TRANA, N, T, LDT, U, LDU, X, LDX, $ SCALE, SEP, FERR, DWORK(1), DWORK(N+1), IWORK, $ DWORK(2*N+1), LDWORK-2*N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, C, LDC, $ U, LDU, C, LDC, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL SB03QD( JOB, 'F', TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99993 ) SCALE WRITE ( NOUT, FMT = 99992 ) SEP WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB03QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03MD =',I2) 99997 FORMAT (' INFO on exit from SB03QD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB03SD.f000077500000000000000000000077741201767322700167550ustar00rootroot00000000000000* SB03SD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 3 + 2*NMAX*NMAX ) + $ NMAX*NMAX + 2*NMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEPD INTEGER I, INFO1, INFO2, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, TRANAT, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL DLACPY, MA02ED, MB01RU, SB03MD, SB03SD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'D' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * ) $ ( ( U(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DLACPY( 'Full', N, N, C, LDC, X, LDX ) * Solve the discrete-time Lyapunov matrix equation. CALL SB03MD( DICO, 'X', FACT, TRANA, N, T, LDT, U, LDU, X, LDX, $ SCALE, SEPD, FERR, DWORK(1), DWORK(N+1), IWORK, $ DWORK(2*N+1), LDWORK-2*N, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE IF ( LSAME( LYAPUN, 'R' ) ) THEN IF( LSAME( TRANA, 'N' ) ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, N*N, INFO2 ) CALL MA02ED( UPLO, N, X, LDX ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, C, LDC, $ U, LDU, C, LDC, DWORK, N*N, INFO2 ) END IF * Estimate the condition and error bound on the solution. CALL SB03SD( JOB, 'F', TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 ) * IF ( INFO2.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO2 ELSE WRITE ( NOUT, FMT = 99993 ) SCALE WRITE ( NOUT, FMT = 99992 ) SEPD WRITE ( NOUT, FMT = 99991 ) RCOND WRITE ( NOUT, FMT = 99990 ) FERR END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB03SD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03MD =',I2) 99997 FORMAT (' INFO on exit from SB03SD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB03TD.f000077500000000000000000000073571201767322700167530ustar00rootroot00000000000000* SB03TD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + 3*NMAX*NMAX + NMAX - 1 ) ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEP INTEGER I, INFO, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'C' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) SCALE IF ( LSAME( FACT, 'N' ) .OR. ( LSAME( LYAPUN, 'O' ) .AND. $ .NOT.LSAME( JOB, 'X') ) ) $ READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( LYAPUN, 'O' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) END IF IF ( .NOT.LSAME( JOB, 'S' ) ) $ READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Solve the continuous-time Lyapunov matrix equation and/or * estimate the condition and error bound on the solution. CALL SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, LDA, $ T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, FERR, $ DWORK(1), DWORK(N+1), IWORK, DWORK(2*N+1), $ LDWORK-2*N, INFO ) * IF ( INFO.EQ.0 ) THEN IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99993 ) SCALE END IF IF ( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'C' ) $ .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99992 ) SEP IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99991 ) RCOND IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99990 ) FERR ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB03TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03TD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB03UD.f000077500000000000000000000074361201767322700167520ustar00rootroot00000000000000* SB03UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDC, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDC = NMAX, LDT = NMAX, $ LDU = NMAX, LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 3 + 2*NMAX*NMAX ) + $ NMAX*NMAX + 2*NMAX ) * .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, SCALE, SEPD INTEGER I, INFO, J, N CHARACTER*1 DICO, FACT, JOB, LYAPUN, TRANA, UPLO * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK), $ T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB03UD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) DICO = 'D' * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) SCALE IF ( LSAME( FACT, 'N' ) .OR. ( LSAME( LYAPUN, 'O' ) .AND. $ .NOT.LSAME( JOB, 'X') ) ) $ READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( LYAPUN, 'O' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) END IF IF ( .NOT.LSAME( JOB, 'S' ) ) $ READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Solve the discrete-time Lyapunov matrix equation and/or * estimate the condition and error bound on the solution. CALL SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, LDA, $ T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, FERR, $ DWORK(1), DWORK(N+1), IWORK, DWORK(2*N+1), $ LDWORK-2*N, INFO ) * IF ( INFO.EQ.0 ) THEN IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99993 ) SCALE END IF IF ( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'C' ) $ .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99992 ) SEPD IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99991 ) RCOND IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) ) $ WRITE ( NOUT, FMT = 99990 ) FERR ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB03UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB03UD =',I2) 99996 FORMAT (' The solution matrix X is') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' Scaling factor = ',F8.4) 99992 FORMAT (/' Estimated separation = ',F8.4) 99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4) 99990 FORMAT (/' Estimated error bound = ',F8.4) END slicot-5.0+20101122/examples77/TSB04MD.f000077500000000000000000000046511201767322700167370ustar00rootroot00000000000000* SB04MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC, LDZ PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX, $ LDZ = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 4*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + 2*NMAX*NMAX+8*NMAX + 5*MMAX + $ NMAX+MMAX ) ) * .. Local Scalars .. INTEGER I, INFO, J, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK), Z(LDZ,MMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( Z(I,J), J = 1,M ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04MD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The orthogonal matrix Z is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TSB04ND.f000077500000000000000000000044341201767322700167370ustar00rootroot00000000000000* SB04ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*( ( NMAX + MMAX ) )* $ ( 4+2*( ( NMAX + MMAX ) ) ) ) INTEGER LIWORK PARAMETER ( LIWORK = 2*( NMAX + MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N CHARACTER*1 ABSCHU, ULA, ULB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, ULA, ULB, ABSCHU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04ND = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TSB04OD.f000077500000000000000000000107671201767322700167460ustar00rootroot00000000000000* SB04OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 10, NMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, LDU, LDV PARAMETER ( LDA = MMAX, LDB = NMAX, LDC = MMAX, LDD = MMAX, $ LDE = NMAX, LDF = MMAX, LDP = MMAX, LDQ = MMAX, $ LDU = NMAX, LDV = NMAX ) INTEGER LDWORK, LIWORK PARAMETER ( LDWORK = (7*(MMAX+NMAX)+2*MMAX*NMAX), $ LIWORK = MMAX+NMAX+6 ) * .. Local Scalars .. DOUBLE PRECISION DIF, SCALE INTEGER I, INFO, J, M, N CHARACTER*1 JOBD, REDUCE, TRANS * .. Local Arrays .. DOUBLE PRECISION A(LDA,MMAX), B(LDB,NMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), E(LDE,NMAX), $ F(LDF,NMAX), P(LDP,MMAX), Q(LDQ,MMAX), $ U(LDU,NMAX), V(LDV,NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB04OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, REDUCE, TRANS, JOBD IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,M ), I = 1,M ) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M ) * Find the solution matrices L and R. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( F(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( C(I,J), J = 1,N ) 40 CONTINUE IF ( LSAME( REDUCE, 'R' ).OR.LSAME( REDUCE, 'A' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( P(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, M WRITE ( NOUT, FMT = 99991 ) ( Q(I,J), J = 1,M ) 80 CONTINUE END IF IF ( LSAME( REDUCE, 'R' ).OR.LSAME( REDUCE, 'B' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99991 ) ( U(I,J), J = 1,N ) 100 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 120 I = 1, N WRITE ( NOUT, FMT = 99991 ) ( V(I,J), J = 1,N ) 120 CONTINUE END IF IF ( SCALE.NE.ONE ) WRITE ( NOUT, FMT = 99987 ) SCALE IF ( .NOT.LSAME( JOBD, 'N' ) ) $ WRITE ( NOUT, FMT = 99990 ) DIF END IF END IF END IF * STOP * 99999 FORMAT (' SB04OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04OD = ',I2) 99997 FORMAT (' The solution matrix L is ') 99996 FORMAT (/' The solution matrix R is ') 99995 FORMAT (/' The left transformation matrix P is ') 99994 FORMAT (/' The right transformation matrix Q is ') 99993 FORMAT (/' The left transformation matrix U is ') 99992 FORMAT (/' The right transformation matrix V is ') 99991 FORMAT (20(1X,F8.4)) 99990 FORMAT (/' DIF = ',F8.4) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' SCALE = ',F8.4) END slicot-5.0+20101122/examples77/TSB04PD.f000077500000000000000000000065351201767322700167450ustar00rootroot00000000000000* SB04PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA, LDB, LDC, LDU, LDV PARAMETER ( LDA = MMAX, LDB = NMAX, LDC = MMAX, $ LDU = MMAX, LDV = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 1 + 2*MMAX + ( 3*MMAX + 5*NMAX + $ 2*( NMAX + MMAX ) ) ) * .. Local Scalars .. CHARACTER DICO, FACTA, FACTB, TRANA, TRANB INTEGER I, INFO, ISGN, J, M, N DOUBLE PRECISION SCALE * .. Local Arrays .. DOUBLE PRECISION A(LDA,MMAX), B(LDB,NMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,MMAX), V(LDV,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB04PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, ISGN, DICO, FACTA, FACTB, TRANA, TRANB IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,M ), I = 1,M ) IF ( LSAME( FACTA, 'F' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,M ) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACTB, 'F' ) ) $ READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M ) * Find the solution matrix X. CALL SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N, $ A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO IF ( INFO.EQ.0 .OR. INFO.EQ.M+N+1 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) SCALE IF ( LSAME( FACTA, 'N' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,M ) 40 CONTINUE END IF IF ( LSAME( FACTB, 'N' ) ) THEN WRITE ( NOUT, FMT = 99993 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( V(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB04PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04PD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' Scaling factor = ',F8.4) 99994 FORMAT (/' The orthogonal matrix U is ') 99993 FORMAT (/' The orthogonal matrix V is ') 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TSB04QD.f000077500000000000000000000046511201767322700167430ustar00rootroot00000000000000* SB04QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC, LDZ PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX, $ LDZ = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 4*NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + 2*NMAX*NMAX+9*NMAX + 5*MMAX + $ NMAX+MMAX ) ) * .. Local Scalars .. INTEGER I, INFO, J, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK), Z(LDZ,MMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99996 ) ( Z(I,J), J = 1,M ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04QD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The orthogonal matrix Z is ') 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TSB04RD.f000077500000000000000000000044341201767322700167430ustar00rootroot00000000000000* SB04RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = MMAX, LDC = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*( ( NMAX + MMAX ) )* $ ( 4+2*( ( NMAX + MMAX ) ) ) ) INTEGER LIWORK PARAMETER ( LIWORK = 2*( NMAX + MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N CHARACTER*1 ABSCHU, ULA, ULB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,MMAX), $ DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB04RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, ULA, ULB, ABSCHU IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,M ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,M ), I = 1,N ) * Find the solution matrix X. CALL SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,M ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SB04RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB04RD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TSB06ND.f000077500000000000000000000061471201767322700167440ustar00rootroot00000000000000* SB06ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDU, LDV, LDF PARAMETER ( LDA = NMAX, LDB = NMAX, LDU = NMAX, $ LDV = MMAX, LDF = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX + (NMAX + 3*MMAX) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, KMAX, M, N, NCONT CHARACTER*1 JOBU, JOBV * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK), $ F(LDF,NMAX), U(LDU,NMAX), V(LDV,MMAX) INTEGER IWORK(LIWORK), KSTAIR(NMAX) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL AB01OD, DLASET, SB06ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, TOL, JOBU, JOBV IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) * First put (A,B) into staircase form with triangular pivots * and determine the stairsizes. CALL AB01OD( 'A', JOBU, JOBV, N, M, A, LDA, B, LDB, U, $ LDU, V, LDV, NCONT, KMAX, KSTAIR, TOL, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.EQ.0 ) THEN IF( LSAME( JOBU, 'N' ) ) THEN * Initialize U as the identity matrix. CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) END IF * Perform "deadbeat control" to give F. CALL SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, $ F, LDF, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99996 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,N ) 60 CONTINUE END IF ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF END IF STOP * 99999 FORMAT (' SB06ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from AB01OD = ',I2) 99997 FORMAT (' INFO on exit from SB06ND = ',I2) 99996 FORMAT (' The deadbeat feedback matrix F is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TSB08CD.f000077500000000000000000000110561201767322700167260ustar00rootroot00000000000000* SB08CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MPMAX PARAMETER ( MPMAX = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDBR, LDC, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDBR = NMAX, $ LDC = MPMAX, LDD = MPMAX, LDDR = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*PMAX + ( NMAX*( NMAX + 5 ) + $ PMAX*( PMAX + 2 ) + 4*PMAX + 4*MMAX )) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MPMAX), BR(LDBR,PMAX), $ C(LDC,NMAX), D(LDD,MPMAX), DR(LDDR,PMAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08CD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a RCFID for (A,B,C,D). CALL SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, $ D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = 1, NR WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = 1, NR ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( BR(I,J), J = 1, P ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99995 ) $ ( C(I,J), J = 1, NR ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, P ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08CD = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples77/TSB08DD.f000077500000000000000000000110151201767322700167220ustar00rootroot00000000000000* SB08DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDCR, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDCR = MMAX, LDD = PMAX, LDDR = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*( NMAX + 5 ) + $ MMAX*( MMAX + 2 ) + $ 4*NMAX + 4*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ CR(LDCR,NMAX), D(LDD,MMAX), DR(LDDR,MMAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08DD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a RCFID for (A,B,C,D). CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, $ D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL, $ DWORK, LDWORK, IWARN, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = NQ-NR+1, NQ ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, M WRITE ( NOUT, FMT = 99995 ) $ ( CR(I,J), J = NQ-NR+1, NQ ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, M ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08DD = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples77/TSB08ED.f000077500000000000000000000111321201767322700167230ustar00rootroot00000000000000* SB08ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MPMAX PARAMETER ( MPMAX = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDBR, LDC, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MPMAX, $ LDD = MPMAX, LDBR = NMAX, LDDR = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*PMAX + ( NMAX*( NMAX + 5 ) + $ 5*PMAX + 4*MMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHA(2), B(LDB,MPMAX), $ BR(LDBR,PMAX), C(LDC,NMAX), D(LDD,MPMAX), $ DR(LDDR,PMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08ED * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA(1), TOL, DICO ALPHA(2) = ALPHA(1) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a LCF for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = 1, NR WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = 1, NR ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( BR(I,J), J = 1, P ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99995 ) $ ( C(I,J), J = 1, NR ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, P ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08ED = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples77/TSB08FD.f000077500000000000000000000110061201767322700167240ustar00rootroot00000000000000* SB08FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDCR, LDD, LDDR PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDCR = MMAX, LDD = PMAX, LDDR = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX*( NMAX + 5 ) + 5*MMAX + $ 4*PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, IWARN, J, M, N, NQ, NR, P CHARACTER*1 DICO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHA(2), B(LDB,MMAX), C(LDC,NMAX), $ CR(LDCR,NMAX), D(LDD,MMAX), DR(LDDR,MMAX), $ DWORK(LDWORK) * .. External Subroutines .. EXTERNAL SB08FD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA(1), TOL, DICO ALPHA(2) = ALPHA(1) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P ) * Find a RCF for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ ) 20 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 40 CONTINUE IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M ) 70 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 ) DO 80 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) $ ( A(I,J), J = NQ-NR+1, NQ ) 80 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 ) DO 90 I = NQ-NR+1, NQ WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M ) 90 CONTINUE IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 ) DO 100 I = 1, M WRITE ( NOUT, FMT = 99995 ) $ ( CR(I,J), J = NQ-NR+1, NQ ) 100 CONTINUE WRITE ( NOUT, FMT = 99983 ) DO 110 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, M ) 110 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB08FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08FD = ',I2) 99996 FORMAT (/' The numerator state dynamics matrix AQ is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The numerator input/state matrix BQ is ') 99992 FORMAT (/' The numerator state/output matrix CQ is ') 99991 FORMAT (/' The numerator input/output matrix DQ is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99986 FORMAT (/' The denominator state dynamics matrix AR is ') 99985 FORMAT (/' The denominator input/state matrix BR is ') 99984 FORMAT (/' The denominator state/output matrix CR is ') 99983 FORMAT (/' The denominator input/output matrix DR is ') END slicot-5.0+20101122/examples77/TSB08MD.f000077500000000000000000000042211201767322700167340ustar00rootroot00000000000000* SB08MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DAMAX PARAMETER ( DAMAX = 10 ) INTEGER LDWORK PARAMETER ( LDWORK = 5*DAMAX+5 ) * .. Local Scalars .. DOUBLE PRECISION RES INTEGER DA, I, INFO CHARACTER*1 ACONA * .. Local Arrays .. DOUBLE PRECISION A(DAMAX+1), DWORK(LDWORK), E(DAMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB08MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) READ ( NIN, FMT = '()' ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = * ) DA, ACONA IF ( DA.LE.-1 .OR. DA.GT.DAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DA ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 ) * Compute the spectral factorization of the given polynomial. CALL SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( ACONA, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 0, DA WRITE ( NOUT, FMT = 99995 ) 2*I, A(I+1) 20 CONTINUE WRITE ( NOUT, FMT = * ) END IF WRITE ( NOUT, FMT = 99996 ) DO 40 I = 0, DA WRITE ( NOUT, FMT = 99995 ) I, E(I+1) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) RES END IF END IF * STOP * 99999 FORMAT (' SB08MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08MD = ',I2) 99997 FORMAT (' The coefficients of the polynomial B(s) are ',//' powe', $ 'r of s coefficient ') 99996 FORMAT (' The coefficients of the spectral factor E(s) are ', $ //' power of s coefficient ') 99995 FORMAT (2X,I5,9X,F9.4) 99994 FORMAT (/' RES = ',1P,E8.1) 99993 FORMAT (/' DA is out of range.',/' DA = ',I5) END slicot-5.0+20101122/examples77/TSB08ND.f000077500000000000000000000042171201767322700167420ustar00rootroot00000000000000* SB08ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER DAMAX PARAMETER ( DAMAX = 10 ) INTEGER LDWORK PARAMETER ( LDWORK = 5*DAMAX+5 ) * .. Local Scalars .. DOUBLE PRECISION RES INTEGER DA, I, INFO CHARACTER*1 ACONA * .. Local Arrays .. DOUBLE PRECISION A(DAMAX+1), DWORK(LDWORK), E(DAMAX+1) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SB08ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) READ ( NIN, FMT = '()' ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = * ) DA, ACONA IF ( DA.LE.-1 .OR. DA.GT.DAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DA ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 ) * Compute the spectral factorization of the given polynomial. CALL SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( ACONA, 'A' ) ) THEN WRITE ( NOUT, FMT = 99997 ) DO 20 I = 0, DA WRITE ( NOUT, FMT = 99995 ) I, A(I+1) 20 CONTINUE WRITE ( NOUT, FMT = * ) END IF WRITE ( NOUT, FMT = 99996 ) DO 40 I = 0, DA WRITE ( NOUT, FMT = 99995 ) I, E(I+1) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) RES END IF END IF * STOP * 99999 FORMAT (' SB08ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB08ND = ',I2) 99997 FORMAT (' The coefficients of the polynomial B(z) are ',//' powe', $ 'r of z coefficient ') 99996 FORMAT (' The coefficients of the spectral factor E(z) are ', $ //' power of z coefficient ') 99995 FORMAT (2X,I5,9X,F9.4) 99994 FORMAT (/' RES = ',1P,E8.1) 99993 FORMAT (/' DA is out of range.',/' DA = ',I5) END slicot-5.0+20101122/examples77/TSB09MD.f000077500000000000000000000051101201767322700167330ustar00rootroot00000000000000* SB09MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NCMAX, NBMAX PARAMETER ( NMAX = 20, NCMAX = 20, NBMAX = 20 ) INTEGER LDH1, LDH2, LDSS, LDSE, LDPRE PARAMETER ( LDH1 = NCMAX, LDH2 = NCMAX, LDSS = NCMAX, $ LDSE = NCMAX, LDPRE = NCMAX ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, N, NB, NC * .. Local Arrays .. DOUBLE PRECISION H1(LDH1,NMAX*NBMAX), H2(LDH2,NMAX*NBMAX), $ PRE(LDPRE,NBMAX), SE(LDSE,NBMAX), SS(LDSS,NBMAX) * .. External Subroutines .. EXTERNAL SB09MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NC, NB, TOL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE IF ( NB.LT.0 .OR. NB.GT.NBMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NB ELSE IF ( NC.LT.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NC ELSE READ ( NIN, FMT = * ) ( ( H1(I,J), I = 1,NC ), J = 1,N*NB ) READ ( NIN, FMT = * ) ( ( H2(I,J), I = 1,NC ), J = 1,N*NB ) * Compare the given sequences and evaluate their closeness. CALL SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, LDSE, $ PRE, LDPRE, TOL, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, NC WRITE ( NOUT, FMT = 99996 ) ( SS(I,J), J = 1,NB ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, NC WRITE ( NOUT, FMT = 99996 ) ( SE(I,J), J = 1,NB ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, NC WRITE ( NOUT, FMT = 99996 ) ( PRE(I,J), J = 1,NB ) 60 CONTINUE END IF END IF STOP * 99999 FORMAT (' SB09MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB09MD = ',I2) 99997 FORMAT (' The sum-of-squares matrix SS is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The quadratic error matrix SE is ') 99994 FORMAT (/' The percentage relative error matrix PRE is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' NB is out of range.',/' NB = ',I5) 99991 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples77/TSB10DD.f000077500000000000000000000111561201767322700167210ustar00rootroot00000000000000* SB10DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK, LDX, $ LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = PMAX, $ LDDK = PMAX, LDX = NMAX, LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*( MMAX + NMAX ) + $ MMAX + PMAX + NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = ( MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = $ ( ( NMAX + MPMX )*( NMAX + MPMX + 6 ) + $ 13*NMAX*NMAX + MMAX*MMAX + 2*MPMX*MPMX + $ NMAX*( MMAX + MPMX ) + $ ( MMAX*( MMAX + 7*NMAX ) + $ 2*MPMX*( 8*NMAX + MMAX + 2*MPMX ) ) $ + 6*NMAX + $ ( 14*NMAX + 23 + 16*NMAX + $ 2*NMAX + ( MMAX + 2*MPMX ) + $ 3*( MMAX + 2*MPMX ) ) ) ) * .. Local Scalars .. DOUBLE PRECISION GAMMA, TOL INTEGER I, INFO, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,PMAX), X(LDX,NMAX), $ Z(LDZ,NMAX), DWORK(LDWORK), RCOND( 8 ) * .. External Subroutines .. EXTERNAL SB10DD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) GAMMA, TOL CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 8 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10DD =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) 99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples77/TSB10ED.f000077500000000000000000000104451201767322700167220ustar00rootroot00000000000000* SB10ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = PMAX, $ LDDK = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*MMAX + PMAX + 2*NMAX + $ NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = ( MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MPMX*( 3*MPMX + 2*NMAX ) + $ ( ( NMAX + MPMX )*( NMAX + MPMX + 6 ) + $ MPMX*( MPMX + ( NMAX + MPMX + 5 ) + 1 ) + $ 2*NMAX*NMAX + ( 14*NMAX*NMAX + 6*NMAX + $ ( 14*NMAX + 23 + 16*NMAX ) + $ MPMX*( NMAX + MPMX + ( MPMX + 3 ) ) ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,MMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,MMAX), DWORK(LDWORK), $ RCOND( 8 ) * .. External Subroutines .. EXTERNAL SB10ED * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) TOL CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 7 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10ED =',I2) 99997 FORMAT (' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples77/TSB10FD.f000077500000000000000000000140221201767322700167160ustar00rootroot00000000000000* SB10FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, N2MAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10, N2MAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK, $ LDAC, LDBC, LDCC, LDDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = MMAX, $ LDDK = MMAX, LDAC = 2*NMAX, LDBC = 2*NMAX, $ LDCC = PMAX, LDDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*( NMAX + MMAX + PMAX ) + $ NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = ( MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MPMX*( 3*MPMX + 2*NMAX ) + $ ( ( NMAX + MPMX )*( NMAX + MPMX + 6 ) + $ MPMX*( MPMX + ( NMAX + MPMX + 5 ) + 1 ) + $ 2*NMAX*( NMAX + 2*MPMX ) + $ ( 4*MPMX*MPMX + ( 2*MPMX + 3*NMAX*NMAX + $ ( 2*NMAX*MPMX + 10*NMAX*NMAX+12*NMAX+5 ) ) + $ MPMX*( 3*NMAX + 3*MPMX + $ ( 2*NMAX + 4*MPMX + $ ( NMAX + MPMX ) ) ) ) ) ) * .. Local Scalars .. INTEGER SDIM LOGICAL SELECT DOUBLE PRECISION GAMMA, TOL INTEGER I, INFO1, INFO2, INFO3, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(N2MAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDAK,NMAX), AC(LDAC,N2MAX), $ B(LDB,MMAX), BK(LDBK,PMAX), BC(LDBC,MMAX), $ C(LDC,NMAX), CK(LDCK,NMAX), CC(LDCC,N2MAX), $ D(LDD,MMAX), DK(LDDK,PMAX), DC(LDDC,MMAX), $ DWORK(LDWORK), RCOND( 4 ) * .. External Subroutines .. EXTERNAL SB10FD, SB10LD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99987 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99986 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99985 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99984 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99983 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) GAMMA, TOL * Compute the suboptimal controller CALL 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, INFO1 ) * IF ( INFO1.EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99989 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99989 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99989 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99989 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99992 ) WRITE( NOUT, FMT = 99988 ) ( RCOND(I), I = 1, 4 ) * Compute the closed-loop matrices 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 ) * IF ( INFO2.EQ.0 ) THEN * Compute the closed-loop poles CALL DGEES( 'N','N', SELECT, 2*N, AC, LDAC, SDIM, $ DWORK(1), DWORK(2*N+1), DWORK, 2*N, $ DWORK(4*N+1), LDWORK-4*N, BWORK, INFO3) * IF( INFO3.EQ.0 ) THEN WRITE( NOUT, FMT = 99991 ) WRITE( NOUT, FMT = 99988 ) (DWORK(I), I =1, 2*N) WRITE( NOUT, FMT = 99990 ) WRITE( NOUT, FMT = 99988 ) (DWORK(2*N+I), I =1, 2*N) ELSE WRITE( NOUT, FMT = 99996 ) INFO3 END IF ELSE WRITE( NOUT, FMT = 99997 ) INFO2 END IF ELSE WRITE( NOUT, FMT = 99998 ) INFO1 END IF END IF STOP * 99999 FORMAT (' SB10FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10FD =',I2) 99997 FORMAT (/' INFO on exit from SB10LD =',I2) 99996 FORMAT (' The controller state matrix AK is'/) 99995 FORMAT (/' The controller input matrix BK is'/) 99994 FORMAT (/' The controller output matrix CK is'/) 99993 FORMAT (/' The controller matrix DK is'/) 99992 FORMAT (/' The estimated condition numbers are'/) 99991 FORMAT (/' The real parts of the closed-loop system poles are'/) 99990 FORMAT (/' The imaginary parts of the closed-loop system', $ ' poles are'/) 99989 FORMAT (10(1X,F8.4)) 99988 FORMAT ( 5(1X,D12.5)) 99987 FORMAT (/' N is out of range.',/' N = ',I5) 99986 FORMAT (/' M is out of range.',/' M = ',I5) 99985 FORMAT (/' N is out of range.',/' N = ',I5) 99984 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99983 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples77/TSB10HD.f000077500000000000000000000101331201767322700167170ustar00rootroot00000000000000* SB10HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK, LDDK PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDAK = NMAX, LDBK = NMAX, LDCK = PMAX, $ LDDK = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*NMAX + NMAX*NMAX ) ) INTEGER MPMX PARAMETER ( MPMX = ( MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MPMX*( 2*NMAX + 3*MPMX ) + $ ( MPMX*( MPMX + ( NMAX + 5 ) + 1 ) + $ NMAX*( 14*NMAX + 12 + 2*MPMX ) + 5 ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NCON, NMEAS, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,MMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,MMAX), DWORK(LDWORK), $ RCOND( 4 ) * .. External Subroutines .. EXTERNAL SB10HD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP, NCON, NMEAS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE IF ( NCON.LT.0 .OR. NCON.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) NCON ELSE IF ( NMEAS.LT.0 .OR. NMEAS.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NMEAS ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) TOL * Compute the optimal H2 controller CALL 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 ) * IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NMEAS ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, NCON WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NMEAS ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 4 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10HD =',I2) 99997 FORMAT (' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (6(1X,F10.4)) 99991 FORMAT (5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' NCON is out of range.',/' NCON = ',I5) 99986 FORMAT (/' NMEAS is out of range.',/' NMEAS = ',I5) END slicot-5.0+20101122/examples77/TSB10ID.f000077500000000000000000000073671201767322700167370ustar00rootroot00000000000000* SB10ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK PARAMETER ( LDA = NMAX, LDAK = NMAX, LDB = NMAX, $ LDBK = NMAX, LDC = PMAX, LDCK = MMAX, $ LDD = PMAX, LDDK = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = ( 2*NMAX + NMAX*NMAX + MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 4*NMAX*NMAX + MMAX*MMAX + PMAX*PMAX + $ 2*MMAX*NMAX + NMAX*PMAX + 4*NMAX + $ ( 10*NMAX*NMAX + 8*NMAX + 5 + $ NMAX*PMAX + 2*NMAX ) ) * .. Local Scalars .. DOUBLE PRECISION FACTOR INTEGER I, INFO, J, M, N, NK, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,PMAX), DWORK(LDWORK), $ RCOND( 2 ) * .. External Subroutines .. EXTERNAL SB10ID * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) FACTOR CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, NK WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,NK ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NK WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,NK ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 2 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10ID =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F9.4)) 99991 FORMAT ( 2(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples77/TSB10KD.f000077500000000000000000000074331201767322700167330ustar00rootroot00000000000000* SB10KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 10, MMAX = 10, PMAX = 10 ) INTEGER LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK PARAMETER ( LDA = NMAX, LDAK = NMAX, LDB = NMAX, $ LDBK = NMAX, LDC = PMAX, LDCK = MMAX, $ LDDK = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*( NMAX + MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 15*NMAX*NMAX + 6*NMAX + $ ( 14*NMAX + 23 + 16*NMAX + $ 2*NMAX+PMAX+MMAX + $ 3*(PMAX+MMAX) ) + $ ( NMAX*NMAX + $ 11*NMAX*PMAX + 2*MMAX*MMAX + $ 8*PMAX*PMAX + 8*MMAX*NMAX + $ 4*MMAX*PMAX + PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION FACTOR INTEGER I, INFO, J, M, N, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ DK(LDDK,PMAX), DWORK(LDWORK), RCOND(4) * .. External Subroutines .. EXTERNAL SB10KD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) FACTOR CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 4 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10KD =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples77/TSB10ZD.f000077500000000000000000000075131201767322700167510ustar00rootroot00000000000000* SB10ZD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX, PMAX PARAMETER ( MMAX = 10, NMAX = 10, PMAX = 10 ) INTEGER LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK PARAMETER ( LDA = NMAX, LDAK = NMAX, LDB = NMAX, $ LDBK = NMAX, LDC = PMAX, LDCK = MMAX, $ LDD = PMAX, LDDK = MMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*( NMAX + MMAX + PMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 16*NMAX*NMAX + 5*MMAX*MMAX + $ 7*PMAX*PMAX + 6*MMAX*NMAX + $ 7*MMAX*PMAX + 7*NMAX*PMAX + 6*NMAX + $ 2*( MMAX + PMAX ) + $ ( 14*NMAX + 23 + 16*NMAX + $ 2*MMAX - 1 + 2*PMAX - 1 ) ) * .. Local Scalars .. DOUBLE PRECISION FACTOR, TOL INTEGER I, INFO, J, M, N, NP * .. Local Arrays .. LOGICAL BWORK(2*NMAX) INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), AK(LDAK,NMAX), B(LDB,MMAX), $ BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX), $ D(LDD,MMAX), DK(LDDK,PMAX), DWORK(LDWORK), $ RCOND( 6 ) * .. External Subroutines .. EXTERNAL SB10ZD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, NP IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) NP ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP ) READ ( NIN, FMT = * ) FACTOR, TOL CALL 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 ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP ) 20 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 30 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, M WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP ) 40 CONTINUE WRITE( NOUT, FMT = 99993 ) WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1,6 ) ELSE WRITE( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' SB10ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (/' INFO on exit from SB10ZD =',I2) 99997 FORMAT (/' The controller state matrix AK is'/) 99996 FORMAT (/' The controller input matrix BK is'/) 99995 FORMAT (/' The controller output matrix CK is'/) 99994 FORMAT (/' The controller matrix DK is'/) 99993 FORMAT (/' The estimated condition numbers are'/) 99992 FORMAT (10(1X,F8.4)) 99991 FORMAT ( 5(1X,D12.5)) 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' NP is out of range.',/' NP = ',I5) END slicot-5.0+20101122/examples77/TSB16AD.f000077500000000000000000000127351201767322700167300ustar00rootroot00000000000000* SB16AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NCMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, $ NCMAX = 20 ) INTEGER MPMAX, NNCMAX PARAMETER ( MPMAX = MMAX + PMAX, NNCMAX = NMAX + NCMAX ) INTEGER LDA, LDB, LDC, LDD, LDAC, LDBC, LDCC, LDDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDAC = NCMAX, LDBC = NCMAX, $ LDCC = PMAX, LDDC = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = 2*( NCMAX + MPMAX ) ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NCMAX*NCMAX + $ NNCMAX*( NNCMAX + 2*MPMAX ) + $ ( NNCMAX*( NNCMAX + $ ( NNCMAX + MMAX + PMAX ) + 7 ) + $ MPMAX*( MPMAX + 4 ) ) ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, TOL1, TOL2 INTEGER I, INFO, IWARN, J, M, N, NCR, NCS, NC, P CHARACTER*1 DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), HSVC(NMAX), $ AC(LDAC,NCMAX), BC(LDBC,PMAX), CC(LDCC,NMAX), $ DC(LDDC,PMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB16AD * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NC, NCR, ALPHA, TOL1, TOL2, DICO, $ JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL IF( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF( P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) IF( NC.LT.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99986 ) NC ELSE IF( NC.GT.0 ) THEN READ ( NIN, FMT = * ) $ ( ( AC(I,J), J = 1,NC ), I = 1,NC ) READ ( NIN, FMT = * ) $ ( ( BC(I,J), J = 1,P ), I = 1, NC ) READ ( NIN, FMT = * ) $ ( ( CC(I,J), J = 1,NC ), I = 1,M ) END IF READ ( NIN, FMT = * ) $ ( ( DC(I,J), J = 1,P ), I = 1,M ) END IF * Find a reduced ssr for (AC,BC,CC,DC). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99984 ) IWARN WRITE ( NOUT, FMT = 99997 ) NCR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSVC(J), J = 1, NCS ) IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( AC(I,J), J = 1,NCR ) 20 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( BC(I,J), J = 1,P ) 40 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( CC(I,J), J = 1,NCR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( DC(I,J), J = 1,P ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB16AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB16AD = ',I2) 99997 FORMAT (/' The order of reduced controller = ',I2) 99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced controller input/state matrix Bc is ') 99992 FORMAT (/' The reduced controller state/output matrix Cc is ') 99991 FORMAT (/' The reduced controller input/output matrix Dc is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of weighted ALPHA-stable', $ ' part are') 99986 FORMAT (/' NC is out of range.',/' NC = ',I5) 99984 FORMAT (' IWARN on exit from SB16AD = ',I2) END slicot-5.0+20101122/examples77/TSB16BD.f000077500000000000000000000107041201767322700167230ustar00rootroot00000000000000* SB16BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDDC, LDF, LDG PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDDC = MMAX, LDF = MMAX, LDG = NMAX $ ) INTEGER LDWORK, LIWORK, MAXMP, MPMAX PARAMETER ( LIWORK = 2*NMAX, MAXMP = ( MMAX + PMAX ), $ MPMAX = MMAX + PMAX ) PARAMETER ( LDWORK = ( NMAX + MAXMP )*MPMAX + $ ( NMAX*( 2*NMAX + $ ( NMAX + MPMAX ) + 5 ) $ + ( NMAX*( NMAX + 1 ) )/2 + $ 4*MAXMP ) ) CHARACTER DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL INTEGER I, INFO, IWARN, J, M, N, NCR, P DOUBLE PRECISION TOL1, TOL2 * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DC(LDDC,PMAX), DWORK(LDWORK), $ F(LDF,NMAX), G(LDG,PMAX), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB16BD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NCR, TOL1, TOL2, $ DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,P ), I = 1,N ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCR ) 20 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,P ) 40 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,NCR ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( DC(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB16BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB16BD = ',I2) 99997 FORMAT (' The order of reduced controller = ',I2) 99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced controller input/state matrix Bc is ') 99992 FORMAT (/' The reduced controller state/output matrix Cc is ') 99991 FORMAT (/' The reduced controller input/output matrix Dc is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The Hankel singular values of extended system are:') END slicot-5.0+20101122/examples77/TSB16CD.f000077500000000000000000000100341201767322700167200ustar00rootroot00000000000000* SB16CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDDC, LDF, LDG PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDDC = MMAX, LDF = MMAX, LDG = NMAX ) INTEGER LDWORK, LIWORK, MPMAX PARAMETER ( LIWORK = 2*NMAX, MPMAX = ( MMAX + PMAX ) ) PARAMETER ( LDWORK = 2*NMAX*NMAX + $ ( 2*NMAX*NMAX + 5*NMAX + $ NMAX*( NMAX + ( NMAX + MPMAX ) $ + ( NMAX + MPMAX ) + 6 ) ) $ ) CHARACTER DICO, JOBCF, JOBD, JOBMR, ORDSEL INTEGER I, INFO, IWARN, J, M, N, NCR, P DOUBLE PRECISION TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), $ F(LDF,NMAX), G(LDG,PMAX), HSV(NMAX) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL SB16CD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NCR, TOL, $ DICO, JOBD, JOBMR, JOBCF, ORDSEL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M ) READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,P ), I = 1,N ) * Find a reduced ssr for (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCR WRITE ( NOUT, FMT = 99987 ) WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N ) IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCR ) 20 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCR WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,P ) 40 CONTINUE IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, M WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,NCR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SB16CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SB16CD = ',I2) 99997 FORMAT (' The order of reduced controller = ',I2) 99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The reduced controller input/state matrix Bc is ') 99992 FORMAT (/' The reduced controller state/output matrix Cc is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The frequency-weighted Hankel singular values are:') END slicot-5.0+20101122/examples77/TSG02AD.f000077500000000000000000000111431201767322700167200ustar00rootroot00000000000000* SG02AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER NMAX2M, NMAX2, NMMAX PARAMETER ( NMAX2M = 2*NMAX+MMAX, NMAX2 = 2*NMAX, $ NMMAX = NMAX+MMAX ) INTEGER LDA, LDB, LDE, LDL, LDQ, LDR, LDS, LDT, LDU, LDX PARAMETER ( LDA = NMAX, LDB = NMAX, LDE = NMAX, LDL = NMAX, $ LDQ = NMAX+PMAX, LDR = MMAX+PMAX, $ LDS = NMAX2M, LDT = NMAX2M, LDU = NMAX2, $ LDX = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX+NMAX2 ) INTEGER LDWORK PARAMETER ( LDWORK = 16*NMAX+23+2*NMAX+MMAX+3*MMAX ) INTEGER LBWORK PARAMETER ( LBWORK = NMAX2 ) * .. Local Scalars .. DOUBLE PRECISION RCONDU, TOL INTEGER I, INFO, IWARN, J, M, N, P CHARACTER*1 ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO LOGICAL LJOBB * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALFAI(NMAX2), ALFAR(NMAX2), $ B(LDB,NMMAX), BETA(NMAX2), DWORK(LDWORK), $ E(LDE,NMAX), L(LDL,MMAX), Q(LDQ,NMAX), $ R(LDR,MMAX), S(LDS,NMAX2M), T(LDT,NMAX2), $ U(LDU,NMAX2), X(LDX,NMAX) INTEGER IWORK(LIWORK) LOGICAL BWORK(LBWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SG02AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBB, FACT, UPLO, JOBL, $ SCAL, SORT, ACC IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE LJOBB = LSAME( JOBB, 'B' ) IF ( LJOBB ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N ) END IF IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99993 ) P ELSE IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'D' ) ) THEN READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,N ) ELSE READ ( NIN, FMT = * ) $ ( ( Q(I,J), J = 1,N ), I = 1,P ) END IF IF ( LJOBB ) THEN IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'C' ) ) THEN READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,M ) ELSE READ ( NIN, FMT = * ) $ ( ( R(I,J), J = 1,M ), I = 1,P ) END IF IF ( LSAME( JOBL, 'N' ) ) $ READ ( NIN, FMT = * ) $ ( ( L(I,J), J = 1,M ), I = 1,N ) END IF * Find the solution matrix X. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' SG02AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SG02AD = ',I2) 99997 FORMAT (' The solution matrix X is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TSG03AD.f000077500000000000000000000056741201767322700167350ustar00rootroot00000000000000* SG03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDE, LDQ, LDX, LDZ PARAMETER ( LDA = NMAX, LDE = NMAX, LDQ = NMAX, $ LDX = NMAX, LDZ = NMAX ) INTEGER LIWORK, LDWORK PARAMETER ( LIWORK = NMAX**2, $ LDWORK = ( 2*NMAX**2 + 4*NMAX ) ) * .. Local Scalars .. CHARACTER*1 DICO, FACT, JOB, TRANS, UPLO DOUBLE PRECISION FERR, SCALE, SEP INTEGER I, INFO, J, N * .. Local Arrays .. INTEGER IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX), $ BETA(NMAX), DWORK(LDWORK), E(LDE,NMAX), $ Q(LDQ,NMAX), X(LDX,NMAX), Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SG03AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, JOB, DICO, FACT, TRANS, UPLO IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( LSAME ( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N ) END IF IF ( .NOT.LSAME ( JOB, 'S' ) ) $ READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N ) * Find the solution matrix X and the scalar SEP. CALL 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 ) IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME ( JOB, 'B' ) .OR. LSAME ( JOB, 'S' ) ) THEN WRITE ( NOUT, FMT = 99997 ) SEP WRITE ( NOUT, FMT = 99996 ) FERR END IF IF ( LSAME ( JOB, 'B' ) .OR. LSAME ( JOB, 'X' ) ) THEN WRITE ( NOUT, FMT = 99995 ) SCALE DO 20 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N ) 20 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' SG03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SG03AD = ',I2) 99997 FORMAT (' SEP = ',D8.2) 99996 FORMAT (' FERR = ',D8.2) 99995 FORMAT (' SCALE = ',D8.2,//' The solution matrix X is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) END slicot-5.0+20101122/examples77/TSG03BD.f000077500000000000000000000053421201767322700167260ustar00rootroot00000000000000* SG03BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX PARAMETER ( NMAX = 20 ) INTEGER LDA, LDB, LDE, LDQ, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDE = NMAX, $ LDQ = NMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + 4*NMAX + 6*NMAX-6 ) ) * .. Local Scalars .. CHARACTER*1 DICO, FACT, TRANS DOUBLE PRECISION SCALE INTEGER I, INFO, J, N, M * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), ALPHAI(NMAX), ALPHAR(NMAX), $ B(LDB,NMAX), BETA(NMAX), DWORK(LDWORK), $ E(LDE,NMAX), Q(LDQ,NMAX), Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL SG03BD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE IF ( M.LT.0 .OR. M.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( LSAME( FACT, 'F' ) ) THEN READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N ) END IF IF ( LSAME( FACT, 'T' ) ) THEN READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M ) END IF * Find the Cholesky factor U of the solution matrix. CALL SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, LDQ, $ Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, BETA, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) SCALE DO 20 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,N ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' SG03BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from SG03BD = ',I2) 99997 FORMAT (' SCALE = ',F8.4,//' The Cholesky factor U of the solution $ matrix is') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TTB01ID.f000077500000000000000000000051341201767322700167260ustar00rootroot00000000000000* TB01ID EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, INFO, J, M, N, P DOUBLE PRECISION MAXRED * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ SCALE(NMAX) * .. External Subroutines .. EXTERNAL TB01ID, UD01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOB, MAXRED IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Balance system matrix S. CALL TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL UD01MD( N, N, 5, NOUT, A, LDA, $ 'The balanced matrix A', INFO ) IF ( M.GT.0 ) $ CALL UD01MD( N, M, 5, NOUT, B, LDB, $ 'The balanced matrix B', INFO ) IF ( P.GT.0 ) $ CALL UD01MD( P, N, 5, NOUT, C, LDC, $ 'The balanced matrix C', INFO ) CALL UD01MD( 1, N, 5, NOUT, SCALE, 1, $ 'The scaling vector SCALE', INFO ) WRITE ( NOUT, FMT = 99994 ) MAXRED END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01ID = ',I2) 99994 FORMAT (/' MAXRED is ',E13.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB01IZ.f000077500000000000000000000051431201767322700167540ustar00rootroot00000000000000* TB01IZ EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX ) * .. Local Scalars .. CHARACTER*1 JOB INTEGER I, INFO, J, M, N, P DOUBLE PRECISION MAXRED * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX) DOUBLE PRECISION SCALE(NMAX) * .. External Subroutines .. EXTERNAL TB01IZ, UD01MD, UD01MZ * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, JOB, MAXRED IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Balance system matrix S. CALL TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE CALL UD01MZ( N, N, 3, NOUT, A, LDA, $ 'The balanced matrix A', INFO ) IF ( M.GT.0 ) $ CALL UD01MZ( N, M, 3, NOUT, B, LDB, $ 'The balanced matrix B', INFO ) IF ( P.GT.0 ) $ CALL UD01MZ( P, N, 3, NOUT, C, LDC, $ 'The balanced matrix C', INFO ) CALL UD01MD( 1, N, 5, NOUT, SCALE, 1, $ 'The scaling vector SCALE', INFO ) WRITE ( NOUT, FMT = 99994 ) MAXRED END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01IZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01IZ = ',I2) 99994 FORMAT (/' MAXRED is ',E13.4) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) 99991 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB01KD.f000077500000000000000000000071431201767322700167320ustar00rootroot00000000000000* TB01KD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDU PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 DICO, JOBA, STDOM INTEGER I, INFO, J, M, N, NDIM, P DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL TB01KD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, STDOM, JOBA IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed ssr for (A,B,C). CALL TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, $ B, LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, $ LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99987 ) NDIM WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01KD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01KD = ',I2) 99997 FORMAT (/' The eigenvalues of state dynamics matrix A are ') 99996 FORMAT (/' The transformed state dynamics matrix inv(U)*A*U is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT ( ' (',F8.4,', ',F8.4,' )') 99993 FORMAT (/' The transformed input/state matrix inv(U)*B is ') 99992 FORMAT (/' The transformed state/output matrix C*U is ') 99991 FORMAT (/' The similarity transformation matrix U is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (' The number of eigenvalues in the domain of interest =', $ I5 ) END slicot-5.0+20101122/examples77/TTB01LD.f000077500000000000000000000071361201767322700167350ustar00rootroot00000000000000* TB01LD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDU PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. CHARACTER*1 DICO, JOBA, STDOM INTEGER I, INFO, J, M, N, NDIM, P DOUBLE PRECISION ALPHA * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL TB01LD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, ALPHA, DICO, STDOM, JOBA IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed ssr for (A,B,C). CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, $ A, LDA, B, LDB, C, LDC, NDIM, U, LDU, $ WR, WI, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99987 ) NDIM WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01LD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01LD = ',I2) 99997 FORMAT (/' The eigenvalues of state dynamics matrix A are ') 99996 FORMAT (/' The transformed state dynamics matrix U''*A*U is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT ( ' (',F8.4,', ',F8.4,' )') 99993 FORMAT (/' The transformed input/state matrix U''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*U is ') 99991 FORMAT (/' The similarity transformation matrix U is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The number of eigenvalues in the domain of interest =', $ I5 ) END slicot-5.0+20101122/examples77/TTB01MD.f000077500000000000000000000053731201767322700167370ustar00rootroot00000000000000* TB01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX PARAMETER ( NMAX = 20, MMAX = 20 ) INTEGER LDA, LDB, LDU, LDWORK PARAMETER ( LDA = NMAX, LDB = NMAX, LDU = NMAX, $ LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N CHARACTER*1 JOBU, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), U(LDU,NMAX), $ DWORK(LDWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, JOBU, UPLO IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99992 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( LSAME( JOBU, 'U' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) * Reduce the pair (B,A) to controller Hessenberg form. CALL TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU, $ DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 80 CONTINUE IF ( LSAME( JOBU, 'I' ).OR.LSAME( JOBU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,N ) 100 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01MD = ',I2) 99997 FORMAT (' The transformed state transition matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed input matrix is ') 99994 FORMAT (/' The transformation matrix that reduces (B,A) to contr', $ 'oller Hessenberg form is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TTB01ND.f000077500000000000000000000053701201767322700167350ustar00rootroot00000000000000* TB01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA, LDC, LDU, LDWORK PARAMETER ( LDA = NMAX, LDC = PMAX, LDU = NMAX, $ LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, N, P CHARACTER*1 JOBU, UPLO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), U(LDU,NMAX), $ DWORK(LDWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, JOBU, UPLO IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) IF ( LSAME( JOBU, 'U' ) ) $ READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N ) * Reduce the pair (A,C) to observer Hessenberg form. CALL TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU, $ DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N ) 80 CONTINUE IF ( LSAME( JOBU, 'I' ).OR.LSAME( JOBU, 'U' ) ) THEN WRITE ( NOUT, FMT = 99994 ) DO 100 I = 1, N WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,N ) 100 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01ND = ',I2) 99997 FORMAT (' The transformed state transition matrix is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed output matrix is ') 99994 FORMAT (/' The transformation matrix that reduces (A,C) to obser', $ 'ver Hessenberg form is ') 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB01PD.f000077500000000000000000000063551201767322700167430ustar00rootroot00000000000000* TB01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDC PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX+MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX + ( NMAX + 3*MAXMP ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, M, N, NR, P CHARACTER JOB, EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ DWORK(LDWORK) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL TB01PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOB, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a minimal ssr for (A,B,C). CALL TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, $ NR, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01PD = ',I2) 99997 FORMAT (' The order of the minimal realization = ',I2) 99996 FORMAT (/' The transformed state dynamics matrix of a minimal re', $ 'alization is ') 99995 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' The transformed input/state matrix of a minimal reali', $ 'zation is ') 99992 FORMAT (/' The transformed state/output matrix of a minimal real', $ 'ization is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB01TD.f000077500000000000000000000062621201767322700167440ustar00rootroot00000000000000* TB01TD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDD PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX ) * .. Local Scalars .. INTEGER I, INFO, IGH, J, LOW, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(NMAX), SCIN(MMAX), $ SCOUT(PMAX), SCSTAT(NMAX) * .. External Subroutines .. EXTERNAL TB01TD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99989 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Balance the state-space representation (A,B,C,D). CALL TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ LOW, IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) LOW, IGH WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 80 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01TD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01TD = ',I2) 99997 FORMAT (' LOW = ',I2,' IGH = ',I2,/) 99996 FORMAT (' The balanced state dynamics matrix A is ') 99995 FORMAT (20(1X,F9.4)) 99994 FORMAT (/' The balanced input/state matrix B is ') 99993 FORMAT (/' The balanced state/output matrix C is ') 99992 FORMAT (/' The scaled direct transmission matrix D is ') 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB01UD.f000077500000000000000000000104051201767322700167370ustar00rootroot00000000000000* TB01UD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDZ = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = MMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX + 3*MMAX + PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, INDCON, J, M, N, NCONT, P CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), TAU(NMAX), Z(LDZ,NMAX) INTEGER IWORK(LIWORK), NBLK(NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01UD, DORGQR * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a controllable ssr for the given system. CALL TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, $ NCONT, INDCON, NBLK, Z, LDZ, TAU, TOL, $ IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) ( NBLK(I), I = 1,INDCON ) WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NCONT WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NCONT ) 60 CONTINUE WRITE ( NOUT, FMT = 99992 ) INDCON IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, $ INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99991 ) DO 80 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 80 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01UD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01UD = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2) 99996 FORMAT (/' The transformed state dynamics matrix of a controllab', $ 'le realization is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' and the dimensions of its diagonal blocks are ', $ /20(1X,I2)) 99993 FORMAT (/' The transformed input/state matrix B of a controllabl', $ 'e realization is ') 99992 FORMAT (/' The controllability index of the transformed system r', $ 'epresentation = ',I2) 99991 FORMAT (/' The similarity transformation matrix Z is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) 99987 FORMAT (/' The transformed output/state matrix C of a controlla', $ 'ble realization is ') END slicot-5.0+20101122/examples77/TTB01WD.f000077500000000000000000000064541201767322700167520ustar00rootroot00000000000000* TB01WD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDU PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDU = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, M, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), U(LDU,NMAX), WI(NMAX), WR(NMAX) * .. External Subroutines .. EXTERNAL TB01WD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99990 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99989 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99988 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed ssr for (A,B,C). CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, $ WR, WI, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99994 ) WR(I), WI(I) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 60 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 60 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 70 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N ) 70 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01WD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01WD = ',I2) 99997 FORMAT (' The eigenvalues of state dynamics matrix A are ') 99996 FORMAT (/' The transformed state dynamics matrix U''*A*U is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT ( ' (',F8.4,', ',F8.4,' )') 99993 FORMAT (/' The transformed input/state matrix U''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*U is ') 99991 FORMAT (/' The similarity transformation matrix U is ') 99990 FORMAT (/' N is out of range.',/' N = ',I5) 99989 FORMAT (/' M is out of range.',/' M = ',I5) 99988 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB01ZD.f000077500000000000000000000063611201767322700167520ustar00rootroot00000000000000* TB01ZD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, PMAX PARAMETER ( NMAX = 20, PMAX = 20 ) INTEGER LDA, LDC, LDZ PARAMETER ( LDA = NMAX, LDC = PMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX + PMAX ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INFO, J, N, NCONT, P CHARACTER*1 JOBZ * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(NMAX), C(LDC,NMAX), DWORK(LDWORK), $ TAU(NMAX), Z(LDZ,NMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB01ZD, DORGQR * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read in the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, P, TOL, JOBZ IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99993 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( B(I), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find a controllable realization for the given system. CALL TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ, $ TAU, TOL, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NCONT DO 20 I = 1, NCONT WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT ) WRITE ( NOUT, FMT = 99991 ) DO 30 I = 1, P WRITE ( NOUT, FMT = 99994 ) ( C(I,J), J = 1,NCONT ) 30 CONTINUE IF ( LSAME( JOBZ, 'F' ) ) $ CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, $ INFO ) IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN WRITE ( NOUT, FMT = 99995 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB01ZD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB01ZD = ',I2) 99997 FORMAT (' The order of the controllable state-space representati', $ 'on = ',I2,//' The state dynamics matrix A of a controlla', $ 'ble realization is ') 99996 FORMAT (/' The input/state vector B of a controllable realizatio', $ 'n is ',/(1X,F8.4)) 99995 FORMAT (/' The similarity transformation matrix Z is ') 99994 FORMAT (20(1X,F8.4)) 99993 FORMAT (/' N is out of range.',/' N = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' The output/state matrix C of a controllable realizati', $ 'on is ') END slicot-5.0+20101122/examples77/TTB03AD.f000077500000000000000000000146641201767322700167300ustar00rootroot00000000000000* TB03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, LDQCO1, $ LDQCO2, LDVCO1, LDVCO2, NMAXP1 PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP, LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP, LDVCO1 = MAXMP, $ LDVCO2 = NMAX, NMAXP1 = NMAX+1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX + ( NMAX + 3*MAXMP ) + $ MAXMP*( MAXMP + 2 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INDBLK, INFO, J, K, KPCOEF, M, N, NR, P, PORM, $ PORP CHARACTER*1 EQUIL, LERI LOGICAL LLERI * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DWORK(LDWORK), $ PCOEFF(LDPCO1,LDPCO2,NMAXP1), $ QCOEFF(LDQCO1,LDQCO2,NMAXP1), $ VCOEFF(LDVCO1,LDVCO2,NMAXP1) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB03AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, LERI, EQUIL LLERI = LSAME( LERI, 'L' ) IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99987 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99986 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99985 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the right pmr which is equivalent to the ssr * C*inv(sI-A)*B+D. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 20 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 20 CONTINUE INDBLK = 0 DO 40 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) ( IWORK(I), I = 1,INDBLK ) WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE IF ( LLERI ) THEN PORM = P PORP = M WRITE ( NOUT, FMT = 99992 ) INDBLK ELSE PORM = M PORP = P WRITE ( NOUT, FMT = 99991 ) INDBLK END IF WRITE ( NOUT, FMT = 99990 ) ( INDEX(I), I = 1,PORM ) KPCOEF = 0 DO 100 I = 1, PORM KPCOEF = MAX( KPCOEF, INDEX(I) ) 100 CONTINUE KPCOEF = KPCOEF + 1 WRITE ( NOUT, FMT = 99989 ) DO 140 I = 1, PORM DO 120 J = 1, PORM WRITE ( NOUT, FMT = 99996 ) $ ( PCOEFF(I,J,K), K = 1,KPCOEF ) 120 CONTINUE 140 CONTINUE WRITE ( NOUT, FMT = 99988 ) IF ( LLERI ) THEN DO 180 I = 1, PORM DO 160 J = 1, PORP WRITE ( NOUT, FMT = 99996 ) $ ( QCOEFF(I,J,K), K = 1,KPCOEF ) 160 CONTINUE 180 CONTINUE ELSE DO 220 I = 1, PORP DO 200 J = 1, PORM WRITE ( NOUT, FMT = 99996 ) $ ( QCOEFF(I,J,K), K = 1,KPCOEF ) 200 CONTINUE 220 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TB03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB03AD = ',I2) 99997 FORMAT (' The order of the minimal state-space representation = ', $ I2,//' The transformed state dynamics matrix of a minimal', $ ' realization is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' and the dimensions of its diagonal blocks are ',/20(I5) $ ) 99994 FORMAT (/' The transformed input/state matrix of a minimal reali', $ 'zation is ') 99993 FORMAT (/' The transformed state/output matrix of a minimal real', $ 'ization is ') 99992 FORMAT (/' The observability index of the transformed minimal sy', $ 'stem representation = ',I2) 99991 FORMAT (/' The controllability index of the transformed minimal ', $ 'system representation = ',I2) 99990 FORMAT (/' INDEX is ',/20(I5)) 99989 FORMAT (/' The denominator matrix P(s) is ') 99988 FORMAT (/' The numerator matrix Q(s) is ') 99987 FORMAT (/' N is out of range.',/' N = ',I5) 99986 FORMAT (/' M is out of range.',/' M = ',I5) 99985 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB04AD.f000077500000000000000000000141151201767322700167200ustar00rootroot00000000000000* TB04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, LDUCO2, $ NMAXP1 PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP, LDDCOE = MAXMP, LDUCO1 = MAXMP, $ LDUCO2 = MAXMP, NMAXP1 = NMAX+1 ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX + 1 ) + $ ( NMAX*MAXMP + 2*NMAX + $ ( NMAX + MAXMP ) + 3*MAXMP ) ) * .. Local Scalars .. DOUBLE PRECISION TOL1, TOL2 INTEGER I, II, IJ, INDBLK, INFO, J, JJ, KDCOEF, M, N, $ NR, P, PORM, PORP CHARACTER*1 ROWCOL CHARACTER*132 ULINE LOGICAL LROWCO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DCOEFF(LDDCOE,NMAXP1), $ DWORK(LDWORK), UCOEFF(LDUCO1,LDUCO2,NMAXP1) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB04AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL1, TOL2, ROWCOL LROWCO = LSAME( ROWCOL, 'R' ) ULINE(1:20) = ' ' DO 20 I = 21, 132 ULINE(I:I) = '-' 20 CONTINUE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99986 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99985 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99984 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the transfer matrix T(s) of (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 40 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE INDBLK = 0 DO 100 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 100 CONTINUE IF ( LROWCO ) THEN PORM = P PORP = M WRITE ( NOUT, FMT = 99993 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) ELSE PORM = M PORP = P WRITE ( NOUT, FMT = 99992 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) END IF WRITE ( NOUT, FMT = 99991 ) ( INDEX(I), I = 1,PORM ) WRITE ( NOUT, FMT = 99990 ) KDCOEF = 0 DO 120 I = 1, PORM KDCOEF = MAX( KDCOEF, INDEX(I) ) 120 CONTINUE KDCOEF = KDCOEF + 1 DO 160 II = 1, PORM DO 140 JJ = 1, PORP WRITE ( NOUT, FMT = 99989 ) II, JJ, $ ( UCOEFF(II,JJ,IJ), IJ = 1,KDCOEF ) WRITE ( NOUT, FMT = 99988 ) ULINE(1:7*KDCOEF+21) WRITE ( NOUT, FMT = 99987 ) $ ( DCOEFF(II,IJ), IJ = 1,KDCOEF ) 140 CONTINUE 160 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB04AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB04AD = ',I2) 99997 FORMAT (' The order of the transformed state-space representatio', $ 'n = ',I2,//' The transformed state dynamics matrix A is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The transformed input/state matrix B is ') 99994 FORMAT (/' The transformed state/output matrix C is ') 99993 FORMAT (/' The controllability index of the transformed state-sp', $ 'ace representation = ',I2,//' The dimensions of the diag', $ 'onal blocks of the transformed A are ',/20(I5)) 99992 FORMAT (/' The observability index of the transformed state-spac', $ 'e representation = ',I2,//' The dimensions of the diagon', $ 'al blocks of the transformed A are ',/20(I5)) 99991 FORMAT (/' The degrees of the denominator polynomials are',/20(I5) $ ) 99990 FORMAT (/' The coefficients of polynomials in the transfer matri', $ 'x T(s) are ') 99989 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2)) 99988 FORMAT (1X,A) 99987 FORMAT (20X,20(1X,F6.2)) 99986 FORMAT (/' N is out of range.',/' N = ',I5) 99985 FORMAT (/' M is out of range.',/' M = ',I5) 99984 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB04BD.f000077500000000000000000000103431201767322700167200ustar00rootroot00000000000000* TB04BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, MDMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, $ MDMAX = NMAX + 1 ) INTEGER PMNMAX PARAMETER ( PMNMAX = PMAX*MMAX*MDMAX ) INTEGER LDA, LDB, LDC, LDD, LDIGD, LDIGN PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDIGD = PMAX, LDIGN = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX + PMAX ) + $ ( NMAX + ( NMAX + PMAX ) + $ NMAX*( 2*NMAX + 5 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, IJ, INFO, J, K, M, MD, N, P CHARACTER*1 JOBD, ORDER, EQUIL CHARACTER*132 ULINE * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), GD(PMNMAX), $ GN(PMNMAX) INTEGER IGD(LDIGD,MMAX), IGN(LDIGN,MMAX), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB04BD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBD, ORDER, EQUIL MD = N + 1 ULINE(1:20) = ' ' DO 20 I = 21, 132 ULINE(I:I) = '-' 20 CONTINUE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99989 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the transfer matrix T(s) of (A,B,C,D). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( ORDER, 'I' ) ) THEN WRITE ( NOUT, FMT = 99997 ) ELSE WRITE ( NOUT, FMT = 99996 ) END IF WRITE ( NOUT, FMT = 99995 ) DO 60 J = 1, M DO 40 I = 1, P IJ = ( (J-1)*P + I-1 )*MD + 1 WRITE ( NOUT, FMT = 99994 ) I, J, $ ( GN(K), K = IJ,IJ+IGN(I,J) ) WRITE ( NOUT, FMT = 99993 ) $ ULINE(1:7*(IGD(I,J)+1)+21) WRITE ( NOUT, FMT = 99992 ) $ ( GD(K), K = IJ,IJ+IGD(I,J) ) 40 CONTINUE 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB04BD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB04BD = ',I2) 99997 FORMAT (/' The polynomial coefficients appear in increasing', $ ' order'/' of the powers of the indeterminate') 99996 FORMAT (/' The polynomial coefficients appear in decreasing', $ ' order'/' of the powers of the indeterminate') 99995 FORMAT (/' The coefficients of polynomials in the transfer matri', $ 'x T(s) are ') 99994 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2)) 99993 FORMAT (1X,A) 99992 FORMAT (20X,20(1X,F6.2)) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB04CD.f000077500000000000000000000103531201767322700167220ustar00rootroot00000000000000* TB04CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NPZMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, $ NPZMAX = NMAX ) INTEGER PMNMAX PARAMETER ( PMNMAX = PMAX*MMAX*NPZMAX ) INTEGER LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDGAIN = PMAX, LDNP = PMAX, $ LDNZ = PMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX*( NMAX + PMAX ) + $ ( NMAX + ( NMAX + PMAX ) + $ NMAX*( 2*NMAX + 3 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, IJ, INFO, J, K, M, N, NPZ, P CHARACTER*1 JOBD, EQUIL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), GAINS(LDGAIN,MMAX), $ POLESI(PMNMAX), POLESR(PMNMAX), ZEROSI(PMNMAX), $ ZEROSR(PMNMAX) INTEGER IWORK(LIWORK), NP(LDNP,MMAX), NZ(LDNZ,MMAX) * .. External Subroutines .. EXTERNAL TB04CD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBD, EQUIL NPZ = N IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P ) * Find the transfer matrix T(s) of (A,B,C,D) in the * pole-zero-gain form. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 60 J = 1, M DO 40 I = 1, P IJ = ( (J-1)*P + I-1 )*NPZ + 1 IF ( NZ(I,J).EQ.0 ) THEN WRITE ( NOUT, FMT = 99996 ) I, J ELSE WRITE ( NOUT, FMT = 99995 ) I, J, $ ( ZEROSR(K), ZEROSI(K), $ K = IJ,IJ+NZ(I,J)-1 ) END IF WRITE ( NOUT, FMT = 99994 ) I, J, $ ( POLESR(K), POLESI(K), K = IJ,IJ+NP(I,J)-1 ) WRITE ( NOUT, FMT = 99993 ) I, J, ( GAINS(I,J) ) 40 CONTINUE 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB04CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB04CD = ',I2) 99997 FORMAT (/' The poles, zeros and gains of the transfer matrix', $ ' elements: ') 99996 FORMAT (/' no zeros for element (',I2,',',I2,')') 99995 FORMAT (/' zeros of element (',I2,',',I2,') are ',// $ ' real part imag part '// (2X,F9.4,5X,F9.4)) 99994 FORMAT (/' poles of element (',I2,',',I2,') are ',// $ ' real part imag part '// (2X,F9.4,5X,F9.4)) 99993 FORMAT (/' gain of element (',I2,',',I2,') is ', F9.4) 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTB05AD.f000077500000000000000000000074661201767322700167340ustar00rootroot00000000000000* TB05AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDG, LDHINV PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDG = PMAX, $ LDHINV = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NMAX ) INTEGER LZWORK PARAMETER ( LZWORK = NMAX*( NMAX+2 ) ) * .. Local Scalars .. COMPLEX*16 FREQ DOUBLE PRECISION RCOND INTEGER I, INFO, J, M, N, P CHARACTER*1 BALEIG, INITA LOGICAL LBALBA, LBALEA, LBALEB, LBALEC, LINITA * .. Local Arrays .. COMPLEX*16 G(LDG,MMAX), HINVB(LDHINV,MMAX), ZWORK(LZWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), EVIM(NMAX), EVRE(NMAX) INTEGER IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TB05AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, FREQ, INITA, BALEIG LBALEC = LSAME( BALEIG, 'C' ) LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' ) LBALEA = LSAME( BALEIG, 'A' ) LBALBA = LBALEB.OR.LBALEA LINITA = LSAME( INITA, 'G' ) IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99992 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the frequency response matrix of the ssr (A,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( ( LBALEC ) .OR. ( LBALEA ) ) WRITE ( NOUT, $ FMT = 99997 ) RCOND IF ( ( LINITA ) .AND. ( LBALBA ) ) $ WRITE ( NOUT, FMT = 99996 ) $ ( EVRE(I), EVIM(I), I = 1,N ) WRITE ( NOUT, FMT = 99995 ) DO 20 I = 1, P WRITE ( NOUT, FMT = 99994 ) ( G(I,J), J = 1,M ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99994 ) ( HINVB(I,J), J = 1,M ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TB05AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TB05AD = ',I2) 99997 FORMAT (' RCOND = ',F4.2) 99996 FORMAT (/' Eigenvalues of the state transmission matrix A are ', $ /(1X,2F7.2,'*j')) 99995 FORMAT (/' The frequency response matrix G(freq) is ') 99994 FORMAT (20(' (',F5.2,',',F5.2,') ',:)) 99993 FORMAT (/' H(inverse)*B is ') 99992 FORMAT (/' N is out of range.',/' N = ',I5) 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTC01OD.f000077500000000000000000000060421201767322700167340ustar00rootroot00000000000000* TC01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, INDMAX PARAMETER ( MMAX = 20, PMAX = 20, INDMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDPCO1, LDPCO2, LDQCO1, LDQCO2 PARAMETER ( LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP ) * .. Local Scalars .. INTEGER I, INDLIM, INFO, J, K, M, P, PORM CHARACTER*1 LERI LOGICAL LLERI * .. Local Arrays .. DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,INDMAX), $ QCOEFF(LDQCO1,LDQCO2,INDMAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TC01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, INDLIM, LERI LLERI = LSAME( LERI, 'L' ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99993 ) P ELSE IF ( INDLIM.LE.0 .OR. INDLIM.GT.INDMAX ) THEN WRITE ( NOUT, FMT = 99992 ) INDLIM ELSE PORM = P IF ( .NOT.LLERI ) PORM = M READ ( NIN, FMT = * ) $ ( ( ( PCOEFF(I,J,K), K = 1,INDLIM ), J = 1,PORM ), $ I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( QCOEFF(I,J,K), K = 1,INDLIM ), J = 1,M ), I = 1,P ) * Find the dual right pmr of the given left pmr. CALL TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 40 I = 1, PORM DO 20 J = 1, PORM WRITE ( NOUT, FMT = 99996 ) I, J, $ ( PCOEFF(I,J,K), K = 1,INDLIM ) 20 CONTINUE 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 80 I = 1, M DO 60 J = 1, P WRITE ( NOUT, FMT = 99996 ) I, J, $ ( QCOEFF(I,J,K), K = 1,INDLIM ) 60 CONTINUE 80 CONTINUE END IF END IF STOP * 99999 FORMAT (' TC01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TC01OD = ',I2) 99997 FORMAT (' The coefficients of the denominator matrix of the dual', $ ' system are ') 99996 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2)) 99995 FORMAT (//' The coefficients of the numerator matrix of the dual', $ ' system are ') 99994 FORMAT (/' M is out of range.',/' M = ',I5) 99993 FORMAT (/' P is out of range.',/' P = ',I5) 99992 FORMAT (/' INDLIM is out of range.',/' INDLIM = ',I5) END slicot-5.0+20101122/examples77/TTC04AD.f000077500000000000000000000104651201767322700167250ustar00rootroot00000000000000* TC04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KPCMAX, NMAX PARAMETER ( MMAX = 5, PMAX = 5, KPCMAX = 5, NMAX = 5 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDPCO1, LDPCO2, LDQCO1, LDQCO2, LDA, LDB, LDC, $ LDD PARAMETER ( LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP, $ LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP ) INTEGER LIWORK PARAMETER ( LIWORK = 2*MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = ( MAXMP )*( MAXMP+4 ) ) * .. Local Scalars .. DOUBLE PRECISION RCOND INTEGER I, INFO, J, K, KPCOEF, M, N, P, PORM, PORP CHARACTER*1 LERI LOGICAL LLERI * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), PCOEFF(LDPCO1,LDPCO2,KPCMAX), $ QCOEFF(LDQCO1,LDQCO2,KPCMAX), DWORK(LDWORK) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TC04AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, LERI LLERI = LSAME( LERI, 'L' ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99991 ) M ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE PORM = P IF ( .NOT.LLERI ) PORM = M READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM ) PORP = M IF ( .NOT.LLERI ) PORP = P KPCOEF = 0 DO 20 I = 1, PORM KPCOEF = MAX( KPCOEF, INDEX(I) ) 20 CONTINUE KPCOEF = KPCOEF + 1 IF ( KPCOEF.LE.0 .OR. KPCOEF.GT.KPCMAX ) THEN WRITE ( NOUT, FMT = 99989 ) KPCOEF ELSE READ ( NIN, FMT = * ) $ ( ( ( PCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORM ), $ I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( QCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORP ), $ I = 1,PORM ) * Find a ssr of the given left pmr. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) N, RCOND WRITE ( NOUT, FMT = 99996 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 80 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1,M ) 100 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TC04AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TC04AD = ',I2) 99997 FORMAT (' The order of the resulting state-space representation ', $ ' = ',I2,//' RCOND = ',F4.2) 99996 FORMAT (/' The state dynamics matrix A is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The input/state matrix B is ') 99993 FORMAT (/' The state/output matrix C is ') 99992 FORMAT (/' The direct transmission matrix D is ') 99991 FORMAT (/' M is out of range.',/' M = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) 99989 FORMAT (/' KPCOEF is out of range.',/' KPCOEF = ',I5) END slicot-5.0+20101122/examples77/TTC05AD.f000077500000000000000000000070311201767322700167210ustar00rootroot00000000000000* TC05AD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KPCMAX PARAMETER ( MMAX = 20, PMAX = 20, KPCMAX = 20 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2 PARAMETER ( LDCFRE = MAXMP, LDPCO1 = MAXMP, $ LDPCO2 = MAXMP, LDQCO1 = MAXMP, $ LDQCO2 = MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = 2*MAXMP ) INTEGER LZWORK PARAMETER ( LZWORK = ( MAXMP )*( MAXMP+2 ) ) * .. Local Scalars .. COMPLEX*16 SVAL DOUBLE PRECISION RCOND INTEGER I, INFO, J, K, KPCOEF, M, P, PORM, PORP CHARACTER*1 LERI LOGICAL LLERI * .. Local Arrays .. COMPLEX*16 CFREQR(LDCFRE,MAXMP), ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK), PCOEFF(LDPCO1,LDPCO2,KPCMAX), $ QCOEFF(LDQCO1,LDQCO2,KPCMAX) INTEGER INDEX(MAXMP), IWORK(MAXMP) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TC05AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, SVAL, LERI LLERI = LSAME( LERI, 'L' ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99995 ) M ELSE IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99994 ) P ELSE PORM = P IF ( .NOT.LLERI ) PORM = M READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM ) PORP = M IF ( .NOT.LLERI ) PORP = P KPCOEF = 0 DO 20 I = 1, PORM KPCOEF = MAX( KPCOEF, INDEX(I) ) 20 CONTINUE KPCOEF = KPCOEF + 1 IF ( KPCOEF.LE.0 .OR. KPCOEF.GT.KPCMAX ) THEN WRITE ( NOUT, FMT = 99993 ) KPCOEF ELSE READ ( NIN, FMT = * ) $ ( ( ( PCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORM ), $ I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( QCOEFF(I,J,K), K = 1,KPCOEF ), J = 1,PORP ), $ I = 1,PORM ) * Find the standard frequency response matrix of left pmr * at 0.5*j. CALL TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1, $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR, $ LDCFRE, IWORK, DWORK, ZWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) RCOND DO 40 I = 1, PORM WRITE ( NOUT, FMT = 99996 ) $ ( CFREQR(I,J), J = 1,PORP ) 40 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TC05AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TC05AD = ',I2) 99997 FORMAT (' RCOND = ',F4.2,//' The frequency response matrix T(SVA', $ 'L) is ') 99996 FORMAT (20(' (',F5.2,',',F5.2,') ',:)) 99995 FORMAT (/' M is out of range.',/' M = ',I5) 99994 FORMAT (/' P is out of range.',/' P = ',I5) 99993 FORMAT (/' KPCOEF is out of range.',/' KPCOEF = ',I5) END slicot-5.0+20101122/examples77/TTD03AD.f000077500000000000000000000153011201767322700167170ustar00rootroot00000000000000* TD03AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KDCMAX, NMAX PARAMETER ( MMAX = 8, PMAX = 8, KDCMAX = 8, NMAX = 8 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, LDPCO2, $ LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, LDVCO2 PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = MAXMP, $ LDD = MAXMP, LDDCOE = MAXMP, $ LDPCO1 = MAXMP, LDPCO2 = MAXMP, $ LDQCO1 = MAXMP, LDQCO2 = MAXMP, $ LDUCO1 = MAXMP, LDUCO2 = MAXMP, $ LDVCO1 = MAXMP, LDVCO2 = NMAX ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = ( NMAX + ( NMAX + 3*MAXMP ) + $ MAXMP*( MAXMP + 2 ) ) ) * .. Local Scalars .. DOUBLE PRECISION TOL CHARACTER*1 EQUIL, LERI, ROWCOL INTEGER I, INDBLK, INFO, J, K, KDCOEF, M, MAXINP, N, NR, $ P, PORMD, PORMP * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DCOEFF(LDDCOE,KDCMAX), $ DWORK(LDWORK), PCOEFF(LDPCO1,LDPCO2,NMAX+1), $ QCOEFF(LDQCO1,LDQCO2,NMAX+1), $ UCOEFF(LDUCO1,LDUCO2,KDCMAX), $ VCOEFF(LDVCO1,LDVCO2,NMAX+1) INTEGER INDEXD(MAXMP), INDEXP(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TD03AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, TOL, ROWCOL, LERI, EQUIL IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99986 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99985 ) P ELSE PORMD = P IF ( LSAME( ROWCOL, 'C' ) ) PORMD = M PORMP = M IF ( LSAME( LERI, 'R' ) ) PORMP = P READ ( NIN, FMT = * ) ( INDEXD(I), I = 1,PORMD ) * KDCOEF = 0 N = 0 DO 20 I = 1, PORMD KDCOEF = MAX( KDCOEF, INDEXD(I) ) N = N + INDEXD(I) 20 CONTINUE KDCOEF = KDCOEF + 1 * IF ( KDCOEF.LE.0 .OR. KDCOEF.GT.KDCMAX ) THEN WRITE ( NOUT, FMT = 99984 ) KDCOEF ELSE READ ( NIN, FMT = * ) $ ( ( DCOEFF(I,J), J = 1,KDCOEF ), I = 1,PORMD ) READ ( NIN, FMT = * ) $ ( ( ( UCOEFF(I,J,K), K = 1,KDCOEF ), J = 1,M ), I = 1,P ) * Find a relatively prime left pmr for the given transfer * function. CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 40 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 100 CONTINUE INDBLK = 0 DO 120 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 120 CONTINUE IF ( LSAME( LERI, 'L' ) ) THEN WRITE ( NOUT, FMT = 99992 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) WRITE ( NOUT, FMT = 99990 ) ( INDEXP(I), I = 1,P ) ELSE WRITE ( NOUT, FMT = 99991 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) WRITE ( NOUT, FMT = 99989 ) ( INDEXP(I), I = 1,M ) END IF MAXINP = 0 DO 140 I = 1, PORMP MAXINP = MAX( MAXINP, INDEXP(I) ) 140 CONTINUE MAXINP = MAXINP + 1 WRITE ( NOUT, FMT = 99988 ) DO 180 I = 1, PORMP DO 160 J = 1, PORMP WRITE ( NOUT, FMT = 99996 ) $ ( PCOEFF(I,J,K), K = 1,MAXINP ) 160 CONTINUE 180 CONTINUE WRITE ( NOUT, FMT = 99987 ) DO 220 I = 1, PORMP DO 200 J = 1, PORMD WRITE ( NOUT, FMT = 99996 ) $ ( QCOEFF(I,J,K), K = 1,MAXINP ) 200 CONTINUE 220 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TD03AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TD03AD = ',I2) 99997 FORMAT (' The order of the resulting minimal realization = ',I2, $ //' The state dynamics matrix A is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix B is ') 99994 FORMAT (/' The state/output matrix C is ') 99993 FORMAT (/' The direct transmission matrix D is ') 99992 FORMAT (/' The observability index of the minimal realization = ', $ I2,//' The dimensions of the diagonal blocks of the state', $ ' dynamics matrix are ',/20(I5)) 99991 FORMAT (/' The controllability index of the minimal realization ', $ '= ',I2,//' The dimensions of the diagonal blocks of the ', $ 'state dynamics matrix are ',/20(I5)) 99990 FORMAT (/' The row degrees of the denominator matrix P(s) are', $ /20(I5)) 99989 FORMAT (/' The column degrees of the denominator matrix P(s) are', $ /20(I5)) 99988 FORMAT (/' The denominator matrix P(s) is ') 99987 FORMAT (/' The numerator matrix Q(s) is ') 99986 FORMAT (/' M is out of range.',/' M = ',I5) 99985 FORMAT (/' P is out of range.',/' P = ',I5) 99984 FORMAT (/' KDCOEF is out of range.',/' KDCOEF = ',I5) END slicot-5.0+20101122/examples77/TTD04AD.f000077500000000000000000000117441201767322700167270ustar00rootroot00000000000000* TD04AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, PMAX, KDCMAX, NMAX PARAMETER ( MMAX = 10, PMAX = 10, KDCMAX = 10, NMAX = 10 ) INTEGER MAXMP PARAMETER ( MAXMP = ( MMAX + PMAX ) ) INTEGER LDDCOE, LDUCO1, LDUCO2, LDA, LDB, LDC, LDD PARAMETER ( LDDCOE = MAXMP, LDUCO1 = MAXMP, $ LDUCO2 = MAXMP, LDA = NMAX, LDB = NMAX, $ LDC = MAXMP, LDD = MAXMP ) INTEGER LIWORK PARAMETER ( LIWORK = NMAX + MAXMP ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX + ( NMAX + 3*MAXMP ) ) * .. Local Scalars .. DOUBLE PRECISION TOL INTEGER I, INDBLK, INFO, J, K, KDCOEF, M, N, NR, P, PORM CHARACTER*1 ROWCOL LOGICAL LROWCO * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX), $ D(LDD,MAXMP), DCOEFF(LDDCOE,KDCMAX), $ DWORK(LDWORK), UCOEFF(LDUCO1,LDUCO2,KDCMAX) INTEGER INDEX(MAXMP), IWORK(LIWORK) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TD04AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, P, TOL, ROWCOL LROWCO = LSAME( ROWCOL, 'R' ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99989 ) P ELSE PORM = P IF ( .NOT.LROWCO ) PORM = M READ ( NIN, FMT = * ) ( INDEX(I), I = 1,PORM ) * N = 0 KDCOEF = 0 DO 20 I = 1, PORM N = N + INDEX(I) KDCOEF = MAX( KDCOEF, INDEX(I) ) 20 CONTINUE KDCOEF = KDCOEF + 1 * IF ( KDCOEF.LE.0 .OR. KDCOEF.GT.KDCMAX ) THEN WRITE ( NOUT, FMT = 99988 ) KDCOEF ELSE READ ( NIN, FMT = * ) $ ( ( DCOEFF(I,J), J = 1,KDCOEF ), I = 1,PORM ) READ ( NIN, FMT = * ) $ ( ( ( UCOEFF(I,J,K), K = 1,KDCOEF ), J = 1,M ), I = 1,P ) * Find a minimal state-space representation (A,B,C,D). CALL TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, $ LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D, $ LDD, TOL, IWORK, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NR DO 40 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR ) 40 CONTINUE WRITE ( NOUT, FMT = 99995 ) DO 60 I = 1, NR WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M ) 60 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 80 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR ) 80 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 100 I = 1, P WRITE ( NOUT, FMT = 99996 ) ( D(I,J), J = 1,M ) 100 CONTINUE INDBLK = 0 DO 120 I = 1, N IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1 120 CONTINUE IF ( LROWCO ) THEN WRITE ( NOUT, FMT = 99992 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) ELSE WRITE ( NOUT, FMT = 99991 ) INDBLK, $ ( IWORK(I), I = 1,INDBLK ) END IF END IF END IF END IF STOP * 99999 FORMAT (' TD04AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TD04AD = ',I2) 99997 FORMAT (' The order of the minimal realization = ',I2,//' The st', $ 'ate dynamics matrix A of a minimal realization is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' The input/state matrix B of a minimal realization is ') 99994 FORMAT (/' The state/output matrix C of a minimal realization is ' $ ) 99993 FORMAT (/' The direct transmission matrix D is ') 99992 FORMAT (/' The observability index of a minimal state-space repr', $ 'esentation = ',I2,//' The dimensions of the diagonal blo', $ 'cks of the state dynamics matrix are',/20(1X,I2)) 99991 FORMAT (/' The controllability index of a minimal state-space re', $ 'presentation = ',I2,//' The dimensions of the diagonal b', $ 'locks of the state dynamics matrix are',/20(1X,I2)) 99990 FORMAT (/' M is out of range.',/' M = ',I5) 99989 FORMAT (/' P is out of range.',/' P = ',I5) 99988 FORMAT (/' KDCOEF is out of range.',/' KDCOEF = ',I5) END slicot-5.0+20101122/examples77/TTD05AD.f000077500000000000000000000040651201767322700167260ustar00rootroot00000000000000* TD05AD EXAMPLE PROGRAM TEXT. * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NP1MAX, MP1MAX PARAMETER ( NP1MAX = 20, MP1MAX = 20 ) * .. Local Scalars .. DOUBLE PRECISION VALI, VALR, W INTEGER I, INFO, MP1, NP1 CHARACTER*1 UNITF, OUTPUT * .. Local Arrays .. DOUBLE PRECISION A(NP1MAX), B(MP1MAX) * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL TD05AD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NP1, MP1, W, UNITF, OUTPUT IF ( NP1.LE.0 .OR. NP1.GT.NP1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP1 ELSE READ ( NIN, FMT = * ) ( A(I), I = 1,NP1 ) IF ( MP1.LE.0 .OR. MP1.GT.MP1MAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP1 ELSE READ ( NIN, FMT = * ) ( B(I), I = 1,MP1 ) * Find the real and imaginary parts of G(jW), where * W = 1.0 radian. CALL TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE IF ( LSAME( OUTPUT, 'C' ) ) THEN WRITE ( NOUT, FMT = 99997 ) VALR, VALI ELSE WRITE ( NOUT, FMT = 99996 ) VALR, VALI END IF END IF END IF END IF STOP * 99999 FORMAT (' TD05AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TD05AD = ',I2) 99997 FORMAT (' Complex value of G(jW) = ',F8.4,1X,F8.4,'*j') 99996 FORMAT (' Magnitude of G(jW) = ',F8.4,' dBs, Phase of G(jW) = ', $ F8.4,' degrees ') 99995 FORMAT (/' NP1 is out of range.',/' NP1 = ',I5) 99994 FORMAT (/' MP1 is out of range.',/' MP1 = ',I5) END slicot-5.0+20101122/examples77/TTF01MD.f000077500000000000000000000057401201767322700167410ustar00rootroot00000000000000* TF01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NYMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, NYMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDU, LDY PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDD = PMAX, $ LDU = MMAX, LDY = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, M, N, NY, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), U(LDU,NYMAX), $ X(NMAX), Y(LDY,NYMAX) * .. External Subroutines .. EXTERNAL TF01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NY IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N ) READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M ) READ ( NIN, FMT = * ) ( X(I), I = 1,N ) IF ( NY.LE.0 .OR. NY.GT.NYMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NY ELSE READ ( NIN, FMT = * ) $ ( ( U(I,J), I = 1,M ), J = 1,NY ) * Compute y(1),...,y(NY) of the given system. CALL TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, $ LDD, U, LDU, X, Y, LDY, DWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NY DO 20 K = 1, NY WRITE ( NOUT, FMT = 99996 ) K, Y(1,K) WRITE ( NOUT, FMT = 99995 ) ( Y(J,K), J = 2,P ) 20 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TF01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01MD = ',I2) 99997 FORMAT (' The output sequence Y(1),...,Y(',I2,') is',/) 99996 FORMAT (' Y(',I2,') : ',F8.4) 99995 FORMAT (9X,F8.4,/) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' NY is out of range.',/' NY = ',I5) END slicot-5.0+20101122/examples77/TTF01ND.f000077500000000000000000000060471201767322700167430ustar00rootroot00000000000000* TF01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX, NYMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20, NYMAX = 20 ) INTEGER LDA, LDB, LDC, LDD, LDU, LDY PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDD = PMAX, LDU = MMAX, LDY = PMAX ) INTEGER LDWORK PARAMETER ( LDWORK = NMAX ) * .. Local Scalars .. CHARACTER*1 UPLO INTEGER I, INFO, J, K, M, N, NY, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ D(LDD,MMAX), DWORK(LDWORK), U(LDU,NYMAX), $ X(NMAX), Y(LDY,NYMAX) * .. External Subroutines .. EXTERNAL TF01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, NY, UPLO IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N ) IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99993 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M ) IF ( P.LE.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99992 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,P ), J = 1,N ) READ ( NIN, FMT = * ) ( ( D(I,J), I = 1,P ), J = 1,M ) READ ( NIN, FMT = * ) ( X(I), I = 1,N ) IF ( NY.LE.0 .OR. NY.GT.NYMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NY ELSE READ ( NIN, FMT = * ) $ ( ( U(I,J), I = 1,M ), J = 1,NY ) * Compute y(1),...,y(NY) of the given system. CALL TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, $ LDC, D, LDD, U, LDU, X, Y, LDY, DWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) NY DO 20 K = 1, NY WRITE ( NOUT, FMT = 99996 ) K, Y(1,K) WRITE ( NOUT, FMT = 99995 ) ( Y(J,K), J = 2,P ) 20 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TF01ND EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01ND = ',I2) 99997 FORMAT (' The output sequence Y(1),...,Y(',I2,') is',/) 99996 FORMAT (' Y(',I2,') : ',F8.4) 99995 FORMAT (9X,F8.4,/) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' M is out of range.',/' M = ',I5) 99992 FORMAT (/' P is out of range.',/' P = ',I5) 99991 FORMAT (/' NY is out of range.',/' NY = ',I5) END slicot-5.0+20101122/examples77/TTF01OD.f000077500000000000000000000043011201767322700167330ustar00rootroot00000000000000* TF01OD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NH1MAX, NH2MAX, NRMAX, NCMAX PARAMETER ( NH1MAX = 20, NH2MAX = 20, NRMAX = 20, $ NCMAX = 20 ) INTEGER LDH, LDT PARAMETER ( LDH = NH1MAX, LDT = NH1MAX*NRMAX ) * .. Local Scalars .. INTEGER I, INFO, J, NC, NCT, NH1, NH2, NR, NRT * .. Local Arrays .. DOUBLE PRECISION H(LDH,(NRMAX+NCMAX-1)*NH2MAX), $ T(LDT,NH2MAX*NCMAX) * .. External Subroutines .. EXTERNAL TF01OD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NH1, NH2, NR, NC IF ( NH1.LE.0 .OR. NH1.GE.NH1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) NH1 ELSE IF ( NH2.LE.0 .OR. NH2.GT.NH2MAX ) THEN WRITE ( NOUT, FMT = 99994 ) NH2 ELSE IF ( NR.LE.0 .OR. NR.GT.NRMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NR ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NC ELSE READ ( NIN, FMT = * ) $ ( ( H(I,J), I = 1,NH1 ), J = 1,( NR+NC-1 )*NH2 ) * Construct the NRT by NCT block Hankel expansion of M(k). CALL TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE NRT = NH1*NR NCT = NH2*NC WRITE ( NOUT, FMT = 99997 ) NRT, NCT DO 20 I = 1, NRT WRITE ( NOUT, FMT = 99996 ) ( T(I,J), J = 1,NCT ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' TF01OD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01OD = ',I2) 99997 FORMAT (' The ',I2,' by ',I2,' matrix T is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' NH1 is out of range.',/' NH1 = ',I5) 99994 FORMAT (/' NH2 is out of range.',/' NH2 = ',I5) 99993 FORMAT (/' NR is out of range.',/' NR = ',I5) 99992 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples77/TTF01PD.f000077500000000000000000000043031201767322700167360ustar00rootroot00000000000000* TF01PD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NH1MAX, NH2MAX, NRMAX, NCMAX PARAMETER ( NH1MAX = 20, NH2MAX = 20, NRMAX = 20, $ NCMAX = 20 ) INTEGER LDH, LDT PARAMETER ( LDH = NH1MAX, LDT = NH1MAX*NRMAX ) * .. Local Scalars .. INTEGER I, INFO, J, NC, NCT, NH1, NH2, NR, NRT * .. Local Arrays .. DOUBLE PRECISION H(LDH,(NRMAX+NCMAX-1)*NH2MAX), $ T(LDT,NH2MAX*NCMAX) * .. External Subroutines .. EXTERNAL TF01PD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) NH1, NH2, NR, NC IF ( NH1.LE.0 .OR. NH1.GE.NH1MAX ) THEN WRITE ( NOUT, FMT = 99995 ) NH1 ELSE IF ( NH2.LE.0 .OR. NH2.GT.NH2MAX ) THEN WRITE ( NOUT, FMT = 99994 ) NH2 ELSE IF ( NR.LE.0 .OR. NR.GT.NRMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NR ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NC ELSE READ ( NIN, FMT = * ) $ ( ( H(I,J), I = 1,NH1 ), J = 1,( NR+NC-1 )*NH2 ) * Construct the NRT by NCT block Toeplitz expansion of M(k). CALL TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE NRT = NH1*NR NCT = NH2*NC WRITE ( NOUT, FMT = 99997 ) NRT, NCT DO 20 I = 1, NRT WRITE ( NOUT, FMT = 99996 ) ( T(I,J), J = 1,NCT ) 20 CONTINUE END IF END IF STOP * 99999 FORMAT (' TF01PD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01PD = ',I2) 99997 FORMAT (' The ',I2,' by ',I2,' matrix T is ') 99996 FORMAT (20(1X,F8.4)) 99995 FORMAT (/' NH1 is out of range.',/' NH1 = ',I5) 99994 FORMAT (/' NH2 is out of range.',/' NH2 = ',I5) 99993 FORMAT (/' NR is out of range.',/' NR = ',I5) 99992 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples77/TTF01QD.f000077500000000000000000000057541201767322700167520ustar00rootroot00000000000000* TF01QD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NAMAX, NBMAX, NCMAX PARAMETER ( NMAX = 20, NAMAX = 20, NBMAX = 20, NCMAX = 20 ) INTEGER LDH PARAMETER ( LDH = NCMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, L, N, NA, NASUM, NB, NC, NL, NORD LOGICAL ERROR * .. Local Arrays .. DOUBLE PRECISION AR(NAMAX), H(LDH,NMAX*NBMAX), MA(NAMAX) INTEGER IORD(NCMAX*NBMAX) * .. External Subroutines .. EXTERNAL TF01QD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NA, NB, NC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( NA.LE.0 .OR. NA.GT.NAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NA ELSE IF ( NB.LE.0 .OR. NB.GT.NBMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NB ELSE IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NC ELSE ERROR = .FALSE. NL = 0 K = 1 NASUM = 0 DO 40 I = 1, NC DO 20 J = 1, NB READ ( NIN, FMT = * ) NORD NASUM = NASUM + NORD IF ( NA.GE.NASUM ) THEN READ ( NIN, FMT = * ) ( MA(NL+L), L = 1,NORD ) READ ( NIN, FMT = * ) ( AR(NL+L), L = 1,NORD ) IORD(K) = NORD K = K + 1 NL = NL + NORD ELSE WRITE ( NOUT, FMT = 99993 ) NA ERROR = .TRUE. END IF 20 CONTINUE 40 CONTINUE IF ( .NOT. ERROR ) THEN * Compute M(1),...,M(N) from the given transfer function * matrix G(z). CALL TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) N DO 80 K = 1, N WRITE ( NOUT, FMT = 99996 ) K, $ ( H(1,(K-1)*NB+J), J = 1,NB ) DO 60 I = 2, NC WRITE ( NOUT, FMT = 99995 ) $ ( H(I,(K-1)*NB+J), J = 1,NB ) 60 CONTINUE 80 CONTINUE END IF END IF END IF STOP * 99999 FORMAT (' TF01QD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01QD = ',I2) 99997 FORMAT (' The Markov Parameters M(1),...,M(',I1,') are ') 99996 FORMAT (/' M(',I1,') : ',20(1X,F8.4)) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' NA is out of range.',/' NA = ',I5) 99992 FORMAT (/' NB is out of range.',/' NB = ',I5) 99991 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples77/TTF01RD.f000077500000000000000000000054401201767322700167430ustar00rootroot00000000000000* TF01RD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, NAMAX, NBMAX, NCMAX PARAMETER ( NMAX = 20, NAMAX = 20, NBMAX = 20, NCMAX = 20 ) INTEGER LDA, LDB, LDC, LDH PARAMETER ( LDA = NAMAX, LDB = NAMAX, LDC = NCMAX, $ LDH = NCMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NAMAX*NCMAX ) * .. Local Scalars .. INTEGER I, INFO, J, K, N, NA, NB, NC * .. Local Arrays .. DOUBLE PRECISION A(LDA,NAMAX), B(LDB,NBMAX), C(LDC,NAMAX), $ H(LDH,NMAX*NBMAX), DWORK(LDWORK) * .. External Subroutines .. EXTERNAL TF01RD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, NA, NB, NC IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99994 ) N ELSE IF ( NA.LE.0 .OR. NA.GT.NAMAX ) THEN WRITE ( NOUT, FMT = 99993 ) NA ELSE READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,NA ), J = 1,NA ) IF ( NB.LE.0 .OR. NB.GT.NBMAX ) THEN WRITE ( NOUT, FMT = 99992 ) NB ELSE READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,NA ), J = 1,NB ) IF ( NC.LE.0 .OR. NC.GT.NCMAX ) THEN WRITE ( NOUT, FMT = 99991 ) NC ELSE READ ( NIN, FMT = * ) ( ( C(I,J), I = 1,NC ), J = 1,NA ) * Compute M(1),...,M(N) from the system (A,B,C). CALL TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, $ LDH, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) N DO 40 K = 1, N WRITE ( NOUT, FMT = 99996 ) K, $ ( H(1,(K-1)*NB+J), J = 1,NB ) DO 20 I = 2, NC WRITE ( NOUT, FMT = 99995 ) $ ( H(I,(K-1)*NB+J), J = 1,NB ) 20 CONTINUE 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TF01RD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TF01RD = ',I2) 99997 FORMAT (' The Markov Parameters M(1),...,M(',I1,') are ') 99996 FORMAT (/' M(',I1,') : ',20(1X,F8.4)) 99995 FORMAT (8X,20(1X,F8.4)) 99994 FORMAT (/' N is out of range.',/' N = ',I5) 99993 FORMAT (/' NA is out of range.',/' NA = ',I5) 99992 FORMAT (/' NB is out of range.',/' NB = ',I5) 99991 FORMAT (/' NC is out of range.',/' NC = ',I5) END slicot-5.0+20101122/examples77/TTG01AD.f000077500000000000000000000120241201767322700167170ustar00rootroot00000000000000* TG01AD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + 3*(LMAX+NMAX ) ) ) * .. Local Scalars .. CHARACTER*1 JOBS INTEGER I, INFO, J, L, M, N, P DOUBLE PRECISION ABCNRM, ENORM, SABCNM, SENORM, THRESH * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), LSCALE(LMAX), $ RSCALE(NMAX) * .. External Functions .. DOUBLE PRECISION DLANGE EXTERNAL DLANGE * .. External Subroutines .. EXTERNAL TG01AD * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, JOBS, THRESH IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Compute norms before scaling ABCNRM = MAX( DLANGE( '1', L, N, A, LDA, DWORK ), $ DLANGE( '1', L, M, B, LDB, DWORK ), $ DLANGE( '1', P, N, C, LDC, DWORK ) ) ENORM = DLANGE( '1', L, N, E, LDE, DWORK ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL TG01AD( JOBS, L, N, M, P, THRESH, A, LDA, E, LDE, $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE SABCNM = MAX( DLANGE( '1', L, N, A, LDA, DWORK ), $ DLANGE( '1', L, M, B, LDB, DWORK ), $ DLANGE( '1', P, N, C, LDC, DWORK ) ) SENORM = DLANGE( '1', L, N, E, LDE, DWORK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99995 ) ( LSCALE(I), I = 1,L ) WRITE ( NOUT, FMT = 99990 ) WRITE ( NOUT, FMT = 99995 ) ( RSCALE(J), J = 1,N ) WRITE ( NOUT, FMT = 99994 ) $ ABCNRM, SABCNM, ENORM, SENORM END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01AD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01AD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Dl*A*Dr is ') 99996 FORMAT (/' The transformed descriptor matrix Dl*E*Dr is ') 99995 FORMAT (20(1X,F9.4)) 99994 FORMAT (/' Norm of [ A B; C 0] =', 1PD10.3/ $ ' Norm of scaled [ A B; C 0] =', 1PD10.3/ $ ' Norm of E =', 1PD10.3/ $ ' Norm of scaled E =', 1PD10.3) 99993 FORMAT (/' The transformed input/state matrix Dl*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Dr is ') 99991 FORMAT (/' The diagonal of left scaling matrix Dl is ') 99990 FORMAT (/' The diagonal of right scaling matrix Dr is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTG01AZ.f000077500000000000000000000120651201767322700167520ustar00rootroot00000000000000* TG01AZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 3*(LMAX+NMAX ) ) * .. Local Scalars .. CHARACTER*1 JOBS INTEGER I, INFO, J, L, M, N, P DOUBLE PRECISION ABCNRM, ENORM, SABCNM, SENORM, THRESH * .. Local Arrays .. COMPLEX*16 A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ E(LDE,NMAX) DOUBLE PRECISION DWORK(LDWORK), LSCALE(LMAX), RSCALE(NMAX) * .. External Functions .. DOUBLE PRECISION ZLANGE EXTERNAL ZLANGE * .. External Subroutines .. EXTERNAL TG01AZ * .. Intrinsic Functions .. INTRINSIC MAX * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, JOBS, THRESH IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Compute norms before scaling ABCNRM = MAX( ZLANGE( '1', L, N, A, LDA, DWORK ), $ ZLANGE( '1', L, M, B, LDB, DWORK ), $ ZLANGE( '1', P, N, C, LDC, DWORK ) ) ENORM = ZLANGE( '1', L, N, E, LDE, DWORK ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL TG01AZ( JOBS, L, N, M, P, THRESH, A, LDA, E, LDE, $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, $ INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE SABCNM = MAX( ZLANGE( '1', L, N, A, LDA, DWORK ), $ ZLANGE( '1', L, M, B, LDB, DWORK ), $ ZLANGE( '1', P, N, C, LDC, DWORK ) ) SENORM = ZLANGE( '1', L, N, E, LDE, DWORK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) WRITE ( NOUT, FMT = 99985 ) ( LSCALE(I), I = 1,L ) WRITE ( NOUT, FMT = 99990 ) WRITE ( NOUT, FMT = 99985 ) ( RSCALE(J), J = 1,N ) WRITE ( NOUT, FMT = 99994 ) $ ABCNRM, SABCNM, ENORM, SENORM END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01AZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01AZ = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Dl*A*Dr is ') 99996 FORMAT (/' The transformed descriptor matrix Dl*E*Dr is ') 99995 FORMAT (20(1X,F9.4,SP,F9.4,S,'i ')) 99994 FORMAT (/' Norm of [ A B; C 0] =', 1PD10.3/ $ ' Norm of scaled [ A B; C 0] =', 1PD10.3/ $ ' Norm of E =', 1PD10.3/ $ ' Norm of scaled E =', 1PD10.3) 99993 FORMAT (/' The transformed input/state matrix Dl*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Dr is ') 99991 FORMAT (/' The diagonal of left scaling matrix Dl is ') 99990 FORMAT (/' The diagonal of right scaling matrix Dr is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) 99985 FORMAT (20(1X,F9.4)) END slicot-5.0+20101122/examples77/TTG01CD.f000077500000000000000000000061471201767322700167320ustar00rootroot00000000000000* TG01CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20) INTEGER LDA, LDB, LDE, LDQ PARAMETER ( LDA = LMAX, LDB = LMAX, $ LDE = LMAX, LDQ = LMAX ) INTEGER LDWORK PARAMETER ( LDWORK = (LMAX+NMAX)+(LMAX+NMAX+MMAX) ) * .. Local Scalars .. CHARACTER*1 COMPQ INTEGER I, INFO, J, L, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX) * .. External Subroutines .. EXTERNAL TG01CD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M COMPQ = 'I' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99990 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) * Find the transformed descriptor system pair * (A-lambda E,B). CALL TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, $ Q, LDQ, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01CD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01CD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The transformed input/state matrix Q''*B is ') 99993 FORMAT (/' The left transformation matrix Q is ') 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TTG01DD.f000077500000000000000000000061401201767322700167240ustar00rootroot00000000000000* TG01DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, PMAX = 20) INTEGER LDA, LDC, LDE, LDZ PARAMETER ( LDA = LMAX, LDC = PMAX, $ LDE = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = (LMAX+NMAX)+(LMAX+NMAX+PMAX) ) * .. Local Scalars .. CHARACTER*1 COMPZ INTEGER I, INFO, J, L, N, P * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01DD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, P COMPZ = 'I' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99992 ) L ELSE IF( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99991 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99990 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system pair * (A-lambda E,B). CALL TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, $ Z, LDZ, DWORK, LDWORK, INFO ) * IF( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99994 ) DO 30 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 40 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01DD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01DD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (/' The transformed input/state matrix C*Z is ') 99993 FORMAT (/' The right transformation matrix Z is ') 99992 FORMAT (/' L is out of range.',/' L = ',I5) 99991 FORMAT (/' N is out of range.',/' N = ',I5) 99990 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTG01ED.f000077500000000000000000000107031201767322700167250ustar00rootroot00000000000000* TG01ED EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + ( LMAX + NMAX ) + $ ( MMAX + PMAX + 3*( LMAX + NMAX ) + $ ( LMAX + NMAX ) + $ 5*( LMAX + NMAX ) ) ) ) * .. Local Scalars .. CHARACTER*1 JOBA INTEGER I, INFO, J, L, M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01ED * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL JOBA = 'R' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, $ TOL, DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22 WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01ED EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01ED = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Rank of matrix E =', I5/ $ ' Rank of matrix A22 =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTG01FD.f000077500000000000000000000107211201767322700167260ustar00rootroot00000000000000* TG01FD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + PMAX + $ (LMAX + NMAX)+( 3*NMAX + MMAX + LMAX ) ) ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBA INTEGER I, INFO, J, L, M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01FD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL COMPQ = 'I' COMPZ = 'I' JOBA = 'R' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22 WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01FD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01FD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Rank of matrix E =', I5/ $ ' Rank of matrix A22 =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTG01FZ.f000077500000000000000000000111441201767322700167540ustar00rootroot00000000000000* TG01FZ EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = 2*NMAX ) INTEGER LZWORK PARAMETER ( LZWORK = 4*NMAX + 2*LMAX + PMAX + MMAX ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBA INTEGER I, INFO, J, L, M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(NMAX) COMPLEX*16 A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ E(LDE,NMAX), Q(LDQ,LMAX), Z(LDZ,NMAX), $ ZWORK(LZWORK) DOUBLE PRECISION DWORK(LDWORK) * .. External Subroutines .. EXTERNAL TG01FZ * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) L, N, M, P, TOL COMPQ = 'I' COMPZ = 'I' JOBA = 'R' IF ( L.LT.0 .OR. L.GT.LMAX ) THEN WRITE ( NOUT, FMT = 99989 ) L ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,L ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system * (A-lambda E,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) RANKE, RNKA22 WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, L WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,L ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01FZ EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01FZ = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4,SP,F8.4,S,'i ')) 99994 FORMAT (' Rank of matrix E =', I5/ $ ' Rank of matrix A22 =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TTG01HD.f000077500000000000000000000106001201767322700167240ustar00rootroot00000000000000* TG01HD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = PMAX, $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + NMAX + 2*MMAX ) ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBCO INTEGER I, INFO, J, M, N, NCONT, NIUCON, NRBLCK, P DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(MMAX), RTAU(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01HD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBCO COMPQ = 'I' COMPZ = 'I' IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system (A-lambda E,B,C). CALL TG01HD( JOBCO, 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NCONT, NIUCON WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99984 ) ( RTAU(I), I = 1,NRBLCK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01HD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01HD = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Dimension of controllable part =', I5/ $ ' Number of uncontrollable infinite eigenvalues =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) 99985 FORMAT (/' The staircase form row dimensions are ' ) 99984 FORMAT (10I5) END slicot-5.0+20101122/examples77/TTG01ID.f000077500000000000000000000107311201767322700167320ustar00rootroot00000000000000* TG01ID EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER LMAX, NMAX, MMAX, PMAX PARAMETER ( LMAX = 20, NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER MPMX PARAMETER ( MPMX = ( MMAX + PMAX ) ) INTEGER LDA, LDB, LDC, LDE, LDQ, LDZ PARAMETER ( LDA = LMAX, LDB = LMAX, LDC = (MMAX + PMAX), $ LDE = LMAX, LDQ = LMAX, LDZ = NMAX ) INTEGER LDWORK PARAMETER ( LDWORK = ( 1 + NMAX + 2*PMAX ) ) * .. Local Scalars .. CHARACTER*1 COMPQ, COMPZ, JOBOBS INTEGER I, INFO, J, M, N, NOBSV, NIUOBS, NLBLCK, P DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER IWORK(MMAX), CTAU(NMAX) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MPMX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX), Q(LDQ,LMAX), $ Z(LDZ,NMAX) * .. External Subroutines .. EXTERNAL TG01ID * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOBOBS COMPQ = 'I' COMPZ = 'I' IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the transformed descriptor system (A-lambda E,B,C). CALL 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 ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NOBSV, NIUOBS WRITE ( NOUT, FMT = 99985 ) WRITE ( NOUT, FMT = 99984 ) ( CTAU(I), I = 1,NLBLCK ) WRITE ( NOUT, FMT = 99997 ) DO 10 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N ) 10 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 20 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N ) 20 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 30 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 30 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 40 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N ) 40 CONTINUE WRITE ( NOUT, FMT = 99991 ) DO 50 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Q(I,J), J = 1,N ) 50 CONTINUE WRITE ( NOUT, FMT = 99990 ) DO 60 I = 1, N WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N ) 60 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01ID EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01ID = ',I2) 99997 FORMAT (/' The transformed state dynamics matrix Q''*A*Z is ') 99996 FORMAT (/' The transformed descriptor matrix Q''*E*Z is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Dimension of observable part =', I5/ $ ' Number of unobservable infinite eigenvalues =', I5) 99993 FORMAT (/' The transformed input/state matrix Q''*B is ') 99992 FORMAT (/' The transformed state/output matrix C*Z is ') 99991 FORMAT (/' The left transformation matrix Q is ') 99990 FORMAT (/' The right transformation matrix Z is ') 99989 FORMAT (/' L is out of range.',/' L = ',I5) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) 99985 FORMAT (/' The staircase form column dimensions are ' ) 99984 FORMAT (10I5) END slicot-5.0+20101122/examples77/TTG01JD.f000077500000000000000000000074411201767322700167370ustar00rootroot00000000000000* TG01JD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NMAX, MMAX, PMAX PARAMETER ( NMAX = 20, MMAX = 20, PMAX = 20 ) INTEGER LDA, LDB, LDC, LDE PARAMETER ( LDA = NMAX, LDB = NMAX, LDC = PMAX, $ LDE = NMAX ) INTEGER LDWORK, LIWORK PARAMETER ( LDWORK = ( 8*NMAX + 2*MMAX ), $ LIWORK = NMAX + ( MMAX + PMAX ) ) * .. Local Scalars .. CHARACTER EQUIL, JOB, SYSTYP INTEGER I, INFO, J, M, N, NR, P DOUBLE PRECISION TOL * .. Local Arrays .. INTEGER INFRED(7), IWORK(LIWORK) DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX), $ DWORK(LDWORK), E(LDE,NMAX) * .. External Subroutines .. EXTERNAL TG01JD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) N, M, P, TOL, JOB, SYSTYP, EQUIL IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99988 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N ) READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N ) IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99987 ) M ELSE READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N ) IF ( P.LT.0 .OR. P.GT.PMAX ) THEN WRITE ( NOUT, FMT = 99986 ) P ELSE READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P ) * Find the irreducible descriptor system (Ar-lambda Er,Br,Cr). CALL TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE, $ B, LDB, C, LDC, NR, INFRED, TOL, IWORK, $ DWORK, LDWORK, INFO ) * IF ( INFO.NE.0 ) THEN WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99994 ) NR WRITE ( NOUT, FMT = 99991 ) DO 10 I = 1, 4 IF( INFRED(I).GE.0 ) $ WRITE ( NOUT, FMT = 99990 ) I, INFRED(I) 10 CONTINUE WRITE ( NOUT, FMT = 99997 ) DO 20 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR ) 20 CONTINUE WRITE ( NOUT, FMT = 99996 ) DO 30 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,NR ) 30 CONTINUE WRITE ( NOUT, FMT = 99993 ) DO 40 I = 1, NR WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M ) 40 CONTINUE WRITE ( NOUT, FMT = 99992 ) DO 50 I = 1, P WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR ) 50 CONTINUE END IF END IF END IF END IF STOP * 99999 FORMAT (' TG01JD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from TG01JD = ',I2) 99997 FORMAT (/' The reduced state dynamics matrix Ar is ') 99996 FORMAT (/' The reduced descriptor matrix Er is ') 99995 FORMAT (20(1X,F8.4)) 99994 FORMAT (' Order of reduced system =', I5 ) 99993 FORMAT (/' The reduced input/state matrix Br is ') 99992 FORMAT (/' The reduced state/output matrix Cr is ') 99991 FORMAT (/' Achieved order reductions in different phases') 99990 FORMAT (' Phase',I2,':', I3, ' elliminated eigenvalue(s)' ) 99988 FORMAT (/' N is out of range.',/' N = ',I5) 99987 FORMAT (/' M is out of range.',/' M = ',I5) 99986 FORMAT (/' P is out of range.',/' P = ',I5) END slicot-5.0+20101122/examples77/TUD01BD.f000077500000000000000000000037021201767322700167210ustar00rootroot00000000000000* UD01BD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MPMAX, NPMAX, DPMAX PARAMETER ( MPMAX = 10, NPMAX = 10, DPMAX = 5 ) INTEGER LDP1, LDP2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX ) * .. Local Scalars .. INTEGER DP, INFO, L, MP, NP * .. Local Arrays .. DOUBLE PRECISION P(LDP1,LDP2,DPMAX) * .. External Subroutines .. EXTERNAL UD01BD, UD01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, 99996 ) MP, NP, DP * Write the coefficients of the matrix polynomial P(s). L = 5 CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, ' P', $ INFO ) IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99997 ) INFO ELSE WRITE ( NOUT, FMT = 99998 ) INFO END IF END IF STOP * 99999 FORMAT (' UD01BD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01BD = ',I2) 99997 FORMAT (' INFO on exit from UD01ND = ',I2) 99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2) 99995 FORMAT (/' NP is out of range.',/' NP = ',I5) 99994 FORMAT (/' MP is out of range.',/' MP = ',I5) 99993 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples77/TUD01CD.f000077500000000000000000000037301201767322700167230ustar00rootroot00000000000000* UD01CD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MPMAX, NPMAX, DPMAX PARAMETER ( MPMAX = 10, NPMAX = 10, DPMAX = 5 ) INTEGER LDP1, LDP2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX ) * .. Local Scalars .. INTEGER DP, INFO, INFO1, L, MP, NP * .. Local Arrays .. DOUBLE PRECISION P(LDP1,LDP2,DPMAX) * .. External Subroutines .. EXTERNAL UD01CD, UD01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) IF ( INFO.GE.0 ) THEN WRITE ( NOUT, 99996 ) MP, NP, DP * Write the coefficients of the matrix polynomial P(s). L = 5 CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, ' P', $ INFO1 ) IF ( INFO1.NE.0 ) $ WRITE ( NOUT, FMT = 99997 ) INFO1 END IF IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO END IF STOP * 99999 FORMAT (' UD01CD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01CD = ',I2) 99997 FORMAT (' INFO on exit from UD01ND = ',I2) 99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2) 99995 FORMAT (/' NP is out of range.',/' NP = ',I5) 99994 FORMAT (/' MP is out of range.',/' MP = ',I5) 99993 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples77/TUD01DD.f000077500000000000000000000030641201767322700167240ustar00rootroot00000000000000* UD01DD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 10, NMAX = 10 ) INTEGER LDA PARAMETER ( LDA = NMAX ) * .. Local Scalars .. INTEGER INFO, INFO1, M, N * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX) * .. External Subroutines .. EXTERNAL UD01DD, UD01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N IF ( M.LT.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99994 ) M ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99995 ) N ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01DD( M, N, NIN, A, LDA, INFO ) IF ( INFO.GE.0 ) THEN * Write the matrix A. CALL UD01MD( M, N, 5, NOUT, A, LDA, ' Matrix A', INFO1 ) IF ( INFO1.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO1 END IF IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99997 ) INFO END IF STOP * 99999 FORMAT (' UD01DD EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01MD = ',I2) 99997 FORMAT (' INFO on exit from UD01DD = ',I2) 99995 FORMAT (/' N is out of range.',/' N = ',I5) 99994 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TUD01MD.f000077500000000000000000000025371201767322700167410ustar00rootroot00000000000000* UD01MD EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MMAX, NMAX PARAMETER ( MMAX = 20, NMAX = 20 ) INTEGER LDA PARAMETER ( LDA = MMAX ) * .. Local Scalars .. INTEGER I, INFO, J, L, M, N CHARACTER*72 TEXT * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX) * .. External Subroutines .. EXTERNAL UD01MD * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) M, N, L, TEXT IF ( M.LE.0 .OR. M.GT.MMAX ) THEN WRITE ( NOUT, FMT = 99996 ) M ELSE IF ( N.LE.0 .OR. N.GT.NMAX ) THEN WRITE ( NOUT, FMT = 99997 ) N ELSE READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M ) * Print out the matrix A. CALL UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) IF ( INFO.NE.0 ) WRITE ( NOUT, FMT = 99998 ) INFO END IF STOP * 99999 FORMAT (' UD01MD EXAMPLE PROGRAM RESULTS',/1X) 99998 FORMAT (' INFO on exit from UD01MD = ',I2) 99997 FORMAT (/' N is out of range.',/' N = ',I5) 99996 FORMAT (/' M is out of range.',/' M = ',I5) END slicot-5.0+20101122/examples77/TUD01ND.f000077500000000000000000000037251201767322700167420ustar00rootroot00000000000000* UD01ND EXAMPLE PROGRAM TEXT * Copyright (c) 2002-2010 NICONET e.V. * * .. Parameters .. INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER MPMAX, NPMAX, DPMAX PARAMETER ( MPMAX = 10, NPMAX = 10, DPMAX = 5 ) INTEGER LDP1, LDP2 PARAMETER ( LDP1 = MPMAX, LDP2 = NPMAX ) * .. Local Scalars .. INTEGER DP, INFO, L, MP, NP CHARACTER*72 TEXT * .. Local Arrays .. DOUBLE PRECISION P(LDP1,LDP2,DPMAX) * .. External Subroutines .. EXTERNAL UD01BD, UD01ND * .. Executable Statements .. * WRITE ( NOUT, FMT = 99999 ) * Skip the heading in the data file and read the data. READ ( NIN, FMT = '()' ) READ ( NIN, FMT = * ) MP, NP, DP, L, TEXT IF ( MP.LE.0 .OR. MP.GT.MPMAX ) THEN WRITE ( NOUT, FMT = 99994 ) MP ELSE IF ( NP.LE.0 .OR. NP.GT.NPMAX ) THEN WRITE ( NOUT, FMT = 99995 ) NP ELSE IF ( DP.LT.0 .OR. DP.GT.DPMAX ) THEN WRITE ( NOUT, FMT = 99993 ) DP ELSE * Read the coefficients of the matrix polynomial P(s). CALL UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) IF ( INFO.EQ.0 ) THEN WRITE ( NOUT, 99996 ) MP, NP, DP * Write the coefficients of the matrix polynomial P(s). CALL UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, $ INFO ) IF ( INFO.NE.0 ) $ WRITE ( NOUT, FMT = 99998 ) INFO ELSE WRITE ( NOUT, FMT = 99997 ) INFO END IF END IF STOP * 99999 FORMAT (' UD01ND EXAMPLE PROGRAM RESULTS', /1X) 99998 FORMAT (' INFO on exit from UD01ND = ',I2) 99997 FORMAT (' INFO on exit from UD01BD = ',I2) 99996 FORMAT (' MP =', I2, 2X, ' NP =', I2, 3X, 'DP =', I2) 99995 FORMAT (/' NP is out of range.',/' NP = ',I5) 99994 FORMAT (/' MP is out of range.',/' MP = ',I5) 99993 FORMAT (/' DP is out of range.',/' DP = ',I5) END slicot-5.0+20101122/examples77/UD01BD.dat000077500000000000000000000005671201767322700171260ustar00rootroot00000000000000UD01BD EXAMPLE PROGRAM DATA 4 3 2 P0 1.0D-00 0.0D-00 0.0D-00 0.0D-00 2.0D-00 4.0D-00 0.0D-00 4.0D-00 8.0D-00 0.0D-00 6.0D-00 1.2D+01 P1 0.0D-00 1.0D-00 2.0D-00 1.0D-00 0.0D-00 0.0D-00 2.0D-00 0.0D-00 0.0D-00 3.0D-00 0.0D-00 0.0D-00 P2 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 slicot-5.0+20101122/examples77/UD01BD.res000077500000000000000000000015301201767322700171360ustar00rootroot00000000000000 UD01BD EXAMPLE PROGRAM RESULTS MP = 4 NP = 3 DP = 2 P( 0) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.2000000D+01 0.4000000D+01 3 0.0000000D+00 0.4000000D+01 0.8000000D+01 4 0.0000000D+00 0.6000000D+01 0.1200000D+02 P( 1) ( 4X 3) 1 2 3 1 0.0000000D+00 0.1000000D+01 0.2000000D+01 2 0.1000000D+01 0.0000000D+00 0.0000000D+00 3 0.2000000D+01 0.0000000D+00 0.0000000D+00 4 0.3000000D+01 0.0000000D+00 0.0000000D+00 P( 2) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 slicot-5.0+20101122/examples77/UD01CD.dat000077500000000000000000000001621201767322700171160ustar00rootroot00000000000000UD01CD EXAMPLE PROGRAM DATA 4 3 2 1 1 1 1.0 1.0 2 2 2 2.0 0.0 1.0 3 3 2 0.0 3.0 1.0 4 1 0 4.0 slicot-5.0+20101122/examples77/UD01CD.res000077500000000000000000000015301201767322700171370ustar00rootroot00000000000000 UD01CD EXAMPLE PROGRAM RESULTS MP = 4 NP = 3 DP = 2 P( 0) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.2000000D+01 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 4 0.4000000D+01 0.0000000D+00 0.0000000D+00 P( 1) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.3000000D+01 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 P( 2) ( 4X 3) 1 2 3 1 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.1000000D+01 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.1000000D+01 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 slicot-5.0+20101122/examples77/UD01DD.dat000077500000000000000000000002431201767322700171170ustar00rootroot00000000000000UD01DD EXAMPLE PROGRAM DATA 6 5 1 1 -1.1 6 1 1.5 2 2 -2.2 6 2 2.5 3 3 -3.3 6 3 3.5 4 4 -4.4 6 4 4.5 5 5 -5.5 6 5 5.5 slicot-5.0+20101122/examples77/UD01DD.res000077500000000000000000000011471201767322700171440ustar00rootroot00000000000000 UD01DD EXAMPLE PROGRAM RESULTS Matrix A ( 6X 5) 1 2 3 4 5 1 -0.1100000D+01 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 -0.2200000D+01 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 -0.3300000D+01 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.4400000D+01 0.0000000D+00 5 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.5500000D+01 6 0.1500000D+01 0.2500000D+01 0.3500000D+01 0.4500000D+01 0.5500000D+01 slicot-5.0+20101122/examples77/UD01MD.dat000077500000000000000000000002411201767322700171260ustar00rootroot00000000000000 UD01MD EXAMPLE PROGRAM DATA 4 4 4 'Matrix A' 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 slicot-5.0+20101122/examples77/UD01MD.res000077500000000000000000000005711201767322700171550ustar00rootroot00000000000000 UD01MD EXAMPLE PROGRAM RESULTS Matrix A ( 4X 4) 1 2 3 4 1 0.1000000D+01 0.2000000D+01 0.3000000D+01 0.4000000D+01 2 0.5000000D+01 0.6000000D+01 0.7000000D+01 0.8000000D+01 3 0.9000000D+01 0.1000000D+02 0.1100000D+02 0.1200000D+02 4 0.1300000D+02 0.1400000D+02 0.1500000D+02 0.1600000D+02 slicot-5.0+20101122/examples77/UD01ND.dat000077500000000000000000000006041201767322700171320ustar00rootroot00000000000000UD01ND EXAMPLE PROGRAM DATA 4 3 2 5 P P0 1.0D-00 0.0D-00 0.0D-00 0.0D-00 2.0D-00 4.0D-00 0.0D-00 4.0D-00 8.0D-00 0.0D-00 6.0D-00 1.2D+01 P1 0.0D-00 1.0D-00 2.0D-00 1.0D-00 0.0D-00 0.0D-00 2.0D-00 0.0D-00 0.0D-00 3.0D-00 0.0D-00 0.0D-00 P2 1.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 0.0D-00 slicot-5.0+20101122/examples77/UD01ND.res000077500000000000000000000015251201767322700171560ustar00rootroot00000000000000 UD01ND EXAMPLE PROGRAM RESULTS MP = 4 NP = 3 DP = 2 P( 0) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.2000000D+01 0.4000000D+01 3 0.0000000D+00 0.4000000D+01 0.8000000D+01 4 0.0000000D+00 0.6000000D+01 0.1200000D+02 P( 1) ( 4X 3) 1 2 3 1 0.0000000D+00 0.1000000D+01 0.2000000D+01 2 0.1000000D+01 0.0000000D+00 0.0000000D+00 3 0.2000000D+01 0.0000000D+00 0.0000000D+00 4 0.3000000D+01 0.0000000D+00 0.0000000D+00 P( 2) ( 4X 3) 1 2 3 1 0.1000000D+01 0.0000000D+00 0.0000000D+00 2 0.0000000D+00 0.0000000D+00 0.0000000D+00 3 0.0000000D+00 0.0000000D+00 0.0000000D+00 4 0.0000000D+00 0.0000000D+00 0.0000000D+00 slicot-5.0+20101122/examples77/makefile000077500000000000000000001373121201767322700172540ustar00rootroot00000000000000#################################################################### # SLICOT examples makefile # # Makefile for generating and running SLICOT Library example # # programs on Unix machines. # # SLICOT, Release 5.0 ./slicot/examples/makefile # # Vasile Sima, KU Leuven # # October 31, 1996. # # Revised December 7, 1999, Jan. 8 2009. # #################################################################### # # This makefile compiles, links, and runs the example programs for # the SLICOT Library on Unix machines. # # The example programs can be executed for double precision only. # To compile, link, and run the example programs, enter 'make'. # The executable files are created in the current directory level. # The files with the results have the extension .exa, and are also # created in the current directory level, so they can automatically be # compared with the .res files provided in this directory. Note that, # for some programs, the signs of some matrix elements could differ; # this does not mean erroneous results. # # To remove the .exa files after the programs have been run, enter # make clean # # To remove the .exa files, as well as the executable programs, enter # make cleanup # # To re-run specific programs after a make, enter (for example): # 'rm TAB01MD; make' or: # 'make TAB01MD' or: # 'touch AB01MD.dat; make' (to re-run the TAB01MD program). # # 'rm TAB01*D; make' (to re-run all programs of section AB01). # #################################################################### include ../make.inc all: AB01MD.exa AB01ND.exa AB01OD.exa AB04MD.exa AB05MD.exa AB05ND.exa \ AB05OD.exa AB05PD.exa AB05QD.exa AB05RD.exa AB07MD.exa AB07ND.exa \ AB08ND.exa AB09AD.exa AB09BD.exa AB09CD.exa AB09DD.exa AB09ED.exa \ AB09FD.exa AB09GD.exa AB09HD.exa AB09ID.exa AB09JD.exa AB09KD.exa \ AB09MD.exa AB09ND.exa AB13AD.exa AB13BD.exa AB13CD.exa AB13DD.exa \ AB13ED.exa AB13FD.exa AB13MD.exa AG08BD.exa \ BB01AD.exa BB02AD.exa BB03AD.exa BB04AD.exa BD01AD.exa BD02AD.exa \ DE01OD.exa DE01PD.exa DF01MD.exa DG01MD.exa DG01ND.exa DG01OD.exa \ DK01MD.exa \ FB01QD.exa FB01RD.exa FB01SD.exa FB01TD.exa FB01VD.exa FD01AD.exa \ IB01AD.exa IB01BD.exa IB01CD.exa IB03AD.exa IB03BD.exa \ MB01TD.exa MB02CD.exa MB02DD.exa MB02ED.exa MB02FD.exa MB02GD.exa \ MB02HD.exa MB02ID.exa MB02JD.exa MB02JX.exa MB02KD.exa MB02MD.exa \ MB02ND.exa MB02QD.exa MB02SD.exa MB02VD.exa MB03MD.exa MB03ND.exa \ MB03OD.exa MB03PD.exa MB03QD.exa MB03RD.exa MB03SD.exa MB03UD.exa \ MB03VD.exa MB03WD.exa MB04DY.exa MB04GD.exa MB04MD.exa MB04OD.exa \ MB04UD.exa MB04VD.exa MB04XD.exa MB04YD.exa MB04ZD.exa MB05MD.exa \ MB05ND.exa MB05OD.exa MC01MD.exa MC01ND.exa MC01OD.exa MC01PD.exa \ MC01QD.exa MC01RD.exa MC01SD.exa MC01TD.exa MC01VD.exa MC01WD.exa \ MC03MD.exa MC03ND.exa \ MD03AD.exa MD03BD.exa \ SB01BD.exa SB01DD.exa SB01MD.exa SB02MD.exa SB02ND.exa SB02OD.exa \ SB02PD.exa SB02QD.exa SB02RD.exa SB02SD.exa SB03MD.exa SB03OD.exa \ SB03QD.exa SB03SD.exa SB03TD.exa SB03UD.exa SB04MD.exa SB04ND.exa \ SB04OD.exa SB04PD.exa SB04QD.exa SB04RD.exa SB06ND.exa SB08CD.exa \ SB08DD.exa SB08ED.exa SB08FD.exa SB08MD.exa SB08ND.exa SB09MD.exa \ SB10DD.exa SB10ED.exa SB10FD.exa SB10HD.exa SB10ID.exa SB10KD.exa \ SB10ZD.exa SB16AD.exa SB16BD.exa SB16CD.exa SG02AD.exa SG03AD.exa \ SG03BD.exa \ TB01ID.exa TB01KD.exa TB01LD.exa TB01MD.exa TB01ND.exa TB01PD.exa \ TB01TD.exa TB01UD.exa TB01WD.exa TB01ZD.exa TB03AD.exa TB04AD.exa \ TB04BD.exa TB04CD.exa TB05AD.exa TC01OD.exa TC04AD.exa TC05AD.exa \ TD03AD.exa TD04AD.exa TD05AD.exa TF01MD.exa TF01ND.exa TF01OD.exa \ TF01PD.exa TF01QD.exa TF01RD.exa TG01AD.exa TG01CD.exa TG01DD.exa \ TG01ED.exa TG01FD.exa TG01HD.exa TG01ID.exa TG01JD.exa \ UD01BD.exa UD01CD.exa UD01DD.exa UD01MD.exa UD01ND.exa \ MB03TD.exa MB03XD.exa MB03XP.exa MB03ZD.exa MB04DD.exa \ MB04DS.exa MB04PB.exa MB04PU.exa MB04TB.exa MB04TS.exa \ AB08NZ.exa AG08BZ.exa TB01IZ.exa TG01AZ.exa TG01FZ.exa \ MB03BD.exa MB03KD.exa MB03LD.exa MB04AD.exa MB04BD.exa AB01MD.exa: AB01MD.dat TAB01MD; ./TAB01MD AB01MD.exa AB01ND.exa: AB01ND.dat TAB01ND; ./TAB01ND AB01ND.exa AB01OD.exa: AB01OD.dat TAB01OD; ./TAB01OD AB01OD.exa AB04MD.exa: AB04MD.dat TAB04MD; ./TAB04MD AB04MD.exa AB05MD.exa: AB05MD.dat TAB05MD; ./TAB05MD AB05MD.exa AB05ND.exa: AB05ND.dat TAB05ND; ./TAB05ND AB05ND.exa AB05OD.exa: AB05OD.dat TAB05OD; ./TAB05OD AB05OD.exa AB05PD.exa: AB05PD.dat TAB05PD; ./TAB05PD AB05PD.exa AB05QD.exa: AB05QD.dat TAB05QD; ./TAB05QD AB05QD.exa AB05RD.exa: AB05RD.dat TAB05RD; ./TAB05RD AB05RD.exa AB07MD.exa: AB07MD.dat TAB07MD; ./TAB07MD AB07MD.exa AB07ND.exa: AB07ND.dat TAB07ND; ./TAB07ND AB07ND.exa AB08ND.exa: AB08ND.dat TAB08ND; ./TAB08ND AB08ND.exa AB09AD.exa: AB09AD.dat TAB09AD; ./TAB09AD AB09AD.exa AB09BD.exa: AB09BD.dat TAB09BD; ./TAB09BD AB09BD.exa AB09CD.exa: AB09CD.dat TAB09CD; ./TAB09CD AB09CD.exa AB09DD.exa: AB09DD.dat TAB09DD; ./TAB09DD AB09DD.exa AB09ED.exa: AB09ED.dat TAB09ED; ./TAB09ED AB09ED.exa AB09FD.exa: AB09FD.dat TAB09FD; ./TAB09FD AB09FD.exa AB09GD.exa: AB09GD.dat TAB09GD; ./TAB09GD AB09GD.exa AB09HD.exa: AB09HD.dat TAB09HD; ./TAB09HD AB09HD.exa AB09ID.exa: AB09ID.dat TAB09ID; ./TAB09ID AB09ID.exa AB09JD.exa: AB09JD.dat TAB09JD; ./TAB09JD AB09JD.exa AB09KD.exa: AB09KD.dat TAB09KD; ./TAB09KD AB09KD.exa AB09MD.exa: AB09MD.dat TAB09MD; ./TAB09MD AB09MD.exa AB09ND.exa: AB09ND.dat TAB09ND; ./TAB09ND AB09ND.exa AB13AD.exa: AB13AD.dat TAB13AD; ./TAB13AD AB13AD.exa AB13BD.exa: AB13BD.dat TAB13BD; ./TAB13BD AB13BD.exa AB13CD.exa: AB13CD.dat TAB13CD; ./TAB13CD AB13CD.exa AB13DD.exa: AB13DD.dat TAB13DD; ./TAB13DD AB13DD.exa AB13ED.exa: AB13ED.dat TAB13ED; ./TAB13ED AB13ED.exa AB13FD.exa: AB13FD.dat TAB13FD; ./TAB13FD AB13FD.exa AB13MD.exa: AB13MD.dat TAB13MD; ./TAB13MD AB13MD.exa AG08BD.exa: AG08BD.dat TAG08BD; ./TAG08BD AG08BD.exa BB01AD.exa: BB01AD.dat TBB01AD; ./TBB01AD BB01AD.exa BB02AD.exa: BB02AD.dat TBB02AD; ./TBB02AD BB02AD.exa BB03AD.exa: BB03AD.dat TBB03AD; ./TBB03AD BB03AD.exa BB04AD.exa: BB04AD.dat TBB04AD; ./TBB04AD BB04AD.exa BD01AD.exa: BD01AD.dat TBD01AD; ./TBD01AD BD01AD.exa BD02AD.exa: BD02AD.dat TBD02AD; ./TBD02AD BD02AD.exa DE01OD.exa: DE01OD.dat TDE01OD; ./TDE01OD DE01OD.exa DE01PD.exa: DE01PD.dat TDE01PD; ./TDE01PD DE01PD.exa DF01MD.exa: DF01MD.dat TDF01MD; ./TDF01MD DF01MD.exa DG01MD.exa: DG01MD.dat TDG01MD; ./TDG01MD DG01MD.exa DG01ND.exa: DG01ND.dat TDG01ND; ./TDG01ND DG01ND.exa DG01OD.exa: DG01OD.dat TDG01OD; ./TDG01OD DG01OD.exa DK01MD.exa: DK01MD.dat TDK01MD; ./TDK01MD DK01MD.exa FB01QD.exa: FB01QD.dat TFB01QD; ./TFB01QD FB01QD.exa FB01RD.exa: FB01RD.dat TFB01RD; ./TFB01RD FB01RD.exa FB01SD.exa: FB01SD.dat TFB01SD; ./TFB01SD FB01SD.exa FB01TD.exa: FB01TD.dat TFB01TD; ./TFB01TD FB01TD.exa FB01VD.exa: FB01VD.dat TFB01VD; ./TFB01VD FB01VD.exa FD01AD.exa: FD01AD.dat TFD01AD; ./TFD01AD FD01AD.exa IB01AD.exa: IB01AD.dat TIB01AD; ./TIB01AD IB01AD.exa IB01BD.exa: IB01BD.dat TIB01BD; ./TIB01BD IB01BD.exa IB01CD.exa: IB01CD.dat TIB01CD; ./TIB01CD IB01CD.exa IB03AD.exa: IB03AD.dat TIB03AD; ./TIB03AD IB03AD.exa IB03BD.exa: IB03BD.dat TIB03BD; ./TIB03BD IB03BD.exa MB01TD.exa: MB01TD.dat TMB01TD; ./TMB01TD MB01TD.exa MB02CD.exa: MB02CD.dat TMB02CD; ./TMB02CD MB02CD.exa MB02DD.exa: MB02DD.dat TMB02DD; ./TMB02DD MB02DD.exa MB02ED.exa: MB02ED.dat TMB02ED; ./TMB02ED MB02ED.exa MB02FD.exa: MB02FD.dat TMB02FD; ./TMB02FD MB02FD.exa MB02GD.exa: MB02GD.dat TMB02GD; ./TMB02GD MB02GD.exa MB02HD.exa: MB02HD.dat TMB02HD; ./TMB02HD MB02HD.exa MB02ID.exa: MB02ID.dat TMB02ID; ./TMB02ID MB02ID.exa MB02JD.exa: MB02JD.dat TMB02JD; ./TMB02JD MB02JD.exa MB02JX.exa: MB02JX.dat TMB02JX; ./TMB02JX MB02JX.exa MB02KD.exa: MB02KD.dat TMB02KD; ./TMB02KD MB02KD.exa MB02MD.exa: MB02MD.dat TMB02MD; ./TMB02MD MB02MD.exa MB02ND.exa: MB02ND.dat TMB02ND; ./TMB02ND MB02ND.exa MB02QD.exa: MB02QD.dat TMB02QD; ./TMB02QD MB02QD.exa MB02SD.exa: MB02SD.dat TMB02SD; ./TMB02SD MB02SD.exa MB02VD.exa: MB02VD.dat TMB02VD; ./TMB02VD MB02VD.exa MB03MD.exa: MB03MD.dat TMB03MD; ./TMB03MD MB03MD.exa MB03ND.exa: MB03ND.dat TMB03ND; ./TMB03ND MB03ND.exa MB03OD.exa: MB03OD.dat TMB03OD; ./TMB03OD MB03OD.exa MB03PD.exa: MB03PD.dat TMB03PD; ./TMB03PD MB03PD.exa MB03QD.exa: MB03QD.dat TMB03QD; ./TMB03QD MB03QD.exa MB03RD.exa: MB03RD.dat TMB03RD; ./TMB03RD MB03RD.exa MB03SD.exa: MB03SD.dat TMB03SD; ./TMB03SD MB03SD.exa MB03UD.exa: MB03UD.dat TMB03UD; ./TMB03UD MB03UD.exa MB03VD.exa: MB03VD.dat TMB03VD; ./TMB03VD MB03VD.exa MB03WD.exa: MB03WD.dat TMB03WD; ./TMB03WD MB03WD.exa MB04DY.exa: MB04DY.dat TMB04DY; ./TMB04DY MB04DY.exa MB04GD.exa: MB04GD.dat TMB04GD; ./TMB04GD MB04GD.exa MB04MD.exa: MB04MD.dat TMB04MD; ./TMB04MD MB04MD.exa MB04OD.exa: MB04OD.dat TMB04OD; ./TMB04OD MB04OD.exa MB04UD.exa: MB04UD.dat TMB04UD; ./TMB04UD MB04UD.exa MB04VD.exa: MB04VD.dat TMB04VD; ./TMB04VD MB04VD.exa MB04XD.exa: MB04XD.dat TMB04XD; ./TMB04XD MB04XD.exa MB04YD.exa: MB04YD.dat TMB04YD; ./TMB04YD MB04YD.exa MB04ZD.exa: MB04ZD.dat TMB04ZD; ./TMB04ZD MB04ZD.exa MB05MD.exa: MB05MD.dat TMB05MD; ./TMB05MD MB05MD.exa MB05ND.exa: MB05ND.dat TMB05ND; ./TMB05ND MB05ND.exa MB05OD.exa: MB05OD.dat TMB05OD; ./TMB05OD MB05OD.exa MC01MD.exa: MC01MD.dat TMC01MD; ./TMC01MD MC01MD.exa MC01ND.exa: MC01ND.dat TMC01ND; ./TMC01ND MC01ND.exa MC01OD.exa: MC01OD.dat TMC01OD; ./TMC01OD MC01OD.exa MC01PD.exa: MC01PD.dat TMC01PD; ./TMC01PD MC01PD.exa MC01QD.exa: MC01QD.dat TMC01QD; ./TMC01QD MC01QD.exa MC01RD.exa: MC01RD.dat TMC01RD; ./TMC01RD MC01RD.exa MC01SD.exa: MC01SD.dat TMC01SD; ./TMC01SD MC01SD.exa MC01TD.exa: MC01TD.dat TMC01TD; ./TMC01TD MC01TD.exa MC01VD.exa: MC01VD.dat TMC01VD; ./TMC01VD MC01VD.exa MC01WD.exa: MC01WD.dat TMC01WD; ./TMC01WD MC01WD.exa MC03MD.exa: MC03MD.dat TMC03MD; ./TMC03MD MC03MD.exa MC03ND.exa: MC03ND.dat TMC03ND; ./TMC03ND MC03ND.exa MD03AD.exa: MD03AD.dat TMD03AD; ./TMD03AD MD03AD.exa MD03BD.exa: MD03BD.dat TMD03BD; ./TMD03BD MD03BD.exa SB01BD.exa: SB01BD.dat TSB01BD; ./TSB01BD SB01BD.exa SB01DD.exa: SB01DD.dat TSB01DD; ./TSB01DD SB01DD.exa SB01MD.exa: SB01MD.dat TSB01MD; ./TSB01MD SB01MD.exa SB02MD.exa: SB02MD.dat TSB02MD; ./TSB02MD SB02MD.exa SB02ND.exa: SB02ND.dat TSB02ND; ./TSB02ND SB02ND.exa SB02OD.exa: SB02OD.dat TSB02OD; ./TSB02OD SB02OD.exa SB02PD.exa: SB02PD.dat TSB02PD; ./TSB02PD SB02PD.exa SB02QD.exa: SB02QD.dat TSB02QD; ./TSB02QD SB02QD.exa SB02RD.exa: SB02RD.dat TSB02RD; ./TSB02RD SB02RD.exa SB02SD.exa: SB02SD.dat TSB02SD; ./TSB02SD SB02SD.exa SB03MD.exa: SB03MD.dat TSB03MD; ./TSB03MD SB03MD.exa SB03OD.exa: SB03OD.dat TSB03OD; ./TSB03OD SB03OD.exa SB03QD.exa: SB03QD.dat TSB03QD; ./TSB03QD SB03QD.exa SB03SD.exa: SB03SD.dat TSB03SD; ./TSB03SD SB03SD.exa SB03TD.exa: SB03TD.dat TSB03TD; ./TSB03TD SB03TD.exa SB03UD.exa: SB03UD.dat TSB03UD; ./TSB03UD SB03UD.exa SB04MD.exa: SB04MD.dat TSB04MD; ./TSB04MD SB04MD.exa SB04ND.exa: SB04ND.dat TSB04ND; ./TSB04ND SB04ND.exa SB04OD.exa: SB04OD.dat TSB04OD; ./TSB04OD SB04OD.exa SB04PD.exa: SB04PD.dat TSB04PD; ./TSB04PD SB04PD.exa SB04QD.exa: SB04QD.dat TSB04QD; ./TSB04QD SB04QD.exa SB04RD.exa: SB04RD.dat TSB04RD; ./TSB04RD SB04RD.exa SB06ND.exa: SB06ND.dat TSB06ND; ./TSB06ND SB06ND.exa SB08CD.exa: SB08CD.dat TSB08CD; ./TSB08CD SB08CD.exa SB08DD.exa: SB08DD.dat TSB08DD; ./TSB08DD SB08DD.exa SB08ED.exa: SB08ED.dat TSB08ED; ./TSB08ED SB08ED.exa SB08FD.exa: SB08FD.dat TSB08FD; ./TSB08FD SB08FD.exa SB08MD.exa: SB08MD.dat TSB08MD; ./TSB08MD SB08MD.exa SB08ND.exa: SB08ND.dat TSB08ND; ./TSB08ND SB08ND.exa SB09MD.exa: SB09MD.dat TSB09MD; ./TSB09MD SB09MD.exa SB10DD.exa: SB10DD.dat TSB10DD; ./TSB10DD SB10DD.exa SB10ED.exa: SB10ED.dat TSB10ED; ./TSB10ED SB10ED.exa SB10FD.exa: SB10FD.dat TSB10FD; ./TSB10FD SB10FD.exa SB10HD.exa: SB10HD.dat TSB10HD; ./TSB10HD SB10HD.exa SB10ID.exa: SB10ID.dat TSB10ID; ./TSB10ID SB10ID.exa SB10KD.exa: SB10KD.dat TSB10KD; ./TSB10KD SB10KD.exa SB10ZD.exa: SB10ZD.dat TSB10ZD; ./TSB10ZD SB10ZD.exa SB16AD.exa: SB16AD.dat TSB16AD; ./TSB16AD SB16AD.exa SB16BD.exa: SB16BD.dat TSB16BD; ./TSB16BD SB16BD.exa SB16CD.exa: SB16CD.dat TSB16CD; ./TSB16CD SB16CD.exa SG02AD.exa: SG02AD.dat TSG02AD; ./TSG02AD SG02AD.exa SG03AD.exa: SG03AD.dat TSG03AD; ./TSG03AD SG03AD.exa SG03BD.exa: SG03BD.dat TSG03BD; ./TSG03BD SG03BD.exa TB01ID.exa: TB01ID.dat TTB01ID; ./TTB01ID TB01ID.exa TB01KD.exa: TB01KD.dat TTB01KD; ./TTB01KD TB01KD.exa TB01LD.exa: TB01LD.dat TTB01LD; ./TTB01LD TB01LD.exa TB01MD.exa: TB01MD.dat TTB01MD; ./TTB01MD TB01MD.exa TB01ND.exa: TB01ND.dat TTB01ND; ./TTB01ND TB01ND.exa TB01PD.exa: TB01PD.dat TTB01PD; ./TTB01PD TB01PD.exa TB01TD.exa: TB01TD.dat TTB01TD; ./TTB01TD TB01TD.exa TB01UD.exa: TB01UD.dat TTB01UD; ./TTB01UD TB01UD.exa TB01WD.exa: TB01WD.dat TTB01WD; ./TTB01WD TB01WD.exa TB01ZD.exa: TB01ZD.dat TTB01ZD; ./TTB01ZD TB01ZD.exa TB03AD.exa: TB03AD.dat TTB03AD; ./TTB03AD TB03AD.exa TB04AD.exa: TB04AD.dat TTB04AD; ./TTB04AD TB04AD.exa TB04BD.exa: TB04BD.dat TTB04BD; ./TTB04BD TB04BD.exa TB04CD.exa: TB04CD.dat TTB04CD; ./TTB04CD TB04CD.exa TB05AD.exa: TB05AD.dat TTB05AD; ./TTB05AD TB05AD.exa TC01OD.exa: TC01OD.dat TTC01OD; ./TTC01OD TC01OD.exa TC04AD.exa: TC04AD.dat TTC04AD; ./TTC04AD TC04AD.exa TC05AD.exa: TC05AD.dat TTC05AD; ./TTC05AD TC05AD.exa TD03AD.exa: TD03AD.dat TTD03AD; ./TTD03AD TD03AD.exa TD04AD.exa: TD04AD.dat TTD04AD; ./TTD04AD TD04AD.exa TD05AD.exa: TD05AD.dat TTD05AD; ./TTD05AD TD05AD.exa TF01MD.exa: TF01MD.dat TTF01MD; ./TTF01MD TF01MD.exa TF01ND.exa: TF01ND.dat TTF01ND; ./TTF01ND TF01ND.exa TF01OD.exa: TF01OD.dat TTF01OD; ./TTF01OD TF01OD.exa TF01PD.exa: TF01PD.dat TTF01PD; ./TTF01PD TF01PD.exa TF01QD.exa: TF01QD.dat TTF01QD; ./TTF01QD TF01QD.exa TF01RD.exa: TF01RD.dat TTF01RD; ./TTF01RD TF01RD.exa TG01AD.exa: TG01AD.dat TTG01AD; ./TTG01AD TG01AD.exa TG01CD.exa: TG01CD.dat TTG01CD; ./TTG01CD TG01CD.exa TG01DD.exa: TG01DD.dat TTG01DD; ./TTG01DD TG01DD.exa TG01ED.exa: TG01ED.dat TTG01ED; ./TTG01ED TG01ED.exa TG01FD.exa: TG01FD.dat TTG01FD; ./TTG01FD TG01FD.exa TG01HD.exa: TG01HD.dat TTG01HD; ./TTG01HD TG01HD.exa TG01ID.exa: TG01ID.dat TTG01ID; ./TTG01ID TG01ID.exa TG01JD.exa: TG01JD.dat TTG01JD; ./TTG01JD TG01JD.exa UD01BD.exa: UD01BD.dat TUD01BD; ./TUD01BD UD01BD.exa UD01CD.exa: UD01CD.dat TUD01CD; ./TUD01CD UD01CD.exa UD01DD.exa: UD01DD.dat TUD01DD; ./TUD01DD UD01DD.exa UD01MD.exa: UD01MD.dat TUD01MD; ./TUD01MD UD01MD.exa UD01ND.exa: UD01ND.dat TUD01ND; ./TUD01ND UD01ND.exa MB03TD.exa: MB03TD.dat TMB03TD; ./TMB03TD MB03TD.exa MB03XD.exa: MB03XD.dat TMB03XD; ./TMB03XD MB03XD.exa MB03XP.exa: MB03XP.dat TMB03XP; ./TMB03XP MB03XP.exa MB03ZD.exa: MB03ZD.dat TMB03ZD; ./TMB03ZD MB03ZD.exa MB04DD.exa: MB04DD.dat TMB04DD; ./TMB04DD MB04DD.exa MB04DS.exa: MB04DS.dat TMB04DS; ./TMB04DS MB04DS.exa MB04PB.exa: MB04PB.dat TMB04PB; ./TMB04PB MB04PB.exa MB04PU.exa: MB04PU.dat TMB04PU; ./TMB04PU MB04PU.exa MB04TB.exa: MB04TB.dat TMB04TB; ./TMB04TB MB04TB.exa MB04TS.exa: MB04TS.dat TMB04TS; ./TMB04TS MB04TS.exa AB08NZ.exa: AB08NZ.dat TAB08NZ; ./TAB08NZ AB08NZ.exa AG08BZ.exa: AG08BZ.dat TAG08BZ; ./TAG08BZ AG08BZ.exa TB01IZ.exa: TB01IZ.dat TTB01IZ; ./TTB01IZ TB01IZ.exa TG01AZ.exa: TG01AZ.dat TTG01AZ; ./TTG01AZ TG01AZ.exa TG01FZ.exa: TG01FZ.dat TTG01FZ; ./TTG01FZ TG01FZ.exa MB03BD.exa: MB03BD.dat TMB03BD; ./TMB03BD MB03BD.exa MB03KD.exa: MB03KD.dat TMB03KD; ./TMB03KD MB03KD.exa MB03LD.exa: MB03LD.dat TMB03LD; ./TMB03LD MB03LD.exa MB04AD.exa: MB04AD.dat TMB04AD; ./TMB04AD MB04AD.exa MB04BD.exa: MB04BD.dat TMB04BD; ./TMB04BD MB04BD.exa TAB01MD: TAB01MD.o ; $(LOADER) -o TAB01MD TAB01MD.o $(LOADOPTS) TAB01ND: TAB01ND.o ; $(LOADER) -o TAB01ND TAB01ND.o $(LOADOPTS) TAB01OD: TAB01OD.o ; $(LOADER) -o TAB01OD TAB01OD.o $(LOADOPTS) TAB04MD: TAB04MD.o ; $(LOADER) -o TAB04MD TAB04MD.o $(LOADOPTS) TAB05MD: TAB05MD.o ; $(LOADER) -o TAB05MD TAB05MD.o $(LOADOPTS) TAB05ND: TAB05ND.o ; $(LOADER) -o TAB05ND TAB05ND.o $(LOADOPTS) TAB05OD: TAB05OD.o ; $(LOADER) -o TAB05OD TAB05OD.o $(LOADOPTS) TAB05PD: TAB05PD.o ; $(LOADER) -o TAB05PD TAB05PD.o $(LOADOPTS) TAB05QD: TAB05QD.o ; $(LOADER) -o TAB05QD TAB05QD.o $(LOADOPTS) TAB05RD: TAB05RD.o ; $(LOADER) -o TAB05RD TAB05RD.o $(LOADOPTS) TAB07MD: TAB07MD.o ; $(LOADER) -o TAB07MD TAB07MD.o $(LOADOPTS) TAB07ND: TAB07ND.o ; $(LOADER) -o TAB07ND TAB07ND.o $(LOADOPTS) TAB08ND: TAB08ND.o ; $(LOADER) -o TAB08ND TAB08ND.o $(LOADOPTS) TAB09AD: TAB09AD.o ; $(LOADER) -o TAB09AD TAB09AD.o $(LOADOPTS) TAB09BD: TAB09BD.o ; $(LOADER) -o TAB09BD TAB09BD.o $(LOADOPTS) TAB09CD: TAB09CD.o ; $(LOADER) -o TAB09CD TAB09CD.o $(LOADOPTS) TAB09DD: TAB09DD.o ; $(LOADER) -o TAB09DD TAB09DD.o $(LOADOPTS) TAB09ED: TAB09ED.o ; $(LOADER) -o TAB09ED TAB09ED.o $(LOADOPTS) TAB09FD: TAB09FD.o ; $(LOADER) -o TAB09FD TAB09FD.o $(LOADOPTS) TAB09GD: TAB09GD.o ; $(LOADER) -o TAB09GD TAB09GD.o $(LOADOPTS) TAB09HD: TAB09HD.o ; $(LOADER) -o TAB09HD TAB09HD.o $(LOADOPTS) TAB09ID: TAB09ID.o ; $(LOADER) -o TAB09ID TAB09ID.o $(LOADOPTS) TAB09JD: TAB09JD.o ; $(LOADER) -o TAB09JD TAB09JD.o $(LOADOPTS) TAB09KD: TAB09KD.o ; $(LOADER) -o TAB09KD TAB09KD.o $(LOADOPTS) TAB09MD: TAB09MD.o ; $(LOADER) -o TAB09MD TAB09MD.o $(LOADOPTS) TAB09ND: TAB09ND.o ; $(LOADER) -o TAB09ND TAB09ND.o $(LOADOPTS) TAB13AD: TAB13AD.o ; $(LOADER) -o TAB13AD TAB13AD.o $(LOADOPTS) TAB13BD: TAB13BD.o ; $(LOADER) -o TAB13BD TAB13BD.o $(LOADOPTS) TAB13CD: TAB13CD.o ; $(LOADER) -o TAB13CD TAB13CD.o $(LOADOPTS) TAB13DD: TAB13DD.o ; $(LOADER) -o TAB13DD TAB13DD.o $(LOADOPTS) TAB13ED: TAB13ED.o ; $(LOADER) -o TAB13ED TAB13ED.o $(LOADOPTS) TAB13FD: TAB13FD.o ; $(LOADER) -o TAB13FD TAB13FD.o $(LOADOPTS) TAB13MD: TAB13MD.o ; $(LOADER) -o TAB13MD TAB13MD.o $(LOADOPTS) TAG08BD: TAG08BD.o ; $(LOADER) -o TAG08BD TAG08BD.o $(LOADOPTS) TBB01AD: TBB01AD.o ; $(LOADER) -o TBB01AD TBB01AD.o $(LOADOPTS) TBB02AD: TBB02AD.o ; $(LOADER) -o TBB02AD TBB02AD.o $(LOADOPTS) TBB03AD: TBB03AD.o ; $(LOADER) -o TBB03AD TBB03AD.o $(LOADOPTS) TBB04AD: TBB04AD.o ; $(LOADER) -o TBB04AD TBB04AD.o $(LOADOPTS) TBD01AD: TBD01AD.o ; $(LOADER) -o TBD01AD TBD01AD.o $(LOADOPTS) TBD02AD: TBD02AD.o ; $(LOADER) -o TBD02AD TBD02AD.o $(LOADOPTS) TDE01OD: TDE01OD.o ; $(LOADER) -o TDE01OD TDE01OD.o $(LOADOPTS) TDE01PD: TDE01PD.o ; $(LOADER) -o TDE01PD TDE01PD.o $(LOADOPTS) TDF01MD: TDF01MD.o ; $(LOADER) -o TDF01MD TDF01MD.o $(LOADOPTS) TDG01MD: TDG01MD.o ; $(LOADER) -o TDG01MD TDG01MD.o $(LOADOPTS) TDG01ND: TDG01ND.o ; $(LOADER) -o TDG01ND TDG01ND.o $(LOADOPTS) TDG01OD: TDG01OD.o ; $(LOADER) -o TDG01OD TDG01OD.o $(LOADOPTS) TDK01MD: TDK01MD.o ; $(LOADER) -o TDK01MD TDK01MD.o $(LOADOPTS) TFB01QD: TFB01QD.o ; $(LOADER) -o TFB01QD TFB01QD.o $(LOADOPTS) TFB01RD: TFB01RD.o ; $(LOADER) -o TFB01RD TFB01RD.o $(LOADOPTS) TFB01SD: TFB01SD.o ; $(LOADER) -o TFB01SD TFB01SD.o $(LOADOPTS) TFB01TD: TFB01TD.o ; $(LOADER) -o TFB01TD TFB01TD.o $(LOADOPTS) TFB01VD: TFB01VD.o ; $(LOADER) -o TFB01VD TFB01VD.o $(LOADOPTS) TFD01AD: TFD01AD.o ; $(LOADER) -o TFD01AD TFD01AD.o $(LOADOPTS) TIB01AD: TIB01AD.o ; $(LOADER) -o TIB01AD TIB01AD.o $(LOADOPTS) TIB01BD: TIB01BD.o ; $(LOADER) -o TIB01BD TIB01BD.o $(LOADOPTS) TIB01CD: TIB01CD.o ; $(LOADER) -o TIB01CD TIB01CD.o $(LOADOPTS) TIB03AD: TIB03AD.o ; $(LOADER) -o TIB03AD TIB03AD.o $(LOADOPTS) TIB03BD: TIB03BD.o ; $(LOADER) -o TIB03BD TIB03BD.o $(LOADOPTS) TMB01TD: TMB01TD.o ; $(LOADER) -o TMB01TD TMB01TD.o $(LOADOPTS) TMB02CD: TMB02CD.o ; $(LOADER) -o TMB02CD TMB02CD.o $(LOADOPTS) TMB02DD: TMB02DD.o ; $(LOADER) -o TMB02DD TMB02DD.o $(LOADOPTS) TMB02ED: TMB02ED.o ; $(LOADER) -o TMB02ED TMB02ED.o $(LOADOPTS) TMB02FD: TMB02FD.o ; $(LOADER) -o TMB02FD TMB02FD.o $(LOADOPTS) TMB02GD: TMB02GD.o ; $(LOADER) -o TMB02GD TMB02GD.o $(LOADOPTS) TMB02HD: TMB02HD.o ; $(LOADER) -o TMB02HD TMB02HD.o $(LOADOPTS) TMB02ID: TMB02ID.o ; $(LOADER) -o TMB02ID TMB02ID.o $(LOADOPTS) TMB02JD: TMB02JD.o ; $(LOADER) -o TMB02JD TMB02JD.o $(LOADOPTS) TMB02JX: TMB02JX.o ; $(LOADER) -o TMB02JX TMB02JX.o $(LOADOPTS) TMB02KD: TMB02KD.o ; $(LOADER) -o TMB02KD TMB02KD.o $(LOADOPTS) TMB02MD: TMB02MD.o ; $(LOADER) -o TMB02MD TMB02MD.o $(LOADOPTS) TMB02ND: TMB02ND.o ; $(LOADER) -o TMB02ND TMB02ND.o $(LOADOPTS) TMB02QD: TMB02QD.o ; $(LOADER) -o TMB02QD TMB02QD.o $(LOADOPTS) TMB02SD: TMB02SD.o ; $(LOADER) -o TMB02SD TMB02SD.o $(LOADOPTS) TMB02VD: TMB02VD.o ; $(LOADER) -o TMB02VD TMB02VD.o $(LOADOPTS) TMB03MD: TMB03MD.o ; $(LOADER) -o TMB03MD TMB03MD.o $(LOADOPTS) TMB03ND: TMB03ND.o ; $(LOADER) -o TMB03ND TMB03ND.o $(LOADOPTS) TMB03OD: TMB03OD.o ; $(LOADER) -o TMB03OD TMB03OD.o $(LOADOPTS) TMB03PD: TMB03PD.o ; $(LOADER) -o TMB03PD TMB03PD.o $(LOADOPTS) TMB03QD: TMB03QD.o ; $(LOADER) -o TMB03QD TMB03QD.o $(LOADOPTS) TMB03RD: TMB03RD.o ; $(LOADER) -o TMB03RD TMB03RD.o $(LOADOPTS) TMB03SD: TMB03SD.o ; $(LOADER) -o TMB03SD TMB03SD.o $(LOADOPTS) TMB03UD: TMB03UD.o ; $(LOADER) -o TMB03UD TMB03UD.o $(LOADOPTS) TMB03VD: TMB03VD.o ; $(LOADER) -o TMB03VD TMB03VD.o $(LOADOPTS) TMB03WD: TMB03WD.o ; $(LOADER) -o TMB03WD TMB03WD.o $(LOADOPTS) TMB04DY: TMB04DY.o ; $(LOADER) -o TMB04DY TMB04DY.o $(LOADOPTS) TMB04GD: TMB04GD.o ; $(LOADER) -o TMB04GD TMB04GD.o $(LOADOPTS) TMB04MD: TMB04MD.o ; $(LOADER) -o TMB04MD TMB04MD.o $(LOADOPTS) TMB04OD: TMB04OD.o ; $(LOADER) -o TMB04OD TMB04OD.o $(LOADOPTS) TMB04UD: TMB04UD.o ; $(LOADER) -o TMB04UD TMB04UD.o $(LOADOPTS) TMB04VD: TMB04VD.o ; $(LOADER) -o TMB04VD TMB04VD.o $(LOADOPTS) TMB04XD: TMB04XD.o ; $(LOADER) -o TMB04XD TMB04XD.o $(LOADOPTS) TMB04YD: TMB04YD.o ; $(LOADER) -o TMB04YD TMB04YD.o $(LOADOPTS) TMB04ZD: TMB04ZD.o ; $(LOADER) -o TMB04ZD TMB04ZD.o $(LOADOPTS) TMB05MD: TMB05MD.o ; $(LOADER) -o TMB05MD TMB05MD.o $(LOADOPTS) TMB05ND: TMB05ND.o ; $(LOADER) -o TMB05ND TMB05ND.o $(LOADOPTS) TMB05OD: TMB05OD.o ; $(LOADER) -o TMB05OD TMB05OD.o $(LOADOPTS) TMC01MD: TMC01MD.o ; $(LOADER) -o TMC01MD TMC01MD.o $(LOADOPTS) TMC01ND: TMC01ND.o ; $(LOADER) -o TMC01ND TMC01ND.o $(LOADOPTS) TMC01OD: TMC01OD.o ; $(LOADER) -o TMC01OD TMC01OD.o $(LOADOPTS) TMC01PD: TMC01PD.o ; $(LOADER) -o TMC01PD TMC01PD.o $(LOADOPTS) TMC01QD: TMC01QD.o ; $(LOADER) -o TMC01QD TMC01QD.o $(LOADOPTS) TMC01RD: TMC01RD.o ; $(LOADER) -o TMC01RD TMC01RD.o $(LOADOPTS) TMC01SD: TMC01SD.o ; $(LOADER) -o TMC01SD TMC01SD.o $(LOADOPTS) TMC01TD: TMC01TD.o ; $(LOADER) -o TMC01TD TMC01TD.o $(LOADOPTS) TMC01VD: TMC01VD.o ; $(LOADER) -o TMC01VD TMC01VD.o $(LOADOPTS) TMC01WD: TMC01WD.o ; $(LOADER) -o TMC01WD TMC01WD.o $(LOADOPTS) TMC03MD: TMC03MD.o ; $(LOADER) -o TMC03MD TMC03MD.o $(LOADOPTS) TMC03ND: TMC03ND.o ; $(LOADER) -o TMC03ND TMC03ND.o $(LOADOPTS) TMD03AD: TMD03AD.o ; $(LOADER) -o TMD03AD TMD03AD.o $(LOADOPTS) TMD03BD: TMD03BD.o ; $(LOADER) -o TMD03BD TMD03BD.o $(LOADOPTS) TSB01BD: TSB01BD.o ; $(LOADER) -o TSB01BD TSB01BD.o $(LOADOPTS) TSB01DD: TSB01DD.o ; $(LOADER) -o TSB01DD TSB01DD.o $(LOADOPTS) TSB01MD: TSB01MD.o ; $(LOADER) -o TSB01MD TSB01MD.o $(LOADOPTS) TSB02MD: TSB02MD.o ; $(LOADER) -o TSB02MD TSB02MD.o $(LOADOPTS) TSB02ND: TSB02ND.o ; $(LOADER) -o TSB02ND TSB02ND.o $(LOADOPTS) TSB02OD: TSB02OD.o ; $(LOADER) -o TSB02OD TSB02OD.o $(LOADOPTS) TSB02PD: TSB02PD.o ; $(LOADER) -o TSB02PD TSB02PD.o $(LOADOPTS) TSB02QD: TSB02QD.o ; $(LOADER) -o TSB02QD TSB02QD.o $(LOADOPTS) TSB02RD: TSB02RD.o ; $(LOADER) -o TSB02RD TSB02RD.o $(LOADOPTS) TSB02SD: TSB02SD.o ; $(LOADER) -o TSB02SD TSB02SD.o $(LOADOPTS) TSB03MD: TSB03MD.o ; $(LOADER) -o TSB03MD TSB03MD.o $(LOADOPTS) TSB03OD: TSB03OD.o ; $(LOADER) -o TSB03OD TSB03OD.o $(LOADOPTS) TSB03QD: TSB03QD.o ; $(LOADER) -o TSB03QD TSB03QD.o $(LOADOPTS) TSB03SD: TSB03SD.o ; $(LOADER) -o TSB03SD TSB03SD.o $(LOADOPTS) TSB03TD: TSB03TD.o ; $(LOADER) -o TSB03TD TSB03TD.o $(LOADOPTS) TSB03UD: TSB03UD.o ; $(LOADER) -o TSB03UD TSB03UD.o $(LOADOPTS) TSB04MD: TSB04MD.o ; $(LOADER) -o TSB04MD TSB04MD.o $(LOADOPTS) TSB04ND: TSB04ND.o ; $(LOADER) -o TSB04ND TSB04ND.o $(LOADOPTS) TSB04OD: TSB04OD.o ; $(LOADER) -o TSB04OD TSB04OD.o $(LOADOPTS) TSB04PD: TSB04PD.o ; $(LOADER) -o TSB04PD TSB04PD.o $(LOADOPTS) TSB04QD: TSB04QD.o ; $(LOADER) -o TSB04QD TSB04QD.o $(LOADOPTS) TSB04RD: TSB04RD.o ; $(LOADER) -o TSB04RD TSB04RD.o $(LOADOPTS) TSB06ND: TSB06ND.o ; $(LOADER) -o TSB06ND TSB06ND.o $(LOADOPTS) TSB08CD: TSB08CD.o ; $(LOADER) -o TSB08CD TSB08CD.o $(LOADOPTS) TSB08DD: TSB08DD.o ; $(LOADER) -o TSB08DD TSB08DD.o $(LOADOPTS) TSB08ED: TSB08ED.o ; $(LOADER) -o TSB08ED TSB08ED.o $(LOADOPTS) TSB08FD: TSB08FD.o ; $(LOADER) -o TSB08FD TSB08FD.o $(LOADOPTS) TSB08MD: TSB08MD.o ; $(LOADER) -o TSB08MD TSB08MD.o $(LOADOPTS) TSB08ND: TSB08ND.o ; $(LOADER) -o TSB08ND TSB08ND.o $(LOADOPTS) TSB09MD: TSB09MD.o ; $(LOADER) -o TSB09MD TSB09MD.o $(LOADOPTS) TSB10DD: TSB10DD.o ; $(LOADER) -o TSB10DD TSB10DD.o $(LOADOPTS) TSB10ED: TSB10ED.o ; $(LOADER) -o TSB10ED TSB10ED.o $(LOADOPTS) TSB10FD: TSB10FD.o ; $(LOADER) -o TSB10FD TSB10FD.o $(LOADOPTS) TSB10HD: TSB10HD.o ; $(LOADER) -o TSB10HD TSB10HD.o $(LOADOPTS) TSB10ID: TSB10ID.o ; $(LOADER) -o TSB10ID TSB10ID.o $(LOADOPTS) TSB10KD: TSB10KD.o ; $(LOADER) -o TSB10KD TSB10KD.o $(LOADOPTS) TSB10ZD: TSB10ZD.o ; $(LOADER) -o TSB10ZD TSB10ZD.o $(LOADOPTS) TSB16AD: TSB16AD.o ; $(LOADER) -o TSB16AD TSB16AD.o $(LOADOPTS) TSB16BD: TSB16BD.o ; $(LOADER) -o TSB16BD TSB16BD.o $(LOADOPTS) TSB16CD: TSB16CD.o ; $(LOADER) -o TSB16CD TSB16CD.o $(LOADOPTS) TSG02AD: TSG02AD.o ; $(LOADER) -o TSG02AD TSG02AD.o $(LOADOPTS) TSG03AD: TSG03AD.o ; $(LOADER) -o TSG03AD TSG03AD.o $(LOADOPTS) TSG03BD: TSG03BD.o ; $(LOADER) -o TSG03BD TSG03BD.o $(LOADOPTS) TTB01ID: TTB01ID.o ; $(LOADER) -o TTB01ID TTB01ID.o $(LOADOPTS) TTB01KD: TTB01KD.o ; $(LOADER) -o TTB01KD TTB01KD.o $(LOADOPTS) TTB01LD: TTB01LD.o ; $(LOADER) -o TTB01LD TTB01LD.o $(LOADOPTS) TTB01MD: TTB01MD.o ; $(LOADER) -o TTB01MD TTB01MD.o $(LOADOPTS) TTB01ND: TTB01ND.o ; $(LOADER) -o TTB01ND TTB01ND.o $(LOADOPTS) TTB01PD: TTB01PD.o ; $(LOADER) -o TTB01PD TTB01PD.o $(LOADOPTS) TTB01TD: TTB01TD.o ; $(LOADER) -o TTB01TD TTB01TD.o $(LOADOPTS) TTB01UD: TTB01UD.o ; $(LOADER) -o TTB01UD TTB01UD.o $(LOADOPTS) TTB01WD: TTB01WD.o ; $(LOADER) -o TTB01WD TTB01WD.o $(LOADOPTS) TTB01ZD: TTB01ZD.o ; $(LOADER) -o TTB01ZD TTB01ZD.o $(LOADOPTS) TTB03AD: TTB03AD.o ; $(LOADER) -o TTB03AD TTB03AD.o $(LOADOPTS) TTB04AD: TTB04AD.o ; $(LOADER) -o TTB04AD TTB04AD.o $(LOADOPTS) TTB04BD: TTB04BD.o ; $(LOADER) -o TTB04BD TTB04BD.o $(LOADOPTS) TTB04CD: TTB04CD.o ; $(LOADER) -o TTB04CD TTB04CD.o $(LOADOPTS) TTB05AD: TTB05AD.o ; $(LOADER) -o TTB05AD TTB05AD.o $(LOADOPTS) TTC01OD: TTC01OD.o ; $(LOADER) -o TTC01OD TTC01OD.o $(LOADOPTS) TTC04AD: TTC04AD.o ; $(LOADER) -o TTC04AD TTC04AD.o $(LOADOPTS) TTC05AD: TTC05AD.o ; $(LOADER) -o TTC05AD TTC05AD.o $(LOADOPTS) TTD03AD: TTD03AD.o ; $(LOADER) -o TTD03AD TTD03AD.o $(LOADOPTS) TTD04AD: TTD04AD.o ; $(LOADER) -o TTD04AD TTD04AD.o $(LOADOPTS) TTD05AD: TTD05AD.o ; $(LOADER) -o TTD05AD TTD05AD.o $(LOADOPTS) TTF01MD: TTF01MD.o ; $(LOADER) -o TTF01MD TTF01MD.o $(LOADOPTS) TTF01ND: TTF01ND.o ; $(LOADER) -o TTF01ND TTF01ND.o $(LOADOPTS) TTF01OD: TTF01OD.o ; $(LOADER) -o TTF01OD TTF01OD.o $(LOADOPTS) TTF01PD: TTF01PD.o ; $(LOADER) -o TTF01PD TTF01PD.o $(LOADOPTS) TTF01QD: TTF01QD.o ; $(LOADER) -o TTF01QD TTF01QD.o $(LOADOPTS) TTF01RD: TTF01RD.o ; $(LOADER) -o TTF01RD TTF01RD.o $(LOADOPTS) TTG01AD: TTG01AD.o ; $(LOADER) -o TTG01AD TTG01AD.o $(LOADOPTS) TTG01CD: TTG01CD.o ; $(LOADER) -o TTG01CD TTG01CD.o $(LOADOPTS) TTG01DD: TTG01DD.o ; $(LOADER) -o TTG01DD TTG01DD.o $(LOADOPTS) TTG01ED: TTG01ED.o ; $(LOADER) -o TTG01ED TTG01ED.o $(LOADOPTS) TTG01FD: TTG01FD.o ; $(LOADER) -o TTG01FD TTG01FD.o $(LOADOPTS) TTG01HD: TTG01HD.o ; $(LOADER) -o TTG01HD TTG01HD.o $(LOADOPTS) TTG01ID: TTG01ID.o ; $(LOADER) -o TTG01ID TTG01ID.o $(LOADOPTS) TTG01JD: TTG01JD.o ; $(LOADER) -o TTG01JD TTG01JD.o $(LOADOPTS) TUD01BD: TUD01BD.o ; $(LOADER) -o TUD01BD TUD01BD.o $(LOADOPTS) TUD01CD: TUD01CD.o ; $(LOADER) -o TUD01CD TUD01CD.o $(LOADOPTS) TUD01DD: TUD01DD.o ; $(LOADER) -o TUD01DD TUD01DD.o $(LOADOPTS) TUD01MD: TUD01MD.o ; $(LOADER) -o TUD01MD TUD01MD.o $(LOADOPTS) TUD01ND: TUD01ND.o ; $(LOADER) -o TUD01ND TUD01ND.o $(LOADOPTS) TMB03TD: TMB03TD.o ; $(LOADER) -o TMB03TD TMB03TD.o $(LOADOPTS) TMB03XD: TMB03XD.o ; $(LOADER) -o TMB03XD TMB03XD.o $(LOADOPTS) TMB03XP: TMB03XP.o ; $(LOADER) -o TMB03XP TMB03XP.o $(LOADOPTS) TMB03ZD: TMB03ZD.o ; $(LOADER) -o TMB03ZD TMB03ZD.o $(LOADOPTS) TMB04DD: TMB04DD.o ; $(LOADER) -o TMB04DD TMB04DD.o $(LOADOPTS) TMB04DS: TMB04DS.o ; $(LOADER) -o TMB04DS TMB04DS.o $(LOADOPTS) TMB04PB: TMB04PB.o ; $(LOADER) -o TMB04PB TMB04PB.o $(LOADOPTS) TMB04PU: TMB04PU.o ; $(LOADER) -o TMB04PU TMB04PU.o $(LOADOPTS) TMB04TB: TMB04TB.o ; $(LOADER) -o TMB04TB TMB04TB.o $(LOADOPTS) TMB04TS: TMB04TS.o ; $(LOADER) -o TMB04TS TMB04TS.o $(LOADOPTS) TAB08NZ: TAB08NZ.o ; $(LOADER) -o TAB08NZ TAB08NZ.o $(LOADOPTS) TAG08BZ: TAG08BZ.o ; $(LOADER) -o TAG08BZ TAG08BZ.o $(LOADOPTS) TTB01IZ: TTB01IZ.o ; $(LOADER) -o TTB01IZ TTB01IZ.o $(LOADOPTS) TTG01AZ: TTG01AZ.o ; $(LOADER) -o TTG01AZ TTG01AZ.o $(LOADOPTS) TTG01FZ: TTG01FZ.o ; $(LOADER) -o TTG01FZ TTG01FZ.o $(LOADOPTS) TMB03BD: TMB03BD.o ; $(LOADER) -o TMB03BD TMB03BD.o $(LOADOPTS) TMB03KD: TMB03KD.o ; $(LOADER) -o TMB03KD TMB03KD.o $(LOADOPTS) TMB03LD: TMB03LD.o ; $(LOADER) -o TMB03LD TMB03LD.o $(LOADOPTS) TMB04AD: TMB04AD.o ; $(LOADER) -o TMB04AD TMB04AD.o $(LOADOPTS) TMB04BD: TMB04BD.o ; $(LOADER) -o TMB04BD TMB04BD.o $(LOADOPTS) $(TAB01MD): $(FRC) $(TAB01ND): $(FRC) $(TAB01OD): $(FRC) $(TAB04MD): $(FRC) $(TAB05MD): $(FRC) $(TAB05ND): $(FRC) $(TAB05OD): $(FRC) $(TAB05PD): $(FRC) $(TAB05QD): $(FRC) $(TAB05RD): $(FRC) $(TAB07MD): $(FRC) $(TAB07ND): $(FRC) $(TAB08ND): $(FRC) $(TAB09AD): $(FRC) $(TAB09BD): $(FRC) $(TAB09CD): $(FRC) $(TAB09DD): $(FRC) $(TAB09ED): $(FRC) $(TAB09FD): $(FRC) $(TAB09GD): $(FRC) $(TAB09HD): $(FRC) $(TAB09ID): $(FRC) $(TAB09JD): $(FRC) $(TAB09KD): $(FRC) $(TAB09MD): $(FRC) $(TAB09ND): $(FRC) $(TAB13AD): $(FRC) $(TAB13BD): $(FRC) $(TAB13CD): $(FRC) $(TAB13DD): $(FRC) $(TAB13ED): $(FRC) $(TAB13FD): $(FRC) $(TAB13MD): $(FRC) $(TAG08BD): $(FRC) $(TBB01AD): $(FRC) $(TBB02AD): $(FRC) $(TBB03AD): $(FRC) $(TBB04AD): $(FRC) $(TBD01AD): $(FRC) $(TBD02AD): $(FRC) $(TDE01OD): $(FRC) $(TDE01PD): $(FRC) $(TDF01MD): $(FRC) $(TDG01MD): $(FRC) $(TDG01ND): $(FRC) $(TDG01OD): $(FRC) $(TDK01MD): $(FRC) $(TFB01QD): $(FRC) $(TFB01RD): $(FRC) $(TFB01SD): $(FRC) $(TFB01TD): $(FRC) $(TFB01VD): $(FRC) $(TFD01AD): $(FRC) $(TIB01AD): $(FRC) $(TIB01BD): $(FRC) $(TIB01CD): $(FRC) $(TIB03AD): $(FRC) $(TIB03BD): $(FRC) $(TMB01TD): $(FRC) $(TMB02CD): $(FRC) $(TMB02DD): $(FRC) $(TMB02ED): $(FRC) $(TMB02FD): $(FRC) $(TMB02GD): $(FRC) $(TMB02HD): $(FRC) $(TMB02ID): $(FRC) $(TMB02JD): $(FRC) $(TMB02JX): $(FRC) $(TMB02KD): $(FRC) $(TMB02MD): $(FRC) $(TMB02ND): $(FRC) $(TMB02QD): $(FRC) $(TMB02SD): $(FRC) $(TMB02VD): $(FRC) $(TMB03MD): $(FRC) $(TMB03ND): $(FRC) $(TMB03OD): $(FRC) $(TMB03PD): $(FRC) $(TMB03QD): $(FRC) $(TMB03RD): $(FRC) $(TMB03SD): $(FRC) $(TMB03UD): $(FRC) $(TMB03VD): $(FRC) $(TMB03WD): $(FRC) $(TMB04DY): $(FRC) $(TMB04GD): $(FRC) $(TMB04MD): $(FRC) $(TMB04OD): $(FRC) $(TMB04UD): $(FRC) $(TMB04VD): $(FRC) $(TMB04XD): $(FRC) $(TMB04YD): $(FRC) $(TMB04ZD): $(FRC) $(TMB05MD): $(FRC) $(TMB05ND): $(FRC) $(TMB05OD): $(FRC) $(TMC01MD): $(FRC) $(TMC01ND): $(FRC) $(TMC01OD): $(FRC) $(TMC01PD): $(FRC) $(TMC01QD): $(FRC) $(TMC01RD): $(FRC) $(TMC01SD): $(FRC) $(TMC01TD): $(FRC) $(TMC01VD): $(FRC) $(TMC01WD): $(FRC) $(TMC03MD): $(FRC) $(TMC03ND): $(FRC) $(TMD03AD): $(FRC) $(TMD03BD): $(FRC) $(TSB01BD): $(FRC) $(TSB01DD): $(FRC) $(TSB01MD): $(FRC) $(TSB02MD): $(FRC) $(TSB02ND): $(FRC) $(TSB02OD): $(FRC) $(TSB02PD): $(FRC) $(TSB02QD): $(FRC) $(TSB02RD): $(FRC) $(TSB02SD): $(FRC) $(TSB03MD): $(FRC) $(TSB03OD): $(FRC) $(TSB03QD): $(FRC) $(TSB03SD): $(FRC) $(TSB03TD): $(FRC) $(TSB03UD): $(FRC) $(TSB04MD): $(FRC) $(TSB04ND): $(FRC) $(TSB04OD): $(FRC) $(TSB04PD): $(FRC) $(TSB04QD): $(FRC) $(TSB04RD): $(FRC) $(TSB06ND): $(FRC) $(TSB08CD): $(FRC) $(TSB08DD): $(FRC) $(TSB08ED): $(FRC) $(TSB08FD): $(FRC) $(TSB08MD): $(FRC) $(TSB08ND): $(FRC) $(TSB09MD): $(FRC) $(TSB10DD): $(FRC) $(TSB10ED): $(FRC) $(TSB10FD): $(FRC) $(TSB10HD): $(FRC) $(TSB10ID): $(FRC) $(TSB10KD): $(FRC) $(TSB10ZD): $(FRC) $(TSB16AD): $(FRC) $(TSB16BD): $(FRC) $(TSB16CD): $(FRC) $(TSG02AD): $(FRC) $(TSG03AD): $(FRC) $(TSG03BD): $(FRC) $(TTB01ID): $(FRC) $(TTB01KD): $(FRC) $(TTB01LD): $(FRC) $(TTB01MD): $(FRC) $(TTB01ND): $(FRC) $(TTB01PD): $(FRC) $(TTB01TD): $(FRC) $(TTB01UD): $(FRC) $(TTB01WD): $(FRC) $(TTB01ZD): $(FRC) $(TTB03AD): $(FRC) $(TTB04AD): $(FRC) $(TTB04BD): $(FRC) $(TTB04CD): $(FRC) $(TTB05AD): $(FRC) $(TTC01OD): $(FRC) $(TTC04AD): $(FRC) $(TTC05AD): $(FRC) $(TTD03AD): $(FRC) $(TTD04AD): $(FRC) $(TTD05AD): $(FRC) $(TTF01MD): $(FRC) $(TTF01ND): $(FRC) $(TTF01OD): $(FRC) $(TTF01PD): $(FRC) $(TTF01QD): $(FRC) $(TTF01RD): $(FRC) $(TTG01AD): $(FRC) $(TTG01CD): $(FRC) $(TTG01DD): $(FRC) $(TTG01ED): $(FRC) $(TTG01FD): $(FRC) $(TTG01HD): $(FRC) $(TTG01ID): $(FRC) $(TTG01JD): $(FRC) $(TUD01BD): $(FRC) $(TUD01CD): $(FRC) $(TUD01DD): $(FRC) $(TUD01MD): $(FRC) $(TUD01ND): $(FRC) $(TMB03TD): $(FRC) $(TMB03XD): $(FRC) $(TMB03XP): $(FRC) $(TMB03ZD): $(FRC) $(TMB04DD): $(FRC) $(TMB04DS): $(FRC) $(TMB04PB): $(FRC) $(TMB04PU): $(FRC) $(TMB04TB): $(FRC) $(TMB04TS): $(FRC) $(TAB08NZ): $(FRC) $(TAG08BZ): $(FRC) $(TTB01IZ): $(FRC) $(TTG01AZ): $(FRC) $(TTG01FZ): $(FRC) $(TMB03BD): $(FRC) $(TMB03KD): $(FRC) $(TMB03LD): $(FRC) $(TMB04AD): $(FRC) $(TMB04BD): $(FRC) FRC: @FRC=$(FRC) clean: rm -f *.exa cleanup: rm -f *.exa \ TAB01MD TAB01ND TAB01OD TAB04MD TAB05MD TAB05ND TAB05OD TAB05PD \ TAB05QD TAB05RD TAB07MD TAB07ND TAB08ND TAB09AD TAB09BD TAB09CD \ TAB09DD TAB09ED TAB09FD TAB09GD TAB09HD TAB09ID TAB09JD TAB09KD \ TAB09MD TAB09ND TAB13AD TAB13BD TAB13CD TAB13DD TAB13ED TAB13FD \ TAB13MD TAG08BD \ TBB01AD TBB02AD TBB03AD TBB04AD TBD01AD TBD02AD \ TDE01OD TDE01PD TDF01MD TDG01MD TDG01ND TDG01OD TDK01MD \ TFB01QD TFB01RD TFB01SD TFB01TD TFB01VD TFD01AD \ TIB01AD TIB01BD TIB01CD TIB03AD TIB03BD \ TMB01TD TMB02CD TMB02DD TMB02ED TMB02FD TMB02GD TMB02HD TMB02ID \ TMB02JD TMB02JX TMB02KD TMB02MD TMB02ND TMB02QD TMB02SD TMB02VD \ TMB03MD TMB03ND TMB03OD TMB03PD TMB03QD TMB03RD TMB03SD TMB03UD \ TMB03VD TMB03WD TMB04DY TMB04GD TMB04MD TMB04OD TMB04UD TMB04VD \ TMB04XD TMB04YD TMB04ZD TMB05MD TMB05ND TMB05OD TMC01MD TMC01ND \ TMC01OD TMC01PD TMC01QD TMC01RD TMC01SD TMC01TD TMC01VD TMC01WD \ TMC03MD TMC03ND TMD03AD TMD03BD \ TSB01BD TSB01DD TSB01MD TSB02MD TSB02ND TSB02OD TSB02PD TSB02QD \ TSB02RD TSB02SD TSB03MD TSB03OD TSB03QD TSB03SD TSB03TD TSB03UD \ TSB04MD TSB04ND TSB04OD TSB04PD TSB04QD TSB04RD TSB06ND TSB08CD \ TSB08DD TSB08ED TSB08FD TSB08MD TSB08ND TSB09MD TSB10DD TSB10ED \ TSB10FD TSB10HD TSB10ID TSB10KD TSB10ZD TSB16AD TSB16BD TSB16CD \ TSG02AD TSG03AD TSG03BD \ TTB01ID TTB01KD TTB01LD TTB01MD TTB01ND TTB01PD TTB01TD TTB01UD \ TTB01WD TTB01ZD TTB03AD TTB04AD TTB04BD TTB04CD TTB05AD TTC01OD \ TTC04AD TTC05AD TTD03AD TTD04AD TTD05AD TTF01MD TTF01ND TTF01OD \ TTF01PD TTF01QD TTF01RD TTG01AD TTG01CD TTG01DD TTG01ED TTG01FD \ TTG01HD TTG01ID TTG01JD TUD01BD \ TUD01CD TUD01DD TUD01MD TUD01ND \ TMB03TD TMB03XD TMB03XP TMB03ZD TMB04DD TMB04DS TMB04PB TMB04PU \ TMB04TB TMB04TS \ TAB08NZ TAG08BZ TTB01IZ TTG01AZ TTG01FZ \ TMB03BD TMB03KD TMB03LD TMB04AD TMB04BD TAB01MD.o: TAB01MD.f ; $(FORTRAN) $(OPTS) -c $< TAB01ND.o: TAB01ND.f ; $(FORTRAN) $(OPTS) -c $< TAB01OD.o: TAB01OD.f ; $(FORTRAN) $(OPTS) -c $< TAB04MD.o: TAB04MD.f ; $(FORTRAN) $(OPTS) -c $< TAB05MD.o: TAB05MD.f ; $(FORTRAN) $(OPTS) -c $< TAB05ND.o: TAB05ND.f ; $(FORTRAN) $(OPTS) -c $< TAB05OD.o: TAB05OD.f ; $(FORTRAN) $(OPTS) -c $< TAB05PD.o: TAB05PD.f ; $(FORTRAN) $(OPTS) -c $< TAB05QD.o: TAB05QD.f ; $(FORTRAN) $(OPTS) -c $< TAB05RD.o: TAB05RD.f ; $(FORTRAN) $(OPTS) -c $< TAB07MD.o: TAB07MD.f ; $(FORTRAN) $(OPTS) -c $< TAB07ND.o: TAB07ND.f ; $(FORTRAN) $(OPTS) -c $< TAB08ND.o: TAB08ND.f ; $(FORTRAN) $(OPTS) -c $< TAB09AD.o: TAB09AD.f ; $(FORTRAN) $(OPTS) -c $< TAB09BD.o: TAB09BD.f ; $(FORTRAN) $(OPTS) -c $< TAB09CD.o: TAB09CD.f ; $(FORTRAN) $(OPTS) -c $< TAB09DD.o: TAB09DD.f ; $(FORTRAN) $(OPTS) -c $< TAB09ED.o: TAB09ED.f ; $(FORTRAN) $(OPTS) -c $< TAB09FD.o: TAB09FD.f ; $(FORTRAN) $(OPTS) -c $< TAB09GD.o: TAB09GD.f ; $(FORTRAN) $(OPTS) -c $< TAB09HD.o: TAB09HD.f ; $(FORTRAN) $(OPTS) -c $< TAB09ID.o: TAB09ID.f ; $(FORTRAN) $(OPTS) -c $< TAB09JD.o: TAB09JD.f ; $(FORTRAN) $(OPTS) -c $< TAB09KD.o: TAB09KD.f ; $(FORTRAN) $(OPTS) -c $< TAB09MD.o: TAB09MD.f ; $(FORTRAN) $(OPTS) -c $< TAB09ND.o: TAB09ND.f ; $(FORTRAN) $(OPTS) -c $< TAB13AD.o: TAB13AD.f ; $(FORTRAN) $(OPTS) -c $< TAB13BD.o: TAB13BD.f ; $(FORTRAN) $(OPTS) -c $< TAB13CD.o: TAB13CD.f ; $(FORTRAN) $(OPTS) -c $< TAB13DD.o: TAB13DD.f ; $(FORTRAN) $(OPTS) -c $< TAB13ED.o: TAB13ED.f ; $(FORTRAN) $(OPTS) -c $< TAB13FD.o: TAB13FD.f ; $(FORTRAN) $(OPTS) -c $< TAB13MD.o: TAB13MD.f ; $(FORTRAN) $(OPTS) -c $< TAG08BD.o: TAG08BD.f ; $(FORTRAN) $(OPTS) -c $< TBB01AD.o: TBB01AD.f ; $(FORTRAN) $(OPTS) -c $< TBB02AD.o: TBB02AD.f ; $(FORTRAN) $(OPTS) -c $< TBB03AD.o: TBB03AD.f ; $(FORTRAN) $(OPTS) -c $< TBB04AD.o: TBB04AD.f ; $(FORTRAN) $(OPTS) -c $< TBD01AD.o: TBD01AD.f ; $(FORTRAN) $(OPTS) -c $< TBD02AD.o: TBD02AD.f ; $(FORTRAN) $(OPTS) -c $< TDE01OD.o: TDE01OD.f ; $(FORTRAN) $(OPTS) -c $< TDE01PD.o: TDE01PD.f ; $(FORTRAN) $(OPTS) -c $< TDF01MD.o: TDF01MD.f ; $(FORTRAN) $(OPTS) -c $< TDG01MD.o: TDG01MD.f ; $(FORTRAN) $(OPTS) -c $< TDG01ND.o: TDG01ND.f ; $(FORTRAN) $(OPTS) -c $< TDG01OD.o: TDG01OD.f ; $(FORTRAN) $(OPTS) -c $< TDK01MD.o: TDK01MD.f ; $(FORTRAN) $(OPTS) -c $< TFB01QD.o: TFB01QD.f ; $(FORTRAN) $(OPTS) -c $< TFB01RD.o: TFB01RD.f ; $(FORTRAN) $(OPTS) -c $< TFB01SD.o: TFB01SD.f ; $(FORTRAN) $(OPTS) -c $< TFB01TD.o: TFB01TD.f ; $(FORTRAN) $(OPTS) -c $< TFB01VD.o: TFB01VD.f ; $(FORTRAN) $(OPTS) -c $< TFD01AD.o: TFD01AD.f ; $(FORTRAN) $(OPTS) -c $< TIB01AD.o: TIB01AD.f ; $(FORTRAN) $(OPTS) -c $< TIB01BD.o: TIB01BD.f ; $(FORTRAN) $(OPTS) -c $< TIB01CD.o: TIB01CD.f ; $(FORTRAN) $(OPTS) -c $< TIB03AD.o: TIB03AD.f ; $(FORTRAN) $(OPTS) -c $< TIB03BD.o: TIB03BD.f ; $(FORTRAN) $(OPTS) -c $< TMB01TD.o: TMB01TD.f ; $(FORTRAN) $(OPTS) -c $< TMB02CD.o: TMB02CD.f ; $(FORTRAN) $(OPTS) -c $< TMB02DD.o: TMB02DD.f ; $(FORTRAN) $(OPTS) -c $< TMB02ED.o: TMB02ED.f ; $(FORTRAN) $(OPTS) -c $< TMB02FD.o: TMB02FD.f ; $(FORTRAN) $(OPTS) -c $< TMB02GD.o: TMB02GD.f ; $(FORTRAN) $(OPTS) -c $< TMB02HD.o: TMB02HD.f ; $(FORTRAN) $(OPTS) -c $< TMB02ID.o: TMB02ID.f ; $(FORTRAN) $(OPTS) -c $< TMB02JD.o: TMB02JD.f ; $(FORTRAN) $(OPTS) -c $< TMB02JX.o: TMB02JX.f ; $(FORTRAN) $(OPTS) -c $< TMB02KD.o: TMB02KD.f ; $(FORTRAN) $(OPTS) -c $< TMB02MD.o: TMB02MD.f ; $(FORTRAN) $(OPTS) -c $< TMB02ND.o: TMB02ND.f ; $(FORTRAN) $(OPTS) -c $< TMB02QD.o: TMB02QD.f ; $(FORTRAN) $(OPTS) -c $< TMB02SD.o: TMB02SD.f ; $(FORTRAN) $(OPTS) -c $< TMB02VD.o: TMB02VD.f ; $(FORTRAN) $(OPTS) -c $< TMB03MD.o: TMB03MD.f ; $(FORTRAN) $(OPTS) -c $< TMB03ND.o: TMB03ND.f ; $(FORTRAN) $(OPTS) -c $< TMB03OD.o: TMB03OD.f ; $(FORTRAN) $(OPTS) -c $< TMB03PD.o: TMB03PD.f ; $(FORTRAN) $(OPTS) -c $< TMB03QD.o: TMB03QD.f ; $(FORTRAN) $(OPTS) -c $< TMB03RD.o: TMB03RD.f ; $(FORTRAN) $(OPTS) -c $< TMB03SD.o: TMB03SD.f ; $(FORTRAN) $(OPTS) -c $< TMB03UD.o: TMB03UD.f ; $(FORTRAN) $(OPTS) -c $< TMB03VD.o: TMB03VD.f ; $(FORTRAN) $(OPTS) -c $< TMB03WD.o: TMB03WD.f ; $(FORTRAN) $(OPTS) -c $< TMB04DY.o: TMB04DY.f ; $(FORTRAN) $(OPTS) -c $< TMB04GD.o: TMB04GD.f ; $(FORTRAN) $(OPTS) -c $< TMB04MD.o: TMB04MD.f ; $(FORTRAN) $(OPTS) -c $< TMB04OD.o: TMB04OD.f ; $(FORTRAN) $(OPTS) -c $< TMB04UD.o: TMB04UD.f ; $(FORTRAN) $(OPTS) -c $< TMB04VD.o: TMB04VD.f ; $(FORTRAN) $(OPTS) -c $< TMB04XD.o: TMB04XD.f ; $(FORTRAN) $(OPTS) -c $< TMB04YD.o: TMB04YD.f ; $(FORTRAN) $(OPTS) -c $< TMB04ZD.o: TMB04ZD.f ; $(FORTRAN) $(OPTS) -c $< TMB05MD.o: TMB05MD.f ; $(FORTRAN) $(OPTS) -c $< TMB05ND.o: TMB05ND.f ; $(FORTRAN) $(OPTS) -c $< TMB05OD.o: TMB05OD.f ; $(FORTRAN) $(OPTS) -c $< TMC01MD.o: TMC01MD.f ; $(FORTRAN) $(OPTS) -c $< TMC01ND.o: TMC01ND.f ; $(FORTRAN) $(OPTS) -c $< TMC01OD.o: TMC01OD.f ; $(FORTRAN) $(OPTS) -c $< TMC01PD.o: TMC01PD.f ; $(FORTRAN) $(OPTS) -c $< TMC01QD.o: TMC01QD.f ; $(FORTRAN) $(OPTS) -c $< TMC01RD.o: TMC01RD.f ; $(FORTRAN) $(OPTS) -c $< TMC01SD.o: TMC01SD.f ; $(FORTRAN) $(OPTS) -c $< TMC01TD.o: TMC01TD.f ; $(FORTRAN) $(OPTS) -c $< TMC01VD.o: TMC01VD.f ; $(FORTRAN) $(OPTS) -c $< TMC01WD.o: TMC01WD.f ; $(FORTRAN) $(OPTS) -c $< TMC03MD.o: TMC03MD.f ; $(FORTRAN) $(OPTS) -c $< TMC03ND.o: TMC03ND.f ; $(FORTRAN) $(OPTS) -c $< TMD03AD.o: TMD03AD.f ; $(FORTRAN) $(OPTS) -c $< TMD03BD.o: TMD03BD.f ; $(FORTRAN) $(OPTS) -c $< TSB01BD.o: TSB01BD.f ; $(FORTRAN) $(OPTS) -c $< TSB01DD.o: TSB01DD.f ; $(FORTRAN) $(OPTS) -c $< TSB01MD.o: TSB01MD.f ; $(FORTRAN) $(OPTS) -c $< TSB02MD.o: TSB02MD.f ; $(FORTRAN) $(OPTS) -c $< TSB02ND.o: TSB02ND.f ; $(FORTRAN) $(OPTS) -c $< TSB02OD.o: TSB02OD.f ; $(FORTRAN) $(OPTS) -c $< TSB02PD.o: TSB02PD.f ; $(FORTRAN) $(OPTS) -c $< TSB02QD.o: TSB02QD.f ; $(FORTRAN) $(OPTS) -c $< TSB02RD.o: TSB02RD.f ; $(FORTRAN) $(OPTS) -c $< TSB02SD.o: TSB02SD.f ; $(FORTRAN) $(OPTS) -c $< TSB03MD.o: TSB03MD.f ; $(FORTRAN) $(OPTS) -c $< TSB03OD.o: TSB03OD.f ; $(FORTRAN) $(OPTS) -c $< TSB03QD.o: TSB03QD.f ; $(FORTRAN) $(OPTS) -c $< TSB03SD.o: TSB03SD.f ; $(FORTRAN) $(OPTS) -c $< TSB03TD.o: TSB03TD.f ; $(FORTRAN) $(OPTS) -c $< TSB03UD.o: TSB03UD.f ; $(FORTRAN) $(OPTS) -c $< TSB04MD.o: TSB04MD.f ; $(FORTRAN) $(OPTS) -c $< TSB04ND.o: TSB04ND.f ; $(FORTRAN) $(OPTS) -c $< TSB04OD.o: TSB04OD.f ; $(FORTRAN) $(OPTS) -c $< TSB04PD.o: TSB04PD.f ; $(FORTRAN) $(OPTS) -c $< TSB04QD.o: TSB04QD.f ; $(FORTRAN) $(OPTS) -c $< TSB04RD.o: TSB04RD.f ; $(FORTRAN) $(OPTS) -c $< TSB06ND.o: TSB06ND.f ; $(FORTRAN) $(OPTS) -c $< TSB08CD.o: TSB08CD.f ; $(FORTRAN) $(OPTS) -c $< TSB08DD.o: TSB08DD.f ; $(FORTRAN) $(OPTS) -c $< TSB08ED.o: TSB08ED.f ; $(FORTRAN) $(OPTS) -c $< TSB08FD.o: TSB08FD.f ; $(FORTRAN) $(OPTS) -c $< TSB08MD.o: TSB08MD.f ; $(FORTRAN) $(OPTS) -c $< TSB08ND.o: TSB08ND.f ; $(FORTRAN) $(OPTS) -c $< TSB09MD.o: TSB09MD.f ; $(FORTRAN) $(OPTS) -c $< TSB10DD.o: TSB10DD.f ; $(FORTRAN) $(OPTS) -c $< TSB10ED.o: TSB10ED.f ; $(FORTRAN) $(OPTS) -c $< TSB10FD.o: TSB10FD.f ; $(FORTRAN) $(OPTS) -c $< TSB10HD.o: TSB10HD.f ; $(FORTRAN) $(OPTS) -c $< TSB10ID.o: TSB10ID.f ; $(FORTRAN) $(OPTS) -c $< TSB10KD.o: TSB10KD.f ; $(FORTRAN) $(OPTS) -c $< TSB10ZD.o: TSB10ZD.f ; $(FORTRAN) $(OPTS) -c $< TSB16AD.o: TSB16AD.f ; $(FORTRAN) $(OPTS) -c $< TSB16BD.o: TSB16BD.f ; $(FORTRAN) $(OPTS) -c $< TSB16CD.o: TSB16CD.f ; $(FORTRAN) $(OPTS) -c $< TSG02AD.o: TSG02AD.f ; $(FORTRAN) $(OPTS) -c $< TSG03AD.o: TSG03AD.f ; $(FORTRAN) $(OPTS) -c $< TSG03BD.o: TSG03BD.f ; $(FORTRAN) $(OPTS) -c $< TTB01ID.o: TTB01ID.f ; $(FORTRAN) $(OPTS) -c $< TTB01KD.o: TTB01KD.f ; $(FORTRAN) $(OPTS) -c $< TTB01LD.o: TTB01LD.f ; $(FORTRAN) $(OPTS) -c $< TTB01MD.o: TTB01MD.f ; $(FORTRAN) $(OPTS) -c $< TTB01ND.o: TTB01ND.f ; $(FORTRAN) $(OPTS) -c $< TTB01PD.o: TTB01PD.f ; $(FORTRAN) $(OPTS) -c $< TTB01TD.o: TTB01TD.f ; $(FORTRAN) $(OPTS) -c $< TTB01UD.o: TTB01UD.f ; $(FORTRAN) $(OPTS) -c $< TTB01WD.o: TTB01WD.f ; $(FORTRAN) $(OPTS) -c $< TTB01ZD.o: TTB01ZD.f ; $(FORTRAN) $(OPTS) -c $< TTB03AD.o: TTB03AD.f ; $(FORTRAN) $(OPTS) -c $< TTB04AD.o: TTB04AD.f ; $(FORTRAN) $(OPTS) -c $< TTB04BD.o: TTB04BD.f ; $(FORTRAN) $(OPTS) -c $< TTB04CD.o: TTB04CD.f ; $(FORTRAN) $(OPTS) -c $< TTB05AD.o: TTB05AD.f ; $(FORTRAN) $(OPTS) -c $< TTC01OD.o: TTC01OD.f ; $(FORTRAN) $(OPTS) -c $< TTC04AD.o: TTC04AD.f ; $(FORTRAN) $(OPTS) -c $< TTC05AD.o: TTC05AD.f ; $(FORTRAN) $(OPTS) -c $< TTD03AD.o: TTD03AD.f ; $(FORTRAN) $(OPTS) -c $< TTD04AD.o: TTD04AD.f ; $(FORTRAN) $(OPTS) -c $< TTD05AD.o: TTD05AD.f ; $(FORTRAN) $(OPTS) -c $< TTF01MD.o: TTF01MD.f ; $(FORTRAN) $(OPTS) -c $< TTF01ND.o: TTF01ND.f ; $(FORTRAN) $(OPTS) -c $< TTF01OD.o: TTF01OD.f ; $(FORTRAN) $(OPTS) -c $< TTF01PD.o: TTF01PD.f ; $(FORTRAN) $(OPTS) -c $< TTF01QD.o: TTF01QD.f ; $(FORTRAN) $(OPTS) -c $< TTF01RD.o: TTF01RD.f ; $(FORTRAN) $(OPTS) -c $< TTG01AD.o: TTG01AD.f ; $(FORTRAN) $(OPTS) -c $< TTG01CD.o: TTG01CD.f ; $(FORTRAN) $(OPTS) -c $< TTG01DD.o: TTG01DD.f ; $(FORTRAN) $(OPTS) -c $< TTG01ED.o: TTG01ED.f ; $(FORTRAN) $(OPTS) -c $< TTG01FD.o: TTG01FD.f ; $(FORTRAN) $(OPTS) -c $< TTG01HD.o: TTG01HD.f ; $(FORTRAN) $(OPTS) -c $< TTG01ID.o: TTG01ID.f ; $(FORTRAN) $(OPTS) -c $< TTG01JD.o: TTG01JD.f ; $(FORTRAN) $(OPTS) -c $< TUD01BD.o: TUD01BD.f ; $(FORTRAN) $(OPTS) -c $< TUD01CD.o: TUD01CD.f ; $(FORTRAN) $(OPTS) -c $< TUD01DD.o: TUD01DD.f ; $(FORTRAN) $(OPTS) -c $< TUD01MD.o: TUD01MD.f ; $(FORTRAN) $(OPTS) -c $< TUD01ND.o: TUD01ND.f ; $(FORTRAN) $(OPTS) -c $< TMB03TD.o: TMB03TD.f ; $(FORTRAN) $(OPTS) -c $< TMB03XD.o: TMB03XD.f ; $(FORTRAN) $(OPTS) -c $< TMB03XP.o: TMB03XP.f ; $(FORTRAN) $(OPTS) -c $< TMB03ZD.o: TMB03ZD.f ; $(FORTRAN) $(OPTS) -c $< TMB04DD.o: TMB04DD.f ; $(FORTRAN) $(OPTS) -c $< TMB04DS.o: TMB04DS.f ; $(FORTRAN) $(OPTS) -c $< TMB04PB.o: TMB04PB.f ; $(FORTRAN) $(OPTS) -c $< TMB04PU.o: TMB04PU.f ; $(FORTRAN) $(OPTS) -c $< TMB04TB.o: TMB04TB.f ; $(FORTRAN) $(OPTS) -c $< TMB04TS.o: TMB04TS.f ; $(FORTRAN) $(OPTS) -c $< TAB08NZ.o: TAB08NZ.f ; $(FORTRAN) $(OPTS) -c $< TAG08BZ.o: TAG08BZ.f ; $(FORTRAN) $(OPTS) -c $< TTB01IZ.o: TTB01IZ.f ; $(FORTRAN) $(OPTS) -c $< TTG01AZ.o: TTG01AZ.f ; $(FORTRAN) $(OPTS) -c $< TTG01FZ.o: TTG01FZ.f ; $(FORTRAN) $(OPTS) -c $< TMB03BD.o: TMB03BD.f ; $(FORTRAN) $(OPTS) -c $< TMB03KD.o: TMB03KD.f ; $(FORTRAN) $(OPTS) -c $< TMB03LD.o: TMB03LD.f ; $(FORTRAN) $(OPTS) -c $< TMB04AD.o: TMB04AD.f ; $(FORTRAN) $(OPTS) -c $< TMB04BD.o: TMB04BD.f ; $(FORTRAN) $(OPTS) -c $< .f.o: ; $(FORTRAN) $(OPTS) -c $< slicot-5.0+20101122/examples77/readme000077500000000000000000000021541201767322700167270ustar00rootroot00000000000000SLICOT Library Subdirectory examples77 -------------------------------------- SLICOT Library Subdirectory examples77 contains all source files for the Fortran 77 example programs calling the SLICOT Library routines, the associated data files (files *.dat), and reference results (files *.res). The Fortran files differ from those in the subdirectory examples in having references to the INTRINSIC functions MAX and MIN in PARAMETER statements avoided, as they are not allowed in Fortran 77. The reference results have been computed on a Sun Ultra 2 machine, for the Unix distribution, and on an Intel Pentium 3 machine, for the Windows distribution. If executable Fortran 77 example programs are created when installing the SLICOT software (as described in the Installation.txt file from the SLICOT root directory), these programs are executed and their results are stored in the files *.exa (with the same name as for the files with data and reference results, and extension exa). More details for executing other tasks, e.g., cleaning the subdirectory examples77, are given in the file makefile included in this subdirectory. slicot-5.0+20101122/gpl-2.0.txt000077500000000000000000000431031201767322700153720ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. slicot-5.0+20101122/libindex.html000077500000000000000000000770241201767322700162470ustar00rootroot00000000000000 On-Line SLICOT Overview

SLICOT LIBRARY INDEX

To go to the beginning of a chapter click on the appropriate letter below:

A ; B ; C ; D ; F ; I ; M ; N ; S ; T ; U ;

or Return to SLICOT homepage
or Go to SLICOT Supporting Routines Index

A - Analysis Routines

AB - State-Space Analysis

Canonical and Quasi Canonical Forms


AB01MD   Orthogonal controllability form for single-input system

AB01ND   Orthogonal controllability staircase form for multi-input system

AB01OD   Staircase form for multi-input system using orthogonal transformations

Continuous/Discrete Time


AB04MD   Discrete-time <-> continuous-time conversion by bilinear transformation

Interconnections of Subsystems


AB05MD   Cascade inter-connection of two systems in state-space form

AB05ND   Feedback inter-connection of two systems in state-space form

AB05OD   Rowwise concatenation of two systems in state-space form

AB05PD   Parallel inter-connection of two systems in state-space form

AB05QD   Appending two systems in state-space form

AB05RD   Closed-loop system for a mixed output and state feedback control law

AB05SD   Closed-loop system for an output feedback control law

Inverse and Dual Systems


AB07MD   Dual of a given state-space representation

AB07ND   Inverse of a given state-space representation

Poles, Zeros, Gain


AB08MD   Normal rank of the transfer-function matrix of a state space model

AB08MZ   Normal rank of the transfer-function matrix of a state space model (complex case)

AB08ND   System zeros and Kronecker structure of system pencil

AB08NZ   System zeros and Kronecker structure of system pencil (complex case)

Model Reduction


AB09AD   Balance & Truncate model reduction   

AB09BD   Singular perturbation approximation based model reduction 

AB09CD   Hankel norm approximation based model reduction 

AB09DD   Singular perturbation approximation formulas 

AB09ED   Hankel norm approximation based model reduction of unstable systems

AB09FD   Balance & Truncate model reduction of coprime factors

AB09GD   Singular perturbation approximation of coprime factors

AB09HD   Stochastic balancing based model reduction

AB09ID   Frequency-weighted model reduction based on balancing techniques

AB09JD   Frequency-weighted Hankel norm approximation with invertible weights

AB09KD   Frequency-weighted Hankel-norm approximation

AB09MD   Balance & Truncate model reduction for the stable part  

AB09ND   Singular perturbation approximation based model reduction for the   
         stable part

System Norms


AB13AD   Hankel-norm of the stable projection   

AB13BD   H2 or L2 norm of a system 

AB13CD   H-infinity norm of a continuous-time stable system
         (obsolete, replaced by AB13DD)

AB13DD   L-infinity norm of a state space system

AB13ED   Complex stability radius, using bisection

AB13FD   Complex stability radius, using bisection and SVD

AB13MD   Upper bound on the structured singular value for a square 
         complex matrix

AG - Generalized State-Space Analysis

Inverse and Dual Systems


AG07BD   Descriptor inverse of a state-space or descriptor representation

Poles, Zeros, Gain


AG08BD   Zeros and Kronecker structure of a descriptor system pencil

AG08BZ   Zeros and Kronecker structure of a descriptor system pencil (complex case)

B - Benchmark and Test Problems

BB - State-space Models


BB01AD   Benchmark examples for continuous-time Riccati equations

BB02AD   Benchmark examples for discrete-time Riccati equations

BB03AD   Benchmark examples of (generalized) continuous-time Lyapunov equations

BB04AD   Benchmark examples of (generalized) discrete-time Lyapunov equations

BD - Generalized State-space Models


BD01AD   Benchmark examples of continuous-time systems

BD02AD   Benchmark examples of discrete-time systems

C - Adaptive Control

D - Data Analysis

DE - Covariances


DE01OD   Convolution or deconvolution of two signals

DE01PD   Convolution or deconvolution of two real signals using Hartley transform

DF - Spectra


DF01MD   Sine transform or cosine transform of a real signal

DG - Discrete Fourier and Hartley Transforms


DG01MD   Discrete Fourier transform of a complex signal

DG01ND   Discrete Fourier transform of a real signal

DG01OD   Scrambled discrete Hartley transform of a real signal

DK - Windowing


DK01MD   Anti-aliasing window applied to a real signal

F - Filtering

FB - Kalman Filters


FB01QD   Time-varying square root covariance filter (dense matrices)

FB01RD   Time-invariant square root covariance filter (Hessenberg form) 

FB01SD   Time-varying square root information filter (dense matrices)

FB01TD   Time-invariant square root information filter (Hessenberg form) 

FB01VD   One recursion of the conventional Kalman filter

FD - Fast Recursive Least Squares Filters


FD01AD   Fast recursive least-squares filter

I - Identification

IB - Subspace Identification

Time Invariant State-space Systems


IB01AD   Input-output data preprocessing and finding the system order

IB01BD   Estimating the system matrices, covariances, and Kalman gain

IB01CD   Estimating the initial state and the system matrices B and D

Wiener Systems


IB03AD   Estimating a Wiener system by a Levenberg-Marquardt algorithm
         (Cholesky-based or conjugate gradients solver)

IB03BD   Estimating a Wiener system by a MINPACK-like Levenberg-Marquardt
         algorithm

M - Mathematical Routines

MB - Linear Algebra

Basic Linear Algebra Manipulations


MB01PD   Matrix scaling (higher level routine)

MB01QD   Matrix scaling (lower level routine)

MB01RD   Computation of matrix expression alpha*R + beta*A*X*trans(A)

MB01TD   Product of two upper quasi-triangular matrices 

MB01UD   Computation of matrix expressions alpha*H*A or alpha*A*H,
         with H an upper Hessenberg matrix

MB01UX   Computation of matrix expressions alpha*T*A or alpha*A*T, T quasi-triangular

MB01WD   Residuals of Lyapunov or Stein equations for Cholesky factored 
         solutions

MB01XD   Computation of the product U'*U or L*L', with U and L upper and 
         lower triangular matrices (block algorithm)

MB01YD   Symmetric rank k operation C := alpha*A*A' + beta*C, C symmetric

MB01ZD   Computation of matrix expressions H := alpha*T*H, or H := alpha*H*T,
         with H Hessenberg-like, T triangular

Linear Equations and Least Squares


MB02CD   Cholesky factorization of a positive definite block Toeplitz matrix

MB02DD   Updating Cholesky factorization of a positive definite block 
         Toeplitz matrix

MB02ED   Solution of T*X = B or X*T = B, with T a positive definite
         block Toeplitz matrix

MB02FD   Incomplete Cholesky factor of a positive definite block Toeplitz matrix

MB02GD   Cholesky factorization of a banded symmetric positive definite
         block Toeplitz matrix

MB02HD   Cholesky factorization of the matrix T'*T, with T a banded
         block Toeplitz matrix of full rank

MB02ID   Solution of over- or underdetermined linear systems with a full rank
         block Toeplitz matrix

MB02JD   Full QR factorization of a block Toeplitz matrix of full rank

MB02JX   Low rank QR factorization with column pivoting of a block Toeplitz matrix

MB02KD   Computation of the product C = alpha*op( T )*B + beta*C, with T
         a block Toeplitz matrix

MB02MD   Solution of Total Least-Squares problem using a SVD approach

MB02ND   Solution of Total Least-Squares problem using a partial SVD approach

MB02OD   Solution of op(A)*X = alpha*B, or X*op(A) = alpha*B, A triangular 

MB02PD   Solution of matrix equation op(A)*X = B, with error bounds 
         and condition estimates

MB02QD   Solution, optionally corresponding to specified free elements, 
         of a linear least squares problem

MB02RD   Solution of a linear system with upper Hessenberg matrix

MB02RZ   Solution of a linear system with complex upper Hessenberg matrix

MB02SD   LU factorization of an upper Hessenberg matrix

MB02SZ   LU factorization of a complex upper Hessenberg matrix

MB02TD   Condition number of an upper Hessenberg matrix

MB02TZ   Condition number of a complex upper Hessenberg matrix

MB02UD   Minimum norm least squares solution of op(R)*X = B, or X*op(R) = B,
         using singular value decomposition (R upper triangular)

MB02VD   Solution of X*op(A) = B

Eigenvalues and Eigenvectors


MB03MD   Upper bound for L singular values of a bidiagonal matrix

MB03ND   Number of singular values of a bidiagonal matrix less than a bound

MB03OD   Matrix rank determination by incremental condition estimation

MB03PD   Matrix rank determination (row pivoting)

MB03QD   Reordering of the diagonal blocks of a real Schur matrix

MB03RD   Reduction of a real Schur matrix to a block-diagonal form

MB03SD   Eigenvalues of a square-reduced Hamiltonian matrix

MB03TD   Reordering the diagonal blocks of a matrix in (skew-)Hamiltonian Schur form

MB03UD   Singular value decomposition of an upper triangular matrix

MB03VD   Periodic Hessenberg form of a product of matrices

MB03WD   Periodic Schur decomposition and eigenvalues of a product of
         matrices in periodic Hessenberg form

MB03XD   Eigenvalues of a Hamiltonian matrix

MB03XP   Periodic Schur decomposition and eigenvalues of a matrix product A*B, 
         A upper Hessenberg and B upper triangular

MB03YD   Periodic QR iteration

MB03ZD   Stable and unstable invariant subspaces for a dichotomic Hamiltonian matrix

Decompositions and Transformations


MB04GD   RQ factorization of a matrix with row pivoting

MB04ID   QR factorization of a matrix with a lower left zero triangle

MB04IZ   QR factorization of a matrix with a lower left zero triangle (complex case)

MB04JD   LQ factorization of a matrix with an upper right zero triangle

MB04KD   QR factorization of a special structured block matrix

MB04LD   LQ factorization of a special structured block matrix

MB04MD   Balancing a general real matrix

MB04ND   RQ factorization of a special structured block matrix

MB04OD   QR factorization of a special structured block matrix (variant)

MB04PB   Paige/Van Loan form of a Hamiltonian matrix

MB04TB   Symplectic URV decomposition of a real 2N-by-2N matrix

MB04UD   Unitary column echelon form for a rectangular matrix 

MB04VD   Upper block triangular form for a rectangular pencil

MB04XD   Basis for left/right null singular subspace of a matrix  

MB04YD   Partial diagonalization of a bidiagonal matrix  

MB04ZD   Transforming a Hamiltonian matrix into a square-reduced form

Matrix Functions


MB05MD   Matrix exponential for a real non-defective matrix 

MB05ND   Matrix exponential and integral for a real matrix 

MB05OD   Matrix exponential for a real matrix, with accuracy estimate

MC - Polynomial and Rational Function Manipulation

Scalar Polynomials


MC01MD   The leading coefficients of the shifted polynomial  

MC01ND   Value of a real polynomial at a given complex point  

MC01OD   Coefficients of a complex polynomial, given its zeros  

MC01PD   Coefficients of a real polynomial, given its zeros  

MC01QD   Quotient and remainder polynomials for polynomial division 

MC01RD   Polynomial operation P(x) = P1(x) P2(x) + alpha P3(x)  

MC01SD   Scaling coefficients of a real polynomial for minimal variation  

MC01TD   Checking stability of a given real polynomial  

MC01VD   Roots of a quadratic equation with real coefficients  

MC01WD   Quotient and remainder polynomials for a quadratic denominator

Polynomial Matrices


MC03MD   Real polynomial matrix operation P(x) = P1(x) P2(x) + alpha P3(x)  

MC03ND   Minimal polynomial basis for the right nullspace of a polynomial matrix

MD - Optimization

Unconstrained Nonlinear Least Squares


MD03AD   Levenberg-Marquardt algorithm (Cholesky-based or conjugate
         gradients solver)

MD03BD   Enhanced MINPACK-like Levenberg-Marquardt algorithm

N - Nonlinear Systems

NI - Interfaces to Nonlinear Solvers

ODE and DAE Solvers


DAESolver    Interface to DAE Solvers

ODESolver    Interface to ODE Solvers

Nonlinear Equation Solvers


KINSOL    Interface to KINSOL solver for nonlinear systems of equations

Nonlinear Optimization Solvers


FSQP    Interface to FSQP solver for nonlinear optimization

S - Synthesis Routines

SB - State-Space Synthesis

Eigenvalue/Eigenvector Assignment


SB01BD    Pole assignment for a given matrix pair (A,B)

SB01DD    Eigenstructure assignment for a controllable matrix pair (A,B) in
          orthogonal canonical form

SB01MD    State feedback matrix of a time-invariant single-input system

Riccati Equations


SB02MD    Solution of algebraic Riccati equations (Schur vectors method)

SB02MT    Conversion of problems with coupling terms to standard problems

SB02ND    Optimal state feedback matrix for an optimal control problem

SB02OD    Solution of algebraic Riccati equations (generalized Schur method)

SB02PD    Solution of continuous algebraic Riccati equations (matrix sign 
          function method) with condition and forward error bound estimates

SB02QD    Condition and forward error for continuous Riccati equation solution

SB02RD    Solution of algebraic Riccati equations (refined Schur vectors method) 
          with condition and forward error bound estimates

SB02SD    Condition and forward error for discrete Riccati equation solution

Lyapunov Equations


SB03MD    Solution of Lyapunov equations and separation estimation

SB03OD    Solution of stable Lyapunov equations (Cholesky factor)

SB03PD    Solution of discrete Lyapunov equations and separation estimation

SB03QD    Condition and forward error for continuous Lyapunov equations

SB03RD    Solution of continuous Lyapunov equations and separation estimation

SB03SD    Condition and forward error for discrete Lyapunov equations

SB03TD    Solution of continuous Lyapunov equations, condition and forward error 
          estimation

SB03UD    Solution of discrete Lyapunov equations, condition and forward error 
          estimation

Sylvester Equations


SB04MD    Solution of continuous Sylvester equations (Hessenberg-Schur method)

SB04ND    Solution of continuous Sylvester equations (one matrix in Schur form)

SB04OD    Solution of generalized Sylvester equations with separation estimation

SB04PD    Solution of continuous or discrete Sylvester equations (Schur method)

SB04QD    Solution of discrete Sylvester equations (Hessenberg-Schur method)

SB04RD    Solution of discrete Sylvester equations (one matrix in Schur form)

Deadbeat Control


SB06ND    Minimum norm deadbeat control state feedback matrix

Transfer Matrix Factorization


SB08CD    Left coprime factorization with inner denominator

SB08DD    Right coprime factorization with inner denominator

SB08ED    Left coprime factorization with prescribed stability degree

SB08FD    Right coprime factorization with prescribed stability degree

SB08GD    State-space representation of a left coprime factorization

SB08HD    State-space representation of a right coprime factorization

SB08MD    Spectral factorization of polynomials (continuous-time case)

SB08ND    Spectral factorization of polynomials (discrete-time case)

Realization Methods


SB09MD    Closeness of two multivariable sequences

Optimal Regulator Problems


SB10AD    H-infinity optimal controller using modified Glover's and Doyle's
          formulas (continuous-time)

SB10DD    H-infinity (sub)optimal state controller for a discrete-time system

SB10ED    H2 optimal state controller for a discrete-time system

SB10FD    H-infinity (sub)optimal state controller for a continuous-time system

SB10HD    H2 optimal state controller for a continuous-time system

SB10MD    D-step in the D-K iteration for continuous-time case

SB10ID    Positive feedback controller for a continuous-time system

SB10KD    Positive feedback controller for a discrete-time system

SB10ZD    Positive feedback controller for a discrete-time system (D <> 0)

Controller Reduction


SB16AD    Stability/performance enforcing frequency-weighted controller reduction

SB16BD    Coprime factorization based state feedback controller reduction

SB16CD    Coprime factorization based frequency-weighted state feedback 
          controller reduction

SG - Generalized State-Space Synthesis

Riccati Equations


SG02AD    Solution of algebraic Riccati equations for descriptor systems

Generalized Lyapunov Equations


SG03AD    Solution of generalized Lyapunov equations and separation estimation

SG03BD    Solution of stable generalized Lyapunov equations (Cholesky factor)

T - Transformation Routines

TB - State-Space

State-Space Transformations


TB01ID   Balancing a system matrix for a given triplet

TB01IZ   Balancing a system matrix for a given triplet (complex case)

TB01KD   Additive spectral decomposition of a state-space system 

TB01LD   Spectral separation of a state-space system

TB01MD   Upper/lower controller Hessenberg form

TB01ND   Upper/lower observer Hessenberg form 

TB01PD   Minimal, controllable or observable block Hessenberg realization 

TB01TD   Balancing state-space representation by permutations and scalings

TB01UD   Controllable block Hessenberg realization for a state-space representation 

TB01WD   Reduction of the state dynamics matrix to real Schur form 

TB01ZD   Controllable realization for single-input systems

State-Space to Polynomial Matrix Conversion


TB03AD   Left/right polynomial matrix representation of a state-space representation

State-Space to Rational Matrix Conversion


TB04AD   Transfer matrix of a state-space representation  

TB04BD   Transfer matrix of a state-space representation, using the pole-zeros method

TB04CD   Transfer matrix of a state-space representation in the pole-zero-gain form

State-Space to Frequency Response


TB05AD   Frequency response matrix of a state-space representation

TC - Polynomial Matrix

Polynomial Matrix Transformations


TC01OD   Dual of a left/right polynomial matrix representation

Polynomial Matrix to State-Space Conversion


TC04AD   State-space representation for left/right polynomial matrix representation

Polynomial Matrix to Frequency Response


TC05AD   Transfer matrix of a left/right polynomial matrix representation

TD - Rational Matrix

Rational Matrix to Polynomial Matrix Conversion


TD03AD   Left/right polynomial matrix representation for a proper transfer matrix

Rational Matrix to State-Space Conversion


TD04AD   Minimal state-space representation for a proper transfer matrix

Rational Matrix to Frequency Response


TD05AD   Evaluation of a transfer function for a specified frequency

TF - Time Response


TF01MD   Output response of a linear discrete-time system

TF01ND   Output response of a linear discrete-time system (Hessenberg matrix)

TF01OD   Block Hankel expansion of a multivariable parameter sequence

TF01PD   Block Toeplitz expansion of a multivariable parameter sequence

TF01QD   Markov parameters of a system from transfer function matrix

TF01RD   Markov parameters of a system from state-space representation

TG - Generalized State-space

Generalized State-space Transformations


TG01AD   Balancing the matrices of the system pencil corresponding to a
         descriptor triple

TG01AZ   Balancing the matrices of the system pencil corresponding to a
         descriptor triple (complex case)

TG01BD   Orthogonal reduction of a descriptor system to the generalized 
         Hessenberg form

TG01CD   Orthogonal reduction of a descriptor system pair (A-sE,B)
         to the QR-coordinate form

TG01DD   Orthogonal reduction of a descriptor system pair (C,A-sE)
         to the RQ-coordinate form

TG01ED   Orthogonal reduction of a descriptor system to a SVD coordinate 
         form

TG01FD   Orthogonal reduction of a descriptor system to a SVD-like
         coordinate form

TG01FZ   Orthogonal reduction of a descriptor system to a SVD-like 
         coordinate form (complex case)

TG01HD   Orthogonal reduction of a descriptor system to the controllability
         staircase form

TG01ID   Orthogonal reduction of a descriptor system to the observability
         staircase form

TG01JD   Irreducible descriptor representation

TG01WD   Reduction of the descriptor dynamics matrix pair to generalized 
         real Schur form

U - Utility Routines

UD - Numerical Data Handling


UD01BD   Reading a matrix polynomial

UD01CD   Reading a sparse matrix polynomial

UD01DD   Reading a sparse real matrix

UD01MD   Printing a real matrix

UD01MZ   Printing a real matrix (complex case)

UD01ND   Printing a matrix polynomial

UE01MD   Default machine-specific parameters for (skew-)Hamiltonian computation routines
slicot-5.0+20101122/make.inc000077500000000000000000000026771201767322700151750ustar00rootroot00000000000000#################################################################### # SLICOT make include file. # # SLICOT, Release 5.0 ./slicot/make.inc # # Vasile Sima, KU Leuven # # October 31, 1996. # # Revised December 7, 1999; February 14, 2005. # #################################################################### # # The machine (platform) identifier to append to the library names # # PLAT = _sun4 # # Modify the FORTRAN and OPTS definitions to refer to the # compiler and desired compiler options for your machine. NOOPT # refers to the compiler options desired when NO OPTIMIZATION is # selected. Define LOADER and LOADOPTS to refer to the loader and # desired load options for your machine. # FORTRAN = f77 OPTS = -O4 -native -u NOOPT = -u LOADER = f77 LOADOPTS = $(SLICOTLIB) $(LPKAUXLIB) $(LAPACKLIB) # # The archiver and the flag(s) to use when building archive (library) # If your system has no ranlib, set RANLIB = echo. # ARCH = ar ARCHFLAGS= r # ARCHFLAGS= cr # RANLIB = ranlib # # The location of the libraries to which you will link. (The # machine-specific, optimized BLAS library should be used whenever # possible.) # #BLASLIB = -L/software/lib LAPACKLIB = -L/software/lib -llapack -lblas SLICOTLIB = ../slicot.a LPKAUXLIB = ../lpkaux.a slicot-5.0+20101122/makefile000077500000000000000000000032771201767322700152620ustar00rootroot00000000000000#################################################################### # SLICOT main makefile # # Top Level Makefile for generating SLICOT Library object file, # # the auxiliary library file, and linking and running the example # # programs. # # SLICOT, Release 5.0 ./slicot/makefile # # October 31, 1996 # # Revised December 7, 1999; February 14, 2005. # #################################################################### # # This makefile creates/updates the SLICOT Library object file, the # auxiliary library, and compiles, links, and runs the example # programs for the SLICOT Library. To perform all these actions, # enter # make # # To create/update the library for SLICOT and auxiliary library, # enter # make lib # # To compile, link, and run the example programs, enter # make example # # To remove the object files for SLICOT routines and auxiliary # routines, enter # make cleanlib # # To remove the files with the computed results (*.exa), enter # make cleanexample # # To remove the object files for SLICOT routines and auxiliary # routines, as well as the files with the computed results (*.exa), # enter # make clean # #################################################################### include make.inc all: lib example clean: cleanlib cleanexample lib: ( cd src; $(MAKE) ) ( cd src_aux; $(MAKE) ) example: ( cd examples; $(MAKE) ) cleanlib: ( cd src; $(MAKE) clean ) ( cd src_aux; $(MAKE) clean ) cleanexample: ( cd examples; $(MAKE) clean ) slicot-5.0+20101122/readme000077500000000000000000000062441201767322700147370ustar00rootroot00000000000000SLICOT Library Root Directory ----------------------------- SLICOT - Subroutine Library In COntrol Theory - is a general purpose basic mathematical library for control theoretical computations. The library provides tools to perform essential system analysis and synthesis tasks. The main emphasis in SLICOT is on numerical reliability of implemented algorithms and the numerical robustness and efficiency of routines. Providing algorithmic flexibility and the use of rigorous implementation and documentation standards are other SLICOT features. The SLICOT Library is available as standard Fortran 77 code in double precision. Each user-callable subroutine for control computations is accompanied by an example program which illustrates the use of the subroutine and can act as a template for the user's own routines. The SLICOT Library is organized by chapters, sections and subsections. The following chapters are currently included: A : Analysis Routines B : Benchmark and Test Problems D : Data Analysis F : Filtering I : Identification M : Mathematical Routines N : Nonlinear Systems (not yet available, except for some auxiliary routines for Wiener systems) S : Synthesis Routines T : Transformation Routines U : Utility Routines SLICOT Library Root Directory contains few, basic files for the SLICOT Library distribution and generation. When distributed, SLICOT software comes with several filled-in subdirectories (benchmark_data, doc, examples, examples77, src, and src_aux), and five files in this root directory: - this file, readme, - the file Installation.txt, describing the SLICOT software installation, - the main SLICOT Library documentation index, libindex.html, and - two template files for building the object library and executable programs, make.inc and makefile, - GNU GENERAL PUBLIC LICENSE Version 2 text file. The last two files might need few changes for being adapted to the specific platform used. Details about installing/updating the SLICOT software are given in the file Installation.txt. After software installation, this directory will also contain the library file slicot.a or slicot.lib, for Unix or Windows platforms, respectively. The library file could then be linked in applications programs, as usual. Specific examples are contained in the directories examples and examples77. The on-line documentation of the SLICOT user's callable routines is accessible via the main SLICOT Library documentation index, libindex.html. This file also contains a link to the documentation of the lower-level, support routines. The SLICOT Library is built on LAPACK (Linear Algebra PACKage) and BLAS (Basic Linear Algebra Subprograms) collections. Therefore, these packages should be available on the platform used. Basic References: 1. P. Benner, V. Mehrmann, V. Sima, S. Van Huffel, and A. Varga, "SLICOT - A Subroutine Library in Systems and Control Theory", Applied and Computational Control, Signals, and Circuits (Birkhauser), Vol. 1, Ch. 10, pp. 505-546, 1999. 2. S. Van Huffel, V. Sima, A. Varga, S. Hammarling, and F. Delebecque, "Development of High Performance Numerical Software for Control", IEEE Control Systems Magazine, Vol. 24, Nr. 1, Feb., pp. 60-76, 2004. slicot-5.0+20101122/src/000077500000000000000000000000001201767322700143355ustar00rootroot00000000000000slicot-5.0+20101122/src/AB01MD.f000077500000000000000000000334761201767322700153700ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB01ND.f000077500000000000000000000411631201767322700153610ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB01OD.f000077500000000000000000000503071201767322700153620ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB04MD.f000077500000000000000000000262161201767322700153650ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB05MD.f000077500000000000000000000436341201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB05ND.f000077500000000000000000000446721201767322700153750ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB05OD.f000077500000000000000000000326341201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB05PD.f000077500000000000000000000306261201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB05QD.f000077500000000000000000000337061201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB05RD.f000077500000000000000000000331771201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB05SD.f000077500000000000000000000302561201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB07MD.f000077500000000000000000000153351201767322700153700ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB07ND.f000077500000000000000000000237351201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB08MD.f000077500000000000000000000237231201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB08MZ.f000077500000000000000000000241641201767322700154170ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB08ND.f000077500000000000000000000453651201767322700154000ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB08NX.f000077500000000000000000000370051201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB08NZ.f000077500000000000000000000461601201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB09AD.f000077500000000000000000000317051201767322700153550ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09AX.f000077500000000000000000000470411201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09BD.f000077500000000000000000000334571201767322700153640ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09BX.f000077500000000000000000000560231201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09CD.f000077500000000000000000000333471201767322700153630ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09CX.f000077500000000000000000000465651201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09DD.f000077500000000000000000000214211201767322700153520ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09ED.f000077500000000000000000000443561201767322700153670ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09FD.f000077500000000000000000000611341201767322700153610ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09GD.f000077500000000000000000000640141201767322700153620ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09HD.f000077500000000000000000000634531201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09HX.f000077500000000000000000000615121201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09HY.f000077500000000000000000000321101201767322700154000ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB09ID.f000077500000000000000000001261031201767322700153620ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09IX.f000077500000000000000000000613071201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09IY.f000077500000000000000000000770651201767322700154230ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09JD.f000077500000000000000000001633441201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09JV.f000077500000000000000000001072171201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 V. Sima, Research Institute for Informatics, Bucharest, May 2010. 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( 'Precision' ) 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 slicot-5.0+20101122/src/AB09JW.f000077500000000000000000001100741201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 V. Sima, Research Institute for Informatics, Bucharest, May 2010. 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( 'Precision' ) 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 slicot-5.0+20101122/src/AB09JX.f000077500000000000000000000202731201767322700154100ustar00rootroot00000000000000 SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED, $ TOLINF, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB09KD.f000077500000000000000000001042201201767322700153600ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09KX.f000077500000000000000000000765651201767322700154300ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AB09MD.f000077500000000000000000000417531201767322700153750ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB09ND.f000077500000000000000000000437551201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB13AD.f000077500000000000000000000302231201767322700153420ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB13AX.f000077500000000000000000000231621201767322700153720ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB13BD.f000077500000000000000000000330611201767322700153460ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB13CD.f000077500000000000000000000444341201767322700153550ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB13DD.f000077500000000000000000001776651201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB13DX.f000077500000000000000000000450451201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AB13ED.f000077500000000000000000000261771201767322700153630ustar00rootroot00000000000000 SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To estimate beta(A), the 2-norm distance from a real matrix A to C the nearest complex matrix with an eigenvalue on the imaginary C axis. The estimate is given as C C LOW <= beta(A) <= HIGH, C C where either C C (1 + TOL) * LOW >= HIGH, C C or C C LOW = 0 and HIGH = delta, C C and delta is a small number approximately equal to the square root C of machine precision times the Frobenius norm (Euclidean norm) C of A. If A is stable in the sense that all eigenvalues of A lie C in the open left half complex plane, then beta(A) is the distance C to the nearest unstable complex matrix, i.e., the complex C stability radius. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C LOW (output) DOUBLE PRECISION C A lower bound for beta(A). C C HIGH (output) DOUBLE PRECISION C An upper bound for beta(A). C C Tolerances C C TOL DOUBLE PRECISION C Specifies the accuracy with which LOW and HIGH approximate C beta(A). If the user sets TOL to be less than SQRT(EPS), C where EPS is the machine precision (see LAPACK Library C Routine DLAMCH), then the tolerance is taken to be C SQRT(EPS). C The recommended value is TOL = 9, which gives an estimate C of beta(A) correct to within an order of magnitude. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 1, 3*N*(N+1) ). C For optimum performance LDWORK should be larger. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -i, the i-th argument had an illegal C value; C = 1: the QR algorithm (LAPACK Library routine DHSEQR) C fails to converge; this error is very rare. C C METHOD C C Let beta(A) be the 2-norm distance from a real matrix A to the C nearest complex matrix with an eigenvalue on the imaginary axis. C It is known that beta(A) = minimum of the smallest singular C value of (A - jwI), where I is the identity matrix and j**2 = -1, C and the minimum is taken over all real w. C The algorithm computes a lower bound LOW and an upper bound HIGH C for beta(A) by a bisection method in the following way. Given a C non-negative real number sigma, the Hamiltonian matrix H(sigma) C is constructed: C C | A -sigma*I | | A G | C H(sigma) = | | := | | . C | sigma*I -A' | | F -A' | C C It can be shown [1] that H(sigma) has an eigenvalue whose real C part is zero if and only if sigma >= beta. Any lower and upper C bounds on beta(A) can be improved by choosing a number between C them and checking to see if H(sigma) has an eigenvalue with zero C real part. This decision is made by computing the eigenvalues of C H(sigma) using the square reduced algorithm of Van Loan [2]. C C REFERENCES C C [1] Byers, R. C A bisection method for measuring the distance of a stable C matrix to the unstable matrices. C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. C C [2] Van Loan, C.F. C A symplectic method for approximating all the eigenvalues of a C Hamiltonian matrix. C Linear Algebra and its Applications, Vol 61, 233-251, 1984. C C NUMERICAL ASPECTS C C Due to rounding errors the computed values of LOW and HIGH can be C proven to satisfy C C LOW - p(n) * sqrt(e) * norm(A) <= beta(A) C and C beta(A) <= HIGH + p(n) * sqrt(e) * norm(A), C C where p(n) is a modest polynomial of degree 3, e is the machine C precision and norm(A) is the Frobenius norm of A, see [1]. C The recommended value for TOL is 9 which gives an estimate of C beta(A) correct to within an order of magnitude. C AB13ED requires approximately 38*N**3 flops for TOL = 9. C C CONTRIBUTOR C C R. Byers, the routines BISEC and BISEC0 (January, 1995). C C REVISIONS C C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. C C KEYWORDS C C Distances, eigenvalue, eigenvalue perturbation, norms, stability C radius. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION HIGH, LOW, TOL INTEGER INFO, LDA, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*) C .. Local Scalars .. INTEGER I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR, $ JWORK, MINWRK, N2 DOUBLE PRECISION ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2 LOGICAL RNEG, SUFWRK C .. Local Arrays .. DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE C .. External Subroutines .. EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, $ DSYMV, MA02ED, MB04ZD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 MINWRK = 3*N*( N + 1 ) C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB13ED', -INFO ) RETURN END IF C C Quick return if possible. C LOW = ZERO IF ( N.EQ.0 ) THEN HIGH = ZERO DWORK(1) = ONE RETURN END IF C C Indices for splitting the work array. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of real workspace needed at that point in the C code, as well as the preferred amount for good performance.) C N2 = N*N IGF = 1 IA2 = IGF + N2 + N IAA = IA2 + N2 IWK = IAA + N2 IWR = IAA IWI = IWR + N C SUFWRK = LDWORK-IWK.GE.N2 C C Computation of the tolerances and the treshold for termination of C the bisection method. SEPS is the square root of the machine C precision. C SFMN = DLAMCH( 'Safe minimum' ) SEPS = SQRT( DLAMCH( 'Epsilon' ) ) TAU = ONE + MAX( TOL, SEPS ) ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) TOL1 = SEPS * ANRM TOL2 = TOL1 * DBLE( 2*N ) C C Initialization of the bisection method. C HIGH = ANRM C C WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO 10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) ) C C Set up H(sigma). C Workspace: N*(N+1)+2*N*N. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) DWORK(IGF) = SIGMA DWORK(IGF+N) = -SIGMA DUMMY(1) = ZERO CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) C DO 20 I = IGF, IA2 - N - 2, N + 1 CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) 20 CONTINUE C C Computation of the eigenvalues by the square reduced algorithm. C Workspace: N*(N+1)+2*N*N+2*N. C CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, $ DUMMY2, 1, DWORK(IWK), INFO ) C C Form the matrix A*A + F*G. C Workspace: need N*(N+1)+2*N*N+N; C prefer N*(N+1)+3*N*N. C JWORK = IA2 IF ( SUFWRK ) $ JWORK = IWK C CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) C IF ( SUFWRK ) THEN C C Use BLAS 3 calculation. C CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) ELSE C C Use BLAS 2 calculation. C DO 30 I = 1, N CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) 30 CONTINUE C END IF C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) C C Find the eigenvalues of A*A + F*G. C Workspace: N*(N+1)+N*N+3*N. C JWORK = IWI + N CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), $ I ) CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, $ DWORK(JWORK), N, INFO ) C IF ( INFO.NE.0 ) THEN INFO = 1 RETURN END IF C C (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the C squares of the eigenvalues of H(sigma). C I = 0 RNEG = .FALSE. C WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive C .AND. I < N ) DO 40 IF ( .NOT.RNEG .AND. I.LT.N ) THEN TEMP = ABS( DWORK(IWI+I) ) IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) ) I = I + 1 GO TO 40 C END WHILE 40 END IF IF ( RNEG ) THEN HIGH = SIGMA ELSE LOW = SIGMA END IF GO TO 10 C END WHILE 10 END IF C C Set optimal workspace dimension. C DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) ) C C *** Last line of AB13ED *** END slicot-5.0+20101122/src/AB13FD.f000077500000000000000000000323141201767322700153520ustar00rootroot00000000000000 SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, $ CWORK, LCWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB13MD.f000077500000000000000000001647451201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/AB8NXZ.f000077500000000000000000000376711201767322700154770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AG07BD.f000077500000000000000000000220701201767322700153540ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/AG08BD.f000077500000000000000000000531601201767322700153610ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AG08BY.f000077500000000000000000000550531201767322700154110ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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, ZERO PARAMETER ( ONE = 1.0D0, 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, TOLZ, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( ABCD(IRC+J,ICOL) ) / DWORK(J) T = MAX( ( ONE + T )*( ONE - T ), ZERO) TT = T*( DWORK(J)/DWORK(P+J) )**2 IF( TT.GT.TOLZ ) 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 slicot-5.0+20101122/src/AG08BZ.f000077500000000000000000000542221201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/AG8BYZ.f000077500000000000000000000561771201767322700154730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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, ZERO PARAMETER ( ONE = 1.0D0, 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, TOLZ, $ 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( ABCD(IRC+J,ICOL) ) / DWORK(J) T = MAX( ( ONE + T )*( ONE - T ), ZERO) TT = T*( DWORK(J)/DWORK(P+J) )**2 IF( TT.GT.TOLZ ) 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 slicot-5.0+20101122/src/BB01AD.f000077500000000000000000001417501201767322700153500ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/BB02AD.f000077500000000000000000001126161201767322700153500ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/BB03AD.f000077500000000000000000000426031201767322700153470ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/BB04AD.f000077500000000000000000000412341201767322700153470ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/BD01AD.f000077500000000000000000001044531201767322700153510ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/BD02AD.f000077500000000000000000000471201201767322700153470ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/DE01OD.f000077500000000000000000000125151201767322700153670ustar00rootroot00000000000000 SUBROUTINE DE01OD( CONV, N, A, B, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/DE01PD.f000077500000000000000000000152521201767322700153710ustar00rootroot00000000000000 SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/DF01MD.f000077500000000000000000000203451201767322700153660ustar00rootroot00000000000000 SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/DG01MD.f000077500000000000000000000152311201767322700153650ustar00rootroot00000000000000 SUBROUTINE DG01MD( INDI, N, XR, XI, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/DG01ND.f000077500000000000000000000206261201767322700153720ustar00rootroot00000000000000 SUBROUTINE DG01ND( INDI, N, XR, XI, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/DG01NY.f000077500000000000000000000052151201767322700154140ustar00rootroot00000000000000 SUBROUTINE DG01NY( INDI, N, XR, XI ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/DG01OD.f000077500000000000000000000227751201767322700154020ustar00rootroot00000000000000 SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/DK01MD.f000077500000000000000000000115331201767322700153720ustar00rootroot00000000000000 SUBROUTINE DK01MD( TYPE, N, A, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/FB01QD.f000077500000000000000000000424231201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/FB01RD.f000077500000000000000000000473411201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/FB01SD.f000077500000000000000000000555761201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/FB01TD.f000077500000000000000000000606671201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/FB01VD.f000077500000000000000000000327451201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/FD01AD.f000077500000000000000000000322251201767322700153520ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01AD.f000077500000000000000000000720771201767322700153640ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01BD.f000077500000000000000000000775701201767322700153700ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01CD.f000077500000000000000000001043761201767322700153640ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01MD.f000077500000000000000000001472211201767322700153720ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01MY.f000077500000000000000000001156171201767322700154230ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01ND.f000077500000000000000000000673111201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01OD.f000077500000000000000000000146001201767322700153660ustar00rootroot00000000000000 SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01OY.f000077500000000000000000000123421201767322700154140ustar00rootroot00000000000000 SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01PD.f000077500000000000000000001425231201767322700153750ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01PX.f000077500000000000000000000402031201767322700154110ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01PY.f000077500000000000000000000726351201767322700154300ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should 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 slicot-5.0+20101122/src/IB01QD.f000077500000000000000000001157601201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB01RD.f000077500000000000000000000657301201767322700154030ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/IB03AD.f000077500000000000000000001300661201767322700153570ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/IB03BD.f000077500000000000000000001317421201767322700153620ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MA01AD.f000077500000000000000000000054411201767322700153560ustar00rootroot00000000000000 SUBROUTINE MA01AD( XR, XI, YR, YI ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MA01BD.f000077500000000000000000000100121201767322700153450ustar00rootroot00000000000000 SUBROUTINE MA01BD( BASE, LGBAS, K, S, A, INCA, ALPHA, BETA, SCAL ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To compute the general product of K real scalars without over- C or underflow. C C ARGUMENTS C C Input/Output Parameters C C BASE (input) DOUBLE PRECISION C Machine base. C C LGBAS (input) DOUBLE PRECISION C Logarithm of BASE. C C K (input) INTEGER C The number of scalars. K >= 1. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C A (input) DOUBLE PRECISION array, dimension (K) C Vector of real scalars. C C INCA (input) INTEGER C Increment for the array A. INCA <> 0. C C ALPHA (output) DOUBLE PRECISION C ALPHA is a real scalar such that C C ALPHA / BETA * BASE**(SCAL) C C is the general product of the scalars in the array A. C C BETA (output) DOUBLE PRECISION C BETA is either 0.0 or 1.0. C See also the description of ALPHA. C C SCAL (output) INTEGER C Scaling factor exponent, see ALPHA. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLAPR1. C C KEYWORDS C C Computer arithmetic, overflow, underflow. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INCA, K, SCAL DOUBLE PRECISION ALPHA, BASE, BETA, LGBAS C .. Array Arguments .. INTEGER S(*) DOUBLE PRECISION A(*) C .. Local Scalars .. INTEGER I, SL DOUBLE PRECISION TEMP C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, MOD C C .. Executable Statements .. C ALPHA = ONE BETA = ONE SCAL = 0 C DO 10 I = 1, K TEMP = A( 1 + ( I - 1 )*INCA ) IF ( TEMP.NE.ZERO ) THEN SL = INT( LOG( ABS( TEMP ) ) / LGBAS ) TEMP = TEMP / ( BASE**DBLE( SL ) ) END IF IF ( S(I).EQ.1 ) THEN ALPHA = ALPHA * TEMP SCAL = SCAL + SL ELSE BETA = BETA * TEMP SCAL = SCAL - SL END IF IF ( MOD( I, 10 ).EQ.0 ) THEN IF ( ALPHA.NE.ZERO ) THEN SL = INT( LOG( ABS( ALPHA ) ) / LGBAS ) SCAL = SCAL + SL ALPHA = ALPHA / ( BASE**DBLE( SL ) ) END IF IF ( BETA.NE.ZERO ) THEN SL = INT( LOG( ABS( BETA ) ) / LGBAS ) SCAL = SCAL - SL BETA = BETA / ( BASE**DBLE( SL ) ) END IF END IF 10 CONTINUE C IF ( BETA.NE.ZERO ) THEN ALPHA = ALPHA / BETA BETA = ONE END IF IF ( ALPHA.EQ.ZERO ) THEN SCAL = 0 ELSE SL = INT( LOG( ABS( ALPHA ) ) / LGBAS ) ALPHA = ALPHA / ( BASE**DBLE( SL ) ) SCAL = SCAL + SL END IF C RETURN C *** Last line of MA01BD *** END slicot-5.0+20101122/src/MA01CD.f000077500000000000000000000070001201767322700153510ustar00rootroot00000000000000 INTEGER FUNCTION MA01CD( A, IA, B, IB ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To compute, without over- or underflow, the sign of the sum of two C real numbers represented using integer powers of a base (usually, C the machine base). Any base can be used, but it should the same C for both numbers. The result is an integer with value 1, 0, or -1, C depending on the sum being found as positive, zero, or negative, C respectively. C C FUNCTION VALUE C C MA01CD INTEGER C The sign of the sum of the two numbers, which is usually C either 1, or -1. If both numbers are 0, or if they have C the same exponent and their sum is 0, the returned value C is 0. C C ARGUMENTS C C Input/Output Parameters C C A (input) DOUBLE PRECISION C The first real scalar. C C IA (input) INTEGER C Exponent of the base for the first real scalar. The scalar C is represented as A * BASE**(IA). C C B (input) DOUBLE PRECISION C The first real scalar. C C IB (input) INTEGER C Exponent of the base for the first real scalar. The scalar C is represented as B * BASE**(IB). C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Feb. 2010. C C REVISIONS C C - C C KEYWORDS C C Computer arithmetic, overflow, underflow. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IA, IB DOUBLE PRECISION A, B C .. Local Scalars .. DOUBLE PRECISION S, SA, SB C .. Intrinsic Functions .. INTRINSIC ABS, LOG, SIGN C C .. Executable Statements .. C IF( A.EQ.ZERO .AND. B.EQ.ZERO ) THEN MA01CD = 0 ELSE IF( A.EQ.ZERO ) THEN MA01CD = SIGN( ONE, B ) ELSE IF( B.EQ.ZERO ) THEN MA01CD = SIGN( ONE, A ) ELSE IF( IA.EQ.IB ) THEN S = A + B IF( S.EQ.ZERO ) THEN MA01CD = 0 ELSE MA01CD = SIGN( ONE, S ) END IF ELSE SA = SIGN( ONE, A ) SB = SIGN( ONE, B ) IF( SA.EQ.SB ) THEN MA01CD = SA ELSE IF( IA.GT.IB ) THEN IF( ( LOG( ABS( A ) ) + IA - IB ).GE.LOG( ABS( B ) ) ) THEN MA01CD = SA ELSE MA01CD = SB END IF ELSE IF( ( LOG( ABS( B ) ) + IB - IA ).GE.LOG( ABS( A ) ) ) THEN MA01CD = SB ELSE MA01CD = SA END IF END IF END IF C RETURN C *** Last line of MA01CD *** END slicot-5.0+20101122/src/MA02AD.f000077500000000000000000000061601201767322700153560ustar00rootroot00000000000000 SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MA02BD.f000077500000000000000000000070521201767322700153600ustar00rootroot00000000000000 SUBROUTINE MA02BD( SIDE, M, N, A, LDA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MA02BZ.f000077500000000000000000000071371201767322700154120ustar00rootroot00000000000000 SUBROUTINE MA02BZ( SIDE, M, N, A, LDA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MA02CD.f000077500000000000000000000067721201767322700153710ustar00rootroot00000000000000 SUBROUTINE MA02CD( N, KL, KU, A, LDA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MA02CZ.f000077500000000000000000000067731201767322700154200ustar00rootroot00000000000000 SUBROUTINE MA02CZ( N, KL, KU, A, LDA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MA02DD.f000077500000000000000000000121501201767322700153550ustar00rootroot00000000000000 SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MA02ED.f000077500000000000000000000057211201767322700153640ustar00rootroot00000000000000 SUBROUTINE MA02ED( UPLO, N, A, LDA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MA02FD.f000077500000000000000000000061351201767322700153650ustar00rootroot00000000000000 SUBROUTINE MA02FD( X1, X2, C, S, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MA02GD.f000077500000000000000000000115021201767322700153600ustar00rootroot00000000000000 SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MA02HD.f000077500000000000000000000114641201767322700153700ustar00rootroot00000000000000 LOGICAL FUNCTION MA02HD( JOB, M, N, DIAG, A, LDA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MA02ID.f000077500000000000000000000216631201767322700153730ustar00rootroot00000000000000 DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG, $ LDQG, DWORK ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MA02JD.f000077500000000000000000000132361201767322700153710ustar00rootroot00000000000000 DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2, $ LDQ2, RES, LDRES ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB01KD.f000077500000000000000000000261611201767322700153730ustar00rootroot00000000000000 SUBROUTINE MB01KD( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, $ C, LDC, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 one of the skew-symmetric rank 2k operations C C C := alpha*A*B' - alpha*B*A' + beta*C, C C or C C C := alpha*A'*B - alpha*B'*A + beta*C, C C where alpha and beta are scalars, C is a real N-by-N skew- C symmetric matrix and A, B are N-by-K matrices in the first case C and K-by-N matrices in the second case. C C This is a modified version of the vanilla implemented BLAS C routine DSYR2K written by Jack Dongarra, Iain Duff, C Jeremy Du Croz and Sven Hammarling. 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 C is to be referenced, as follows: C = 'U': only the strictly upper triangular part of C is to C be referenced; C = 'L': only the striclty lower triangular part of C is to C be referenced. C C TRANS CHARACTER*1 C Specifies the operation to be performed, as follows: C = 'N': C := alpha*A*B' - alpha*B*A' + beta*C; C = 'T' or 'C': C := alpha*A'*B - alpha*B'*A + beta*C. 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 If TRANS = 'N' the number of columns of A and B; and if C TRANS = 'T' or TRANS = 'C' the number of rows of A and B. C K >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. If alpha is zero, or N <= 1, or K = 0, C A and B are not referenced. C C A (input) DOUBLE PRECISION array, dimension (LDA,KA), C where KA is K when TRANS = 'N', and is N otherwise. C On entry with TRANS = 'N', the leading N-by-K part of C of this array must contain the matrix A. C On entry with TRANS = 'T' or TRANS = 'C', the leading C K-by-N 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,N), if TRANS = 'N'; C LDA >= MAX(1,K), if TRANS = 'T' or TRANS = 'C'. C C B (input) DOUBLE PRECISION array, dimension (LDB,KB), C where KB is K when TRANS = 'N', and is N otherwise. C On entry with TRANS = 'N', the leading N-by-K part of C of this array must contain the matrix B. C On entry with TRANS = 'T' or TRANS = 'C', the leading C K-by-N 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), if TRANS = 'N'; C LDB >= MAX(1,K), if TRANS = 'T' or TRANS = 'C'. C C BETA (input) DOUBLE PRECISION C The scalar beta. If beta is zero C need not be set before C entry. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,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 C. 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 C. 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 C. 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 C. C C LDC INTEGER C The leading dimension of the 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 NUMERICAL ASPECTS C C Though being almost identical with the vanilla implementation C of the BLAS routine DSYR2K 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, Jan. 2010 (SLICOT version of the HAPACK routine DSKR2K). 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 UPLO, TRANS INTEGER INFO, K, LDA, LDB, LDC, N DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) C .. Local Scalars .. LOGICAL LUP, LTRAN INTEGER I, J, L DOUBLE PRECISION TEMP1, TEMP2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LUP = LSAME( UPLO, 'U' ) LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C C Check the scalar input parameters. C IF ( .NOT.( LUP .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRAN .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 ( ( .NOT.LTRAN .AND. LDA.LT.N ) .OR. LDA.LT.1 .OR. $ ( LTRAN .AND. LDA.LT.K ) ) THEN INFO = -7 ELSE IF ( ( .NOT.LTRAN .AND. LDB.LT.N ) .OR. LDB.LT.1 .OR. $ ( LTRAN .AND. LDB.LT.K ) ) THEN INFO = -9 ELSE IF ( LDC.LT.MAX( 1, N ) ) THEN INFO = -12 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB01KD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( ( N.LE.1 ) .OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C Special case ALPHA = 0. C IF ( ALPHA.EQ.ZERO ) THEN IF ( LUP ) THEN IF ( BETA.EQ.ZERO ) THEN DO 20 J = 2, N DO 10 I = 1, J-1 C(I,J) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 2, N DO 30 I = 1, J-1 C(I,J) = BETA * C(I,J) 30 CONTINUE 40 CONTINUE END IF ELSE IF( BETA.EQ.ZERO ) THEN DO 60 J = 1, N-1 DO 50 I = J+1, N C(I,J) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80 J = 1, N-1 DO 70 I = J+1, N C(I,J) = BETA * C(I,J) 70 CONTINUE 80 CONTINUE END IF END IF RETURN END IF C C Normal case. C IF ( .NOT.LTRAN ) THEN C C Update C := alpha*A*B' - alpha*B*A' + beta*C. C IF ( LUP ) THEN DO 130 J = 2, N IF ( BETA.EQ.ZERO ) THEN DO 90 I = 1, J-1 C(I,J) = ZERO 90 CONTINUE ELSE IF ( BETA.NE.ONE ) THEN DO 100 I = 1, J-1 C(I,J) = BETA * C(I,J) 100 CONTINUE END IF DO 120 L = 1, K IF ( ( A(J,L).NE.ZERO ) .OR. $ ( B(J,L).NE.ZERO ) ) THEN TEMP1 = ALPHA * B(J,L) TEMP2 = ALPHA * A(J,L) DO 110 I = 1, J-1 C(I,J) = C(I,J) + A(I,L)*TEMP1 - B(I,L)*TEMP2 110 CONTINUE END IF 120 CONTINUE 130 CONTINUE ELSE DO 180 J = 1, N-1 IF ( BETA.EQ.ZERO ) THEN DO 140 I = J+1, N C(I,J) = ZERO 140 CONTINUE ELSE IF ( BETA.NE.ONE ) THEN DO 150 I = J+1, N C(I,J) = BETA * C(I,J) 150 CONTINUE END IF DO 170 L = 1, K IF ( ( A(J,L).NE.ZERO ) .OR. $ ( B(J,L).NE.ZERO ) ) THEN TEMP1 = ALPHA * B(J,L) TEMP2 = ALPHA * A(J,L) DO 160 I = J+1, N C(I,J) = C(I,J) + A(I,L)*TEMP1 - B(I,L)*TEMP2 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE END IF ELSE C C Update C := alpha*A'*B - alpha*B'*A + beta*C. C IF ( LUP ) THEN DO 210 J = 2, N DO 200 I = 1, J-1 TEMP1 = ZERO TEMP2 = ZERO DO 190 L = 1, K TEMP1 = TEMP1 + A(L,I)*B(L,J) TEMP2 = TEMP2 + B(L,I)*A(L,J) 190 CONTINUE IF ( BETA.EQ.ZERO ) THEN C(I,J) = ALPHA*TEMP1 - ALPHA*TEMP2 ELSE C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 - ALPHA*TEMP2 END IF 200 CONTINUE 210 CONTINUE ELSE DO 240 J = 1, N-1 DO 230 I = J+1, N TEMP1 = ZERO TEMP2 = ZERO DO 220, L = 1, K TEMP1 = TEMP1 + A(L,I)*B(L,J) TEMP2 = TEMP2 + B(L,I)*A(L,J) 220 CONTINUE IF ( BETA.EQ.ZERO ) THEN C(I,J) = ALPHA*TEMP1 - ALPHA*TEMP2 ELSE C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 - ALPHA*TEMP2 END IF 230 CONTINUE 240 CONTINUE END IF END IF RETURN C *** Last line of MB01KD *** END slicot-5.0+20101122/src/MB01LD.f000077500000000000000000000363351201767322700154000ustar00rootroot00000000000000 SUBROUTINE MB01LD( 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 skew-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 skew-symmetric matrices R C and X are given, as follows: C = 'U': the strictly upper triangular part is given; C = 'L': the strictly 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 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 or N <= 1, or M <= 1, C then A and X are not referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) C On entry with UPLO = 'U', the leading M-by-M strictly C upper triangular part of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix R. The lower triangle is not referenced. C On entry with UPLO = 'L', the leading M-by-M strictly C lower triangular part of this array must contain the C strictly lower triangular part of the skew-symmetric C matrix R. The upper triangle is not referenced. C On exit, the leading M-by-M strictly upper triangular part C (if UPLO = 'U'), or strictly lower triangular part C (if UPLO = 'L'), of this array contains the corresponding C _ C strictly triangular part of the computed matrix R. C C LDR INTEGER C The leading dimension of the 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 the 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 or input/output) DOUBLE PRECISION array, dimension C (LDX,K), where K = N, if UPLO = 'U' or LDWORK >= M*(N-1), C or K = MAX(N,M), if UPLO = 'L' and LDWORK < M*(N-1). C On entry, if UPLO = 'U', the leading N-by-N strictly upper C triangular part of this array must contain the strictly C upper triangular part of the skew-symmetric matrix X and C the lower triangular part of the array is not referenced. C On entry, if UPLO = 'L', the leading N-by-N strictly lower C triangular part of this array must contain the strictly C lower triangular part of the skew-symmetric matrix X and C the upper triangular part of the array is not referenced. C If LDWORK < M*(N-1), this array is overwritten with the C matrix op(A)*X, if UPLO = 'U', or X*op(A)', if UPLO = 'L'. C C LDX INTEGER C The leading dimension of the array X. C LDX >= MAX(1,N), if UPLO = 'L' or LDWORK >= M*(N-1); C LDX >= MAX(1,N,M), if UPLO = 'U' and LDWORK < M*(N-1). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C This array is not referenced when beta = 0, or M <= 1, or C N <= 1. C C LDWORK The length of the array DWORK. C LDWORK >= N, if beta <> 0, and M > 0, and N > 1; C LDWORK >= 0, if beta = 0, or M = 0, or N <= 1. C For optimum performance, LDWORK >= M*(N-1), if beta <> 0, C M > 1, and N > 1. 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 skew- C symmetry into account. If LDWORK >= M*(N-1), a BLAS 3 like C implementation is used. Specifically, let X = T - T', with T a C strictly upper or strictly lower triangular matrix, defined by C C T = striu( X ), if UPLO = 'U', C T = stril( X ), if UPLO = 'L', C C where striu and stril denote the strictly upper triangular part C and strictly lower triangular 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 the skew-symmetric C correspondent of DSYR2K (with a Fortran implementation available C in the SLICOT Library routine MB01KD). C If LDWORK < M*(N-1), a BLAS 2 implementation is used. 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, Research Institute for Informatics, Bucharest, Jan. 2010. C Based on the SLICOT Library routine MB01RU and the HAPACK Library C routine DSKUPD. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2010. 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 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, NOTTRA, UPPER INTEGER I, J, M2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DLASET, DSCAL, $ DTRMM, MB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTTRA = LSAME( TRANS, 'N' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = -1 ELSE IF( ( .NOT.NOTTRA ).AND.( .NOT.LTRANS ) )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. $ ( NOTTRA .AND. LDA.LT.M ) ) THEN INFO = -10 ELSE IF( LDX.LT.MAX( 1, N ) .OR. $ ( LDX.LT.M .AND. UPPER .AND. LDWORK.LT.M*( N - 1 ) ) ) THEN INFO = -12 ELSE IF( LDWORK.LT.0 .OR. ( BETA.NE.ZERO .AND. M.GT.1 .AND. N.GT.1 $ .AND. LDWORK.LT.N ) ) THEN INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01LD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( M.LE.0 ) $ RETURN C M2 = MIN( 2, M ) IF ( BETA.EQ.ZERO .OR. N.LE.1 ) THEN IF ( UPPER ) THEN I = 1 J = M2 ELSE I = M2 J = 1 END IF C IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, M-1, M-1, ZERO, ZERO, R(I,J), LDR ) ELSE C C Special case beta = 0 or N <= 1. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M-1, M-1, R(I,J), $ LDR, INFO ) END IF RETURN END IF C C General case: beta <> 0. C IF ( LDWORK.GE.M*( N - 1 ) ) THEN C C Use a BLAS 3 like implementation. C Compute W = A*T or W = T*A in DWORK, and apply the updating C formula (see METHOD section). Note that column 1 (if C UPLO = 'U') or column N (if UPLO = 'L') is zero in the first C case, and it is not stored; similarly, row N (if UPLO = 'U') or C row 1 (if UPLO = 'L') is zero in the second case, and it is not C stored. C Workspace: need M*(N-1). C IF ( UPPER ) THEN I = 1 J = M2 ELSE I = M2 J = 1 END IF C IF( NOTTRA ) THEN C CALL DLACPY( 'Full', M, N-1, A(1,I), LDA, DWORK, M ) CALL DTRMM( 'Right', UPLO, 'NoTranspose', 'Non-unit', M, $ N-1, ONE, X(I,J), LDX, DWORK, M ) CALL MB01KD( UPLO, TRANS, M, N-1, BETA, DWORK, M, A(1,J), $ LDA, ALPHA, R, LDR, INFO ) C ELSE C CALL DLACPY( 'Full', N-1, M, A(J,1), LDA, DWORK, N-1 ) CALL DTRMM( 'Left', UPLO, 'NoTranspose', 'Non-unit', N-1, $ M, ONE, X(I,J), LDX, DWORK, N-1 ) CALL MB01KD( UPLO, TRANS, M, N-1, BETA, A(I,1), LDA, DWORK, $ N-1, ALPHA, R, LDR, INFO ) C END IF C ELSE C C Use a BLAS 2 implementation. C C IF ( NOTTRA ) THEN C C Compute A*X*A'. C IF ( UPPER ) THEN C C Compute A*X in X (M-by-N). C DO 10 J = 1, N-1 CALL DCOPY( J-1, X(1,J), 1, DWORK, 1 ) DWORK(J) = ZERO CALL DCOPY( N-J, X(J,J+1), LDX, DWORK(J+1), 1 ) CALL DSCAL( N-J, -ONE, DWORK(J+1), 1 ) CALL DGEMV( TRANS, M, N, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,J), 1 ) 10 CONTINUE C CALL DCOPY( N-1, X(1,N), 1, DWORK, 1 ) CALL DGEMV( TRANS, M, N-1, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,N), 1 ) C C Compute alpha*striu( R ) + beta*striu( X*A' ) in the C strictly upper triangular part of R. C DO 20 I = 1, M-1 CALL DCOPY( N, X(I,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, M-I, N, BETA, A(I+1,1), LDA, DWORK, $ 1, ALPHA, R(I,I+1), LDR ) 20 CONTINUE C ELSE C C Compute X*A' in X (N-by-M). C DO 30 I = 1, N-1 CALL DCOPY( I-1, X(I,1), LDX, DWORK, 1 ) DWORK(I) = ZERO CALL DCOPY( N-I, X(I+1,I), 1, DWORK(I+1), 1 ) CALL DSCAL( N-I, -ONE, DWORK(I+1), 1 ) CALL DGEMV( TRANS, M, N, ONE, A, LDA, DWORK, 1, ZERO, $ X(I,1), LDX ) 30 CONTINUE C CALL DCOPY( N-1, X(N,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, M, N-1, ONE, A, LDA, DWORK, 1, ZERO, $ X(N,1), LDX ) C C Compute alpha*stril( R ) + beta*stril( A*X ) in the C strictly lower triangular part of R. C DO 40 J = 1, M-1 CALL DCOPY( N, X(1,J), 1, DWORK, 1 ) CALL DGEMV( TRANS, M-J, N, BETA, A(J+1,1), LDA, DWORK, $ 1, ALPHA, R(J+1,J), 1 ) 40 CONTINUE C END IF C ELSE C C Compute A'*X*A. C IF ( UPPER ) THEN C C Compute A'*X in X (M-by-N). C DO 50 J = 1, N-1 CALL DCOPY( J-1, X(1,J), 1, DWORK, 1 ) DWORK(J) = ZERO CALL DCOPY( N-J, X(J,J+1), LDX, DWORK(J+1), 1 ) CALL DSCAL( N-J, -ONE, DWORK(J+1), 1 ) CALL DGEMV( TRANS, N, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,J), 1 ) 50 CONTINUE C CALL DCOPY( N-1, X(1,N), 1, DWORK, 1 ) CALL DGEMV( TRANS, N-1, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,N), 1 ) C C Compute alpha*striu( R ) + beta*striu( X*A ) in the C strictly upper triangular part of R. C DO 60 I = 1, M-1 CALL DCOPY( N, X(I,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, N, M-I, BETA, A(1,I+1), LDA, DWORK, $ 1, ALPHA, R(I,I+1), LDR ) 60 CONTINUE C ELSE C C Compute X*A in X (N-by-M). C DO 70 I = 1, N-1 CALL DCOPY( I-1, X(I,1), LDX, DWORK, 1 ) DWORK(I) = ZERO CALL DCOPY( N-I, X(I+1,I), 1, DWORK(I+1), 1 ) CALL DSCAL( N-I, -ONE, DWORK(I+1), 1 ) CALL DGEMV( TRANS, N, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(I,1), LDX ) 70 CONTINUE C CALL DCOPY( N-1, X(N,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, N-1, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(N,1), LDX ) C C Compute alpha*stril( R ) + beta*stril( A'*X ) in the C strictly lower triangular part of R. C DO 80 J = 1, M-1 CALL DCOPY( N, X(1,J), 1, DWORK, 1 ) CALL DGEMV( TRANS, N, M-J, BETA, A(1,J+1), LDA, DWORK, $ 1, ALPHA, R(J+1,J), 1 ) 80 CONTINUE C END IF END IF END IF C RETURN C *** Last line of MB01LD *** END slicot-5.0+20101122/src/MB01MD.f000077500000000000000000000212071201767322700153710ustar00rootroot00000000000000 SUBROUTINE MB01MD( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB01ND.f000077500000000000000000000201601201767322700153670ustar00rootroot00000000000000 SUBROUTINE MB01ND( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB01PD.f000077500000000000000000000216201201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB01QD.f000077500000000000000000000225751201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB01RD.f000077500000000000000000000267211201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB01RU.f000077500000000000000000000226361201767322700154260ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB01RW.f000077500000000000000000000170611201767322700154240ustar00rootroot00000000000000 SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB01RX.f000077500000000000000000000261251201767322700154260ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB01RY.f000077500000000000000000000343051201767322700154260ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB01SD.f000077500000000000000000000071211201767322700153760ustar00rootroot00000000000000 SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB01TD.f000077500000000000000000000120161201767322700153760ustar00rootroot00000000000000 SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB01UD.f000077500000000000000000000170001201767322700153750ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB01UW.f000077500000000000000000000304651201767322700154320ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB01UX.f000077500000000000000000000275061201767322700154350ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB01VD.f000077500000000000000000001344601201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB01WD.f000077500000000000000000000260001201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB01XD.f000077500000000000000000000150001201767322700153760ustar00rootroot00000000000000 SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB01XY.f000077500000000000000000000131361201767322700154330ustar00rootroot00000000000000 SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB01YD.f000077500000000000000000000252721201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB01ZD.f000077500000000000000000000351651201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB02CD.f000077500000000000000000000542461201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB02CU.f000077500000000000000000001103551201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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 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, TOLZ C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2, IDAMAX, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( A1(J,I) ) / DWORK(J) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO ) TEMP2 = TEMP*( DWORK(J) / DWORK(K+J) )**2 IF( TEMP2.LE.TOLZ ) 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 = ABS( B(JJ,POS) ) / DWORK(JJ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO) TEMP2 = TEMP*( DWORK(JJ) / DWORK(K+JJ) )**2 IF( TEMP2.LE.TOLZ ) 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 slicot-5.0+20101122/src/MB02CV.f000077500000000000000000000662661201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02CX.f000077500000000000000000000250361201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02CY.f000077500000000000000000000275701201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02DD.f000077500000000000000000000525441201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02ED.f000077500000000000000000000403561201767322700153700ustar00rootroot00000000000000 SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, $ LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02FD.f000077500000000000000000000323551201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB02GD.f000077500000000000000000000460101201767322700153630ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB02HD.f000077500000000000000000000447451201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB02ID.f000077500000000000000000000451401201767322700153700ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02JD.f000077500000000000000000000424231201767322700153720ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB02JX.f000077500000000000000000000612141201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB02KD.f000077500000000000000000000651751201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB02MD.f000077500000000000000000000525121201767322700153750ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02ND.f000077500000000000000000001000141201767322700153650ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02NY.f000077500000000000000000000220231201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02OD.f000077500000000000000000000216721201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02PD.f000077500000000000000000000521561201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02QD.f000077500000000000000000000442731201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB02QY.f000077500000000000000000000257701201767322700154340ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02RD.f000077500000000000000000000132771201767322700154070ustar00rootroot00000000000000 SUBROUTINE MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02RZ.f000077500000000000000000000146331201767322700154320ustar00rootroot00000000000000 SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02SD.f000077500000000000000000000111041201767322700153730ustar00rootroot00000000000000 SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB02SZ.f000077500000000000000000000115371201767322700154330ustar00rootroot00000000000000 SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB02TD.f000077500000000000000000000151201201767322700153760ustar00rootroot00000000000000 SUBROUTINE MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, $ DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02TZ.f000077500000000000000000000161351201767322700154330ustar00rootroot00000000000000 SUBROUTINE MB02TZ( NORM, N, HNORM, H, LDH, IPIV, RCOND, DWORK, $ ZWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02UD.f000077500000000000000000000541431201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB02UU.f000077500000000000000000000116751201767322700154330ustar00rootroot00000000000000 SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02UV.f000077500000000000000000000136331201767322700154300ustar00rootroot00000000000000 SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB02UW.f000077500000000000000000000245101201767322700154250ustar00rootroot00000000000000 SUBROUTINE MB02UW( LTRANS, N, M, PAR, A, LDA, B, LDB, SCALE, $ IWARN ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 the form A X = s B or A' X = s B with C possible scaling ("s") and perturbation of A. (A' means C A-transpose.) A is an N-by-N real matrix, and X and B are C N-by-M matrices. N may be 1 or 2. The scalar "s" is a scaling C factor (.LE. 1), computed by this subroutine, which is so chosen C that X can be computed without overflow. X is further scaled if C necessary to assure that norm(A)*norm(X) is less than overflow. C C ARGUMENTS C C Mode Parameters C C LTRANS LOGICAL C Specifies if A or A-transpose is to be used, as follows: C =.TRUE. : A-transpose will be used; C =.FALSE.: A will be used (not transposed). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. It may (only) be 1 or 2. C C M (input) INTEGER C The number of right hand size vectors. C C PAR (input) DOUBLE PRECISION array, dimension (3) C Machine related parameters: C PAR(1) =: PREC (machine precision)*base, DLAMCH( 'P' ); C PAR(2) =: SFMIN safe minimum, DLAMCH( 'S' ); C PAR(3) =: SMIN The desired lower bound on the singular C values of A. This should be a safe C distance away from underflow or overflow, C say, between (underflow/machine precision) C and (machine precision * overflow). 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 >= 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 matrix B (right-hand side). C On exit, the leading N-by-M part of this array contains C the N-by-M matrix X (unknowns). C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C SCALE (output) DOUBLE PRECISION C The scale factor that B must be multiplied by to insure C that overflow does not occur when computing X. Thus, C A X will be SCALE*B, not B (ignoring perturbations of A). C SCALE will be at most 1. C C Warning Indicator C C IWARN INTEGER C = 0: no warnings (A did not have to be perturbed); C = 1: A had to be perturbed to make its smallest (or only) C singular value greater than SMIN (see below). C C METHOD C C Gaussian elimination with complete pivoting is used. The matrix A C is slightly perturbed if it is (close to being) singular. C C FURTHER COMMENTS C C If both singular values of A are less than SMIN, SMIN*identity C will be used instead of A. If only one singular value is less C than SMIN, one element of A will be perturbed enough to make the C smallest singular value roughly SMIN. If both singular values C are at least SMIN, A will not be perturbed. In any case, the C perturbation will be at most some small multiple of C max( SMIN, EPS*norm(A) ), where EPS is the machine precision C (see LAPACK Library routine DLAMCH). The singular values are C computed by infinity-norm approximations, and thus will only be C correct to a factor of 2 or so. C C Note: all input quantities are assumed to be smaller than overflow C by a reasonable factor. (See BIGNUM.) In the interests of speed, C this routine does not check the inputs for errors. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2009. C Based on the LAPACK Library routine DLALN2. C C REVISIONS C C V. Sima, Nov. 2010. C C KEYWORDS C C Linear system of equations, matrix operations, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C C .. Scalar Arguments .. LOGICAL LTRANS INTEGER IWARN, LDA, LDB, N, M DOUBLE PRECISION SCALE, SMIN C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), PAR( * ) C C .. Local Scalars .. INTEGER I, ICMAX, J DOUBLE PRECISION BBND, BIGNUM, BNORM, B1, B2, CMAX, C21, C22, $ CS, EPS, L21, SCALEP, SMINI, SMLNUM, TEMP, U11, $ U11R, U12, U22, XNORM, X1, X2 C C .. Local Arrays .. LOGICAL RSWAP( 4 ), ZSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) DOUBLE PRECISION C( 2, 2 ), CV( 4 ) C C ..External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLANGE EXTERNAL DLANGE, IDAMAX C C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. C .. Equivalences .. EQUIVALENCE ( C( 1, 1 ), CV( 1 ) ) C .. C .. Data statements .. DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C IWARN = 0 C C Compute BIGNUM. C SMIN = PAR( 3 ) EPS = PAR( 1 ) SMLNUM = TWO*PAR( 2 ) / EPS BIGNUM = ONE / SMLNUM C C Standard initializations. C SCALE = ONE C IF( N.EQ.1 ) THEN C C 1-by-1 (i.e., scalar) systems C X = B. C CS = A( 1, 1 ) CMAX = ABS( CS ) SMINI = MAX( SMIN, SMLNUM, EPS*CMAX ) C C If | C | < SMINI, use C = SMINI. C IF( CMAX.LT.SMINI ) THEN CS = SMINI CMAX = SMINI IWARN = 1 END IF C C Check scaling for X = B / C. C BNORM = ABS( B( 1, IDAMAX( M, B, LDB ) ) ) IF( CMAX.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CMAX ) $ SCALE = ONE / BNORM END IF C C Compute X. C DO 10 I = 1, M B( 1, I ) = ( B( 1, I )*SCALE ) / CS 10 CONTINUE C ELSE C C 2x2 systems. C C Compute C = A (or A'). C C( 1, 1 ) = A( 1, 1 ) C( 2, 2 ) = A( 2, 2 ) IF( LTRANS ) THEN C( 1, 2 ) = A( 2, 1 ) C( 2, 1 ) = A( 1, 2 ) ELSE C( 2, 1 ) = A( 2, 1 ) C( 1, 2 ) = A( 1, 2 ) END IF C BNORM = DLANGE( 'M', N, M, B, LDB, CV ) C C Find the largest element in C. C CMAX = ZERO ICMAX = 0 C DO 20 J = 1, 4 IF( ABS( CV( J ) ).GT.CMAX ) THEN CMAX = ABS( CV( J ) ) ICMAX = J END IF 20 CONTINUE C SMINI = MAX( SMIN, SMLNUM, EPS*CMAX ) C C If norm(C) < SMINI, use SMINI*identity. C IF( CMAX.LT.SMINI ) THEN IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI C DO 30 I = 1, M B( 1, I ) = TEMP*B( 1, I ) B( 2, I ) = TEMP*B( 2, I ) 30 CONTINUE C IWARN = 1 RETURN END IF C C Gaussian elimination with complete pivoting. C U11 = CV( ICMAX ) C21 = CV( IPIVOT( 2, ICMAX ) ) U12 = CV( IPIVOT( 3, ICMAX ) ) C22 = CV( IPIVOT( 4, ICMAX ) ) U11R = ONE / U11 L21 = U11R*C21 U22 = C22 - U12*L21 C C If smaller pivot < SMINI, use SMINI. C IF( ABS( U22 ).LT.SMINI ) THEN U22 = SMINI IWARN = 1 END IF C SCALEP = ONE C DO 50 I = 1, M IF( RSWAP( ICMAX ) ) THEN B1 = B( 2, I ) B2 = B( 1, I ) ELSE B1 = B( 1, I ) B2 = B( 2, I ) END IF B2 = B2 - L21*B1 BBND = MAX( ABS( B1*( U22*U11R ) ), ABS( B2 ) ) IF( BBND.GT.ONE .AND. ABS( U22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( U22 ) ) $ SCALE = ONE / BBND END IF SCALE = MIN( SCALE, SCALEP ) IF( SCALE.LT.SCALEP ) THEN SCALEP = SCALE / SCALEP C DO 40 J = 1, I - 1 B( 1, J ) = B( 1, J )*SCALEP B( 2, J ) = B( 2, J )*SCALEP 40 CONTINUE C END IF C X2 = ( B2*SCALE ) / U22 X1 = ( SCALE*B1 )*U11R - X2*( U11R*U12 ) IF( ZSWAP( ICMAX ) ) THEN B( 1, I ) = X2 B( 2, I ) = X1 ELSE B( 1, I ) = X1 B( 2, I ) = X2 END IF XNORM = MAX( ABS( X1 ), ABS( X2 ) ) C C Further scaling if norm(A) norm(X) > overflow. C IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM B( 1, I ) = TEMP*B( 1, I ) B( 2, I ) = TEMP*B( 2, I ) SCALE = TEMP*SCALE END IF END IF SCALEP = SCALE 50 CONTINUE C END IF C RETURN C C *** Last line of MB02UW *** END slicot-5.0+20101122/src/MB02VD.f000077500000000000000000000140461201767322700154060ustar00rootroot00000000000000 SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB02WD.f000077500000000000000000000364261201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02XD.f000077500000000000000000000347111201767322700154110ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB02YD.f000077500000000000000000000277271201767322700154230ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03AD.f000077500000000000000000000164121201767322700153610ustar00rootroot00000000000000 SUBROUTINE MB03AD( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1, $ S1, C2, S2 ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) C such that the orthogonal matrix C C [ C1 S1 0 ] [ 1 0 0 ] C Q = [ -S1 C1 0 ] * [ 0 C2 S2 ] C [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson single/double shift C polynomial of the general product of matrices, stored in the C array A, parallel to the first unit vector. C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number of shifts employed by the shift C polynomial, as follows: C = 'D': two real shifts; C = 'S': one real shift. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors in the array A. N >= 3. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C On entry, the leading N-by-N-by-K part of this array must C contain a n-by-n product (implicitly represented by its K C factors) in upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, if SHFT = 'D', C2 and S2 contain the parameters C for the second Givens rotation. C C METHOD C C Two Givens rotations are properly computed and applied. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLASHF. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, S1, C2, S2 C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. LOGICAL SGLE INTEGER AI, I DOUBLE PRECISION ALPHA, BETA, C3, DELTA, GAMMA, S3, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARTG C .. Intrinsic Functions .. INTRINSIC SQRT C C .. Executable Statements .. C SGLE = LSAME( SHFT, 'S' ) C1 = ONE S1 = ZERO C2 = 1/SQRT( TWO ) S2 = C2 C DO 10 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN ALPHA = C2 * A(1,1,AI) GAMMA = S2 * A(N,N,AI) BETA = S2 * A(N-1,N,AI) BETA = C1 * BETA + S1 * A(N-1,N-1,AI) CALL DLARTG( ALPHA, GAMMA, C2, S2, TEMP ) TEMP = C1 * TEMP CALL DLARTG( TEMP, BETA, C1, S1, ALPHA ) ELSE TEMP = A(1,1,AI) BETA = S2 * TEMP TEMP = C2 * TEMP ALPHA = S1 * TEMP GAMMA = A(N,N,AI) DELTA = C2 * GAMMA GAMMA = S2 * GAMMA CALL DLARTG( DELTA, BETA, C2, S2, C3 ) DELTA = C1 * A(N-1,N,AI) - S1 * GAMMA ALPHA = C2 * ALPHA - S2 * DELTA GAMMA = C1 * A(N-1,N-1,AI) CALL DLARTG( GAMMA, ALPHA, C1, S1, TEMP ) END IF 10 CONTINUE C AI = AMAP(1) ALPHA = A(1,1,AI) * C2 - A(N,N,AI) * S2 BETA = C1 * ( C2 * A(2,1,AI) ) GAMMA = C1 * ( S2 * A(N-1,N,AI) ) + S1 * A(N-1,N-1,AI) ALPHA = ALPHA * C1 - A(N,N-1,AI) * S1 CALL DLARTG( ALPHA, BETA, C1, S1, TEMP ) C C This is sufficient for single real shifts. C IF ( .NOT.SGLE ) THEN C CALL DLARTG( TEMP, GAMMA, C2, S2, ALPHA ) C C Rotation 1 is preserved. C ALPHA = C2 GAMMA = ( A(N-1,N-1,AI) * C1 ) * C2 + A(N,N-1,AI) * S2 DELTA = ( A(N-1,N-1,AI) * S1 ) * C2 CALL DLARTG( GAMMA, DELTA, C3, S3, TEMP ) CALL DLARTG( ALPHA, TEMP, C2, S2, ALPHA ) C C Rotation 3 is preserved throughout the following complete loop. C DO 20 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN ALPHA = ( A(1,1,AI) * C1 + A(1,2,AI) * S1 ) * C2 BETA = ( A(2,2,AI) * S1 ) * C2 GAMMA = A(N-1,N-1,AI) * S2 CALL DLARTG( ALPHA, BETA, C1, S1, TEMP ) CALL DLARTG( TEMP, GAMMA, C2, S2, ALPHA ) ELSE ALPHA = C1 * A(1,1,AI) GAMMA = S1 * A(1,1,AI) BETA = C1 * A(1,2,AI) + S1 * A(2,2,AI) DELTA = -S1 * A(1,2,AI) + C1 * A(2,2,AI) CALL DLARTG( DELTA, GAMMA, C1, S1, TEMP ) ALPHA = -ALPHA * S2 BETA = -BETA * S2 ALPHA = C1 * ALPHA + S1 * BETA BETA = C2 * A(N-1,N-1,AI) CALL DLARTG( BETA, ALPHA, C2, S2, TEMP ) S2 = -S2 END IF 20 CONTINUE C C Last step: Let the rotations collap into A. C AI = AMAP(1) ALPHA = C1 * A(1,1,AI) + S1 * A(1,2,AI) BETA = C1 * A(2,1,AI) + S1 * A(2,2,AI) GAMMA = S1 * A(3,2,AI) ALPHA = C2 * ALPHA - S2 * C3 BETA = C2 * BETA - S2 * S3 GAMMA = C2 * GAMMA CALL DLARTG( BETA, GAMMA, C2, S2, TEMP ) CALL DLARTG( ALPHA, TEMP, C1, S1, BETA ) END IF RETURN C *** Last line of MB03AD *** END slicot-5.0+20101122/src/MB03BA.f000077500000000000000000000063141201767322700153570ustar00rootroot00000000000000 SUBROUTINE MB03BA( K, H, S, SMULT, AMAP, QMAP ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To compute the suitable maps for Hessenberg index H and C signature array S. Auxiliary routine for the periodic QZ C algorithms. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C H (input) INTEGER C Index which corresponds to A_1. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SMULT (output) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SMULT. C C AMAP (output) INTEGER array, dimension (K) C The map for accessing the factors, that is, C if AMAP(I) = J, then the factor A_I is stored at the J-th C position in A. C C QMAP (output) INTEGER array, dimension (K) C The map for accessing the orthognal transformation C matrices, that is, if QMAP(I) = J, then the matrix Q_I is C stored at the J-th position in Q. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLAIND. C C KEYWORDS C C Hessenberg matrix, QZ algorithm, periodic QZ algorithm. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER K, H, SMULT C .. Array Arguments .. INTEGER AMAP(*), QMAP(*), S(*) C .. Local Scalars .. INTEGER I, TEMP C .. Intrinsic Functions .. INTRINSIC MOD C C .. Executable Statements .. C IF ( S(H).EQ.-1 ) THEN SMULT = -1 DO 10 I = 1, H AMAP(I) = H-I+1 10 CONTINUE DO 20 I = H+1, K AMAP(I) = H+1-I+K 20 CONTINUE TEMP = MOD( H, K ) + 1 DO 30 I = TEMP, 1, -1 QMAP(TEMP-I+1) = I 30 CONTINUE DO 40 I = K, TEMP + 1, -1 QMAP(TEMP+K-I+1) = I 40 CONTINUE ELSE SMULT = 1 DO 50 I = H, K AMAP(I-H+1) = I QMAP(I-H+1) = I 50 CONTINUE DO 60 I = 1, H-1 AMAP(K-H+I+1) = I QMAP(K-H+I+1) = I 60 CONTINUE END IF C RETURN C *** Last line of MB03BA *** END slicot-5.0+20101122/src/MB03BB.f000077500000000000000000000304231201767322700153560ustar00rootroot00000000000000 SUBROUTINE MB03BB( BASE, LGBAS, ULP, K, AMAP, S, SINV, A, LDA1, $ LDA2, ALPHAR, ALPHAI, BETA, SCAL, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 general 2-by-2 matrix product via C a complex single shifted periodic QZ algorithm. C C ARGUMENTS C C Input/Output Parameters C C BASE (input) DOUBLE PRECISION C Machine base. C C LGBAS (input) DOUBLE PRECISION C Logarithm of BASE. C C ULP (input) DOUBLE PRECISION C Machine precision. C C K (input) INTEGER C The number of factors. K >= 1. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C On entry, the leading 2-by-2-by-K part of this array must C contain a 2-by-2 product (implicitly represented by its K C factors) in upper Hessenberg-triangular form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= 2. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= 2. C C ALPHAR (output) DOUBLE PRECISION array, dimension (2) C On exit, if INFO = 0, this array contains the scaled real C part of the two eigenvalues. If BETA(I) <> 0, then the C I-th eigenvalue (I = 1 : 2) is given by C (ALPHAR(I) + ALPHAI(I)*SQRT(-1) ) * (BASE)**SCAL(I). C C ALPHAI (output) DOUBLE PRECISION array, dimension (2) C On exit, if INFO = 0, this array contains the scaled C imaginary part of the two eigenvalues. ALPHAI(1) >= 0. C C BETA (output) DOUBLE PRECISION array, dimension (2) C On exit, if INFO = 0, this array contains information C about infinite eigenvalues. If BETA(I) = 0, then the C I-th eigenvalue is infinite. Otherwise, BETA(I) = 1.0. C C SCAL (output) INTEGER array, dimension (2) C On exit, if INFO = 0, this array contains the scaling C exponents for the two eigenvalues. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (8*K) C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: the periodic QZ algorithm did not converge. C C METHOD C C A complex single shifted periodic QZ iteration is applied. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLACP2. C V. Sima, June 2010, July 2010. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER INFO, K, LDA1, LDA2, SINV DOUBLE PRECISION BASE, LGBAS, ULP C .. Array Arguments .. DOUBLE PRECISION A(LDA1,LDA2,*), ALPHAI(2), ALPHAR(2), BETA(2), $ DWORK(*) INTEGER AMAP(*), S(*), SCAL(2) C .. Local Scalars .. INTEGER AI, I, IITER, J, PDM, PDW, SL DOUBLE PRECISION CS, CST, LHS, RHS, TEMPI, TEMPR COMPLEX*16 SN, SNT, TEMP C .. Local Arrays .. COMPLEX*16 T(2,2), Z(3,3) C .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 C .. External Subroutines .. EXTERNAL DLADIV, ZLARTG, ZROT C .. Intrinsic Functions .. INTRINSIC DCMPLX, DCONJG, DBLE, DIMAG, DREAL, INT, LOG, $ MAX, MOD C C .. Executable Statements .. C C Apply a complex single shifted periodic QZ iteration. C This might not be efficient but it seems to be reliable. C PDW = 0 C DO 10 I = 1, K AI = AMAP(I) DWORK(PDW+1) = A(1,1,AI) DWORK(PDW+2) = ZERO DWORK(PDW+3) = A(2,1,AI) DWORK(PDW+4) = ZERO DWORK(PDW+5) = A(1,2,AI) DWORK(PDW+6) = ZERO DWORK(PDW+7) = A(2,2,AI) DWORK(PDW+8) = ZERO PDW = PDW + 8 10 CONTINUE C PDM = PDW C DO 40 IITER = 1, 60 C C Test for deflation. C LHS = DLAPY2( DWORK(3), DWORK(4) ) RHS = MAX( DLAPY2( DWORK(1), DWORK(2) ), $ DLAPY2( DWORK(7), DWORK(8) ) ) IF ( RHS.EQ.ZERO ) $ RHS = DLAPY2( DWORK(5), DWORK(6) ) IF ( LHS.LE.ULP*RHS ) $ GO TO 50 C C Start Iteration. C IF ( IITER.EQ.1 ) THEN C C Compute a randomly chosen initial unitary shift. C CALL ZLARTG( DCMPLX( ONE, -TWO ), DCMPLX( TWO, TWO ), CS, $ SN, TEMP ) ELSE IF ( MOD( IITER, 30 ).EQ.0 ) THEN C C Ad hoc shift. C CALL ZLARTG( DCMPLX( DBLE( I ), ONE ), DCMPLX( ONE, -TWO ), $ CS, SN, TEMP ) ELSE C C Compute the shift by a product QR decomposition. C CS = ONE SN = CZERO CALL ZLARTG( CONE, CONE, CST, SNT, TEMP ) PDW = PDM C DO 20 I = K, 2, -1 PDW = PDW - 8 TEMP = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) Z(1,1) = TEMP Z(2,1) = CZERO Z(3,1) = CZERO Z(1,2) = CZERO Z(2,2) = TEMP Z(3,2) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) Z(1,3) = CZERO Z(2,3) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) ) Z(3,3) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) IF ( S(AMAP(I)).EQ.SINV ) THEN CALL ZROT( 3, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT ) $ ) CALL ZROT( 3, Z(1,1), 1, Z(1,2), 1, CS, DCONJG( SN ) $ ) CALL ZLARTG( Z(1,1), Z(3,1), CST, SNT, TEMP ) CALL ZLARTG( TEMP, Z(2,1), CS, SN, TEMP ) ELSE CALL ZROT( 3, Z(1,1), 3, Z(3,1), 3, CST, SNT ) CALL ZROT( 3, Z(1,1), 3, Z(2,1), 3, CS, SN ) TEMP = Z(3,3) CALL ZLARTG( TEMP, Z(3,1), CST, SNT, Z(3,3) ) SNT = -SNT CALL ZROT( 2, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT ) $ ) TEMP = Z(2,2) CALL ZLARTG( TEMP, Z(2,1), CS, SN, Z(2,2) ) SN = -SN END IF 20 CONTINUE C PDW = 0 Z(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) Z(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) Z(1,2) = -DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) Z(2,2) = CZERO Z(1,3) = -DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) Z(2,3) = CZERO CALL ZROT( 2, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT ) ) CALL ZROT( 2, Z(1,1), 1, Z(1,2), 1, CS, DCONJG( SN ) ) CALL ZLARTG( Z(1,1), Z(2,1), CS, SN, TEMP ) END IF CST = CS SNT = SN PDW = PDM C DO 30 I = K, 2, -1 PDW = PDW - 8 T(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) T(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) T(1,2) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) ) T(2,2) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) IF ( S(AMAP(I)).EQ.SINV) THEN CALL ZROT( 2, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) ) TEMP = T(1,1) CALL ZLARTG( TEMP, T(2,1), CS, SN, T(1,1) ) T(2,1) = CZERO CALL ZROT( 1, T(1,2), 2, T(2,2), 2, CS, SN ) ELSE CALL ZROT( 2, T(1,1), 2, T(2,1), 2, CS, SN ) TEMP = T(2,2) CALL ZLARTG( TEMP, T(2,1), CS, SN, T(2,2) ) T(2,1) = CZERO SN = -SN CALL ZROT( 1, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) ) END IF DWORK(PDW+1) = DREAL( T(1,1) ) DWORK(PDW+2) = DIMAG( T(1,1) ) DWORK(PDW+3) = DREAL( T(2,1) ) DWORK(PDW+4) = DIMAG( T(2,1) ) DWORK(PDW+5) = DREAL( T(1,2) ) DWORK(PDW+6) = DIMAG( T(1,2) ) DWORK(PDW+7) = DREAL( T(2,2) ) DWORK(PDW+8) = DIMAG( T(2,2) ) 30 CONTINUE C PDW = 0 T(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) T(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) T(1,2) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) ) T(2,2) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) CALL ZROT( 2, T(1,1), 2, T(2,1), 2, CST, SNT ) CALL ZROT( 2, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) ) DWORK(PDW+1) = DREAL( T(1,1) ) DWORK(PDW+2) = DIMAG( T(1,1) ) DWORK(PDW+3) = DREAL( T(2,1) ) DWORK(PDW+4) = DIMAG( T(2,1) ) DWORK(PDW+5) = DREAL( T(1,2) ) DWORK(PDW+6) = DIMAG( T(1,2) ) DWORK(PDW+7) = DREAL( T(2,2) ) DWORK(PDW+8) = DIMAG( T(2,2) ) 40 CONTINUE C C Not converged. C INFO = 1 GO TO 80 C C Converged. C 50 CONTINUE C DO 70 J = 1, 2 PDW = 0 IF ( J.EQ.2 ) $ PDW = 6 TEMPI = ZERO TEMPR = ONE BETA(J) = ONE SCAL(J) = 0 C DO 60 I = 1, K RHS = DLAPY2( DWORK(PDW+1), DWORK(PDW+2) ) IF ( RHS.NE.ZERO ) THEN SL = INT( LOG( RHS ) / LGBAS ) DWORK(PDW+1) = DWORK(PDW+1) / ( BASE**DBLE( SL ) ) DWORK(PDW+2) = DWORK(PDW+2) / ( BASE**DBLE( SL ) ) END IF IF ( S(AMAP(I)).EQ.1 ) THEN LHS = TEMPI TEMPI = TEMPR*DWORK(PDW+2) + TEMPI*DWORK(PDW+1) TEMPR = TEMPR*DWORK(PDW+1) - LHS*DWORK(PDW+2) SCAL(J) = SCAL(J) + SL ELSE IF ( RHS.EQ.ZERO ) THEN BETA(J) = ZERO ELSE LHS = TEMPR RHS = TEMPI CALL DLADIV( LHS, RHS, DWORK(PDW+1), DWORK(PDW+2), $ TEMPR, TEMPI ) SCAL(J) = SCAL(J) - SL END IF IF ( ( MOD( I, 10 ).EQ.0 ) .OR. ( I.EQ.K ) ) THEN RHS = DLAPY2( TEMPR, TEMPI ) IF ( RHS.EQ.ZERO ) THEN SCAL(J) = 0 ELSE SL = INT( LOG( RHS ) / LGBAS ) TEMPR = TEMPR / ( BASE**DBLE( SL ) ) TEMPI = TEMPI / ( BASE**DBLE( SL ) ) SCAL(J) = SCAL(J) + SL END IF END IF PDW = PDW + 8 60 CONTINUE C ALPHAR(J) = TEMPR ALPHAI(J) = TEMPI 70 CONTINUE C IF ( TEMPI.GT.ZERO ) THEN ALPHAR(2) = ALPHAR(1) ALPHAI(2) = ALPHAI(1) ALPHAR(1) = TEMPR ALPHAI(1) = TEMPI TEMPR = SCAL(2) SCAL(2) = SCAL(1) SCAL(1) = TEMPR END IF C INFO = 0 C 80 CONTINUE RETURN C *** Last line of MB03BB *** END slicot-5.0+20101122/src/MB03BC.f000077500000000000000000000311301201767322700153530ustar00rootroot00000000000000 SUBROUTINE MB03BC( K, AMAP, S, SINV, A, LDA1, LDA2, MACPAR, CV, $ SV, DWORK ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To compute the product singular value decomposition of the K-1 C triangular factors corresponding to a 2-by-2 product of K C factors in upper Hessenberg-triangular form. C For a general product of 2-by-2 triangular matrices C C S(2) S(3) S(K) C A = A(:,:,2) A(:,:,3) ... A(:,:,K), C C Givens rotators are computed so that C S(i) C [ CV(i-1) SV(i-1) ] [ A(1,1,i)(in) A(1,2,i)(in) ] C [ -SV(i-1) CV(i-1) ] [ 0 A(2,2,i)(in) ] C S(i) C [ A(1,1,i)(out) A(1,2,i)(out) ] [ CV(i) SV(i) ] C = [ 0 A(2,2,i)(out) ] [ -SV(i) CV(i) ] C C stays upper triangular and C C [ CV(1) SV(1) ] [ CV(K) -SV(K) ] C [ -SV(1) CV(1) ] * A * [ SV(K) CV(K) ] C C is diagonal. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading 2-by-2-by-K part of this array must C contain a 2-by-2 product (implicitly represented by its K C factors) in upper Hessenberg-triangular form. C On exit, the leading 2-by-2-by-K part of this array C contains modified triangular factors such that their C product is diagonal. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= 2. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= 2. C C MACPAR (input) DOUBLE PRECISION array, dimension (5) C Machine parameters: C MACPAR(1) overflow threshold, DLAMCH( 'O' ); C MACPAR(2) underflow threshold, DLAMCH( 'U' ); C MACPAR(3) safe minimum, DLAMCH( 'S' ); C MACPAR(4) relative machine precision, DLAMCH( 'E' ); C MACPAR(5) base of the machine, DLAMCH( 'B' ). C C CV (output) DOUBLE PRECISION array, dimension (K) C On exit, the first K elements of this array contain the C cosines of the Givens rotators. C C SV (output) DOUBLE PRECISION array, dimension (K) C On exit, the first K elements of this array contain the C sines of the Givens rotators. C C Workspace C C DWORK DOUBLE PRECISION array, dimension 3*(K-1) C C METHOD C C The product singular value decomposition of the K-1 C triangular factors are computed as described in [1]. C C REFERENCES C C [1] Bojanczyk, A. and Van Dooren, P. C On propagating orthogonal transformations in a product of 2x2 C triangular matrices. C In Reichel, Ruttan and Varga: 'Numerical Linear Algebra', C pp. 1-9, 1993. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLAPST. C V. Sima, Nov. 2010. C C KEYWORDS C C Eigenvalues, orthogonal transformation, singular values, C singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0, $ TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER K, LDA1, LDA2, SINV C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*), CV(*), DWORK(*), MACPAR(*), $ SV(*) C .. Local Scalars .. INTEGER AI, I, PW, SCL DOUBLE PRECISION A11, A12, A22, B11, B12, B22, BASE, CC, CL, CR, $ EPS, MX, MX2, RMAX, RMIN, RMNS, RMXS, S11, S12, $ S22, SC, SFMN, SL, SR, SSMAX, SSMIN, T11, T12, $ T22, TEMP, TWOS C .. External Subroutines .. EXTERNAL DLARTG, DLASV2 C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C C .. Executable Statements .. C RMAX = MACPAR(1) RMXS = SQRT( RMAX ) RMIN = MACPAR(2) RMNS = SQRT( RMIN ) SFMN = MACPAR(3) EPS = MACPAR(4) BASE = MACPAR(5) TWOS = SQRT( TWO ) C C Compute the product of the 2-by-2 triangular matrices. C PW = 1 T11 = ONE T12 = ZERO T22 = ONE C DO 60 I = 2, K AI = AMAP(I) A11 = A(1,1,AI) A12 = A(1,2,AI) A22 = A(2,2,AI) IF ( S(AI).NE.SINV ) THEN TEMP = A11 A11 = A22 A22 = TEMP A12 = -A12 END IF C C A and T are scaled so that the elements of the resulting C product do not overflow. C MX = ABS( A11 ) / RMXS MX2 = ABS( T11 ) / RMXS 10 CONTINUE IF ( MX*MX2.GE.ONE ) THEN IF ( MX.GE.ONE ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.ONE ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 10 END IF C MX = ABS( A22 ) / RMXS MX2 = ABS( T22 ) / RMXS 20 CONTINUE IF ( MX*MX2.GE.ONE ) THEN IF ( MX.GE.ONE ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.ONE ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 20 END IF C MX = ABS( A12 ) / RMXS MX2 = ABS( T11 ) / RMXS 30 CONTINUE IF ( MX*MX2.GE.HALF ) THEN IF ( MX.GE.HALF ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.HALF ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 30 END IF C MX = ABS( A22 ) / RMXS MX2 = ABS( T12 ) / RMXS 40 CONTINUE IF ( MX*MX2.GE.HALF ) THEN IF ( MX.GE.HALF ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.HALF ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 40 END IF C C Avoid underflow if possible. C MX = MAX( ABS( A11 ), ABS( A22 ), ABS( A12 ) ) MX2 = MAX( ABS( T11 ), ABS( T22 ), ABS( T12 ) ) IF ( MX.NE.ZERO .AND. MX2.NE.ZERO ) THEN 50 CONTINUE IF ( ( MX.LE.( ONE/RMNS ) .AND. MX2.LE.RMNS ) .OR. $ ( MX.LE.RMNS .AND. MX2.LE.( ONE/RMNS ) ) ) $ THEN IF ( MX.LE.MX2 ) THEN MX = MX * BASE A11 = A11 * BASE A22 = A22 * BASE A12 = A12 * BASE ELSE MX2 = MX2 * BASE T11 = T11 * BASE T22 = T22 * BASE T12 = T12 * BASE END IF GOTO 50 END IF END IF T12 = T11 * A12 + T12 * A22 T11 = T11 * A11 T22 = T22 * A22 IF ( I.LT.K ) THEN DWORK(PW) = T11 DWORK(PW+1) = T12 DWORK(PW+2) = T22 PW = PW + 3 END IF 60 CONTINUE C C Compute the SVD of this product avoiding unnecessary C overflow/underflow in the singular values. C TEMP = MAX( ABS( T11 / TWO ) + ABS( T12 / TWO ), $ ABS( T22 / TWO ) ) IF ( TEMP.GT.( RMAX/( TWO * TWOS ) ) ) THEN TEMP = TEMP / BASE T11 = T11 / BASE T12 = T12 / BASE T22 = T22 / BASE END IF 70 CONTINUE IF ( TEMP.LT.( RMAX/( TWO * BASE * TWOS ) ) .AND. $ T11.NE.ZERO .AND. T22.NE.ZERO ) THEN SCL = 0 IF ( ABS( T22 ).LE.TWOS * RMIN ) THEN SCL = 1 ELSE IF ( EPS * ABS( T12 ).GT.ABS( T22 ) ) THEN IF ( SQRT( ABS( T11 ) ) * SQRT( ABS( T22 ) ).LE. $ ( SQRT( TWOS ) * RMNS ) * SQRT( ABS( T12 ) ) ) $ SCL = 1 ELSE IF ( ABS( T11 ).LE.TWOS * RMIN * $ ( ONE + ABS( T12 / T22 ) ) ) $ SCL = 1 END IF IF ( SCL.EQ.1 ) THEN TEMP = TEMP * BASE T11 = T11 * BASE T12 = T12 * BASE T22 = T22 * BASE GOTO 70 END IF END IF C CALL DLASV2( T11, T12, T22, SSMIN, SSMAX, SR, CR, SL, CL ) C C Now, the last transformation is propagated to the front as C described in [1]. C S11 = T11 S22 = T22 S12 = T12 C CV(K) = CR SV(K) = SR C DO 80 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN A11 = A(1,1,AI) A12 = A(1,2,AI) A22 = A(2,2,AI) ELSE A11 = A(2,2,AI) A12 = -A(1,2,AI) A22 = A(1,1,AI) END IF IF ( I.GT.2 ) THEN PW = PW - 3 T11 = DWORK(PW) T12 = DWORK(PW+1) T22 = DWORK(PW+2) IF ( ABS( SR * CL * S22 ).LT.ABS( SL * CR * S11 ) ) THEN B11 = T22 B22 = T11 B12 = -T12 CC = CL SC = SL ELSE B11 = A11 B12 = A12 B22 = A22 CC = CR SC = SR END IF MX = MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ) ) IF ( MX.GT.RMAX / TWO ) THEN B11 = B11 / TWO B22 = B22 / TWO B12 = B12 / TWO END IF CALL DLARTG( B11 * CC + B12 * SC, SC * B22, CC, SC, TEMP ) ELSE CC = CL SC = SL END IF IF ( ABS( SC ).LT.SFMN * ABS( A22 ) ) THEN A(1,1,AI) = SC * SR * A22 + CC * ( CR * A11 + SR * A12 ) ELSE A(1,1,AI) = ( A22 / SC ) * SR END IF IF ( ABS( SR ).LT.SFMN * ABS( A11 ) ) THEN A(2,2,AI) = SC * SR * A11 + CR * ( CC * A22 - SC * A12 ) ELSE A(2,2,AI) = ( A11 / SR ) * SC END IF A(1,2,AI) = ( A12 * CR - A11 * SR ) * CC + A22 * CR * SC IF ( S(AI).NE.SINV ) THEN TEMP = A(1,1,AI) A(1,1,AI) = A(2,2,AI) A(2,2,AI) = TEMP A(1,2,AI) = -A(1,2,AI) END IF CR = CC SR = SC CV(I-1) = CR SV(I-1) = SR S11 = T11 S12 = T12 S22 = T22 80 CONTINUE C CV(1) = CL SV(1) = SL C RETURN C *** Last line of MB03BC *** END slicot-5.0+20101122/src/MB03BD.f000077500000000000000000001677321201767322700153760ustar00rootroot00000000000000 SUBROUTINE MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, $ A, LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, $ BETA, SCAL, IWORK, LIWORK, DWORK, LDWORK, $ IWARN, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 eigenvalues of the generalized matrix product C C S(1) S(2) S(K) C A(:,:,1) * A(:,:,2) * ... * A(:,:,K) C C where A(:,:,H) is upper Hessenberg and A(:,:,i), i <> H, is upper C triangular, using a double-shift version of the periodic C QZ method. In addition, A may be reduced to periodic Schur form: C A(:,:,H) is upper quasi-triangular and all the other factors C A(:,:,I) are upper triangular. Optionally, the 2-by-2 triangular C matrices corresponding to 2-by-2 diagonal blocks in A(:,:,H) C are so reduced that their product is a 2-by-2 diagonal matrix. C C If COMPQ = 'U' or COMPQ = 'I', then the orthogonal factors are C computed and stored in the array Q so that for S(I) = 1, C C T C Q(:,:,I)(in) A(:,:,I)(in) Q(:,:,MOD(I,K)+1)(in) C T (1) C = Q(:,:,I)(out) A(:,:,I)(out) Q(:,:,MOD(I,K)+1)(out), C C and for S(I) = -1, C C T C Q(:,:,MOD(I,K)+1)(in) A(:,:,I)(in) Q(:,:,I)(in) C T (2) C = Q(:,:,MOD(I,K)+1)(out) A(:,:,I)(out) Q(:,:,I)(out). C C A partial generation of the orthogonal factors can be realized C via the array QIND. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; A will not C necessarily be put into periodic Schur form; C = 'S': put A into periodic Schur form, and return the C eigenvalues in ALPHAR, ALPHAI, BETA, and SCAL; C = 'T': as JOB = 'S', but A is put into standardized C periodic Schur form, that is, the general product C of the 2-by-2 triangular matrices corresponding to C a complex eigenvalue is diagonal. C C DEFL CHARACTER*1 C Specifies the deflation strategy to be used, as follows: C = 'C': apply a careful deflation strategy, that is, C the criteria are based on the magnitudes of C neighboring elements and infinite eigenvalues are C only deflated at the top; this is the recommended C option; C = 'A': apply a more aggressive strategy, that is, C elements on the subdiagonal or diagonal are set C to zero as soon as they become smaller in magnitude C than eps times the norm of the corresponding C factor; this option is only recommended if C balancing is applied beforehand and convergence C problems are observed. C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': do not modify Q; C = 'U': modify (update) the array Q by the orthogonal C transformations that are applied to the matrices in C the array A to reduce them to periodic Schur form; C = 'I': like COMPQ = 'U', except that each matrix in the C array Q will be first initialized to the identity C matrix; C = 'P': use the parameters as encoded in QIND. C C QIND INTEGER array, dimension (K) C If COMPQ = 'P', then this array describes the generation C of the orthogonal factors as follows: C If QIND(I) > 0, then the array Q(:,:,QIND(I)) is C modified by the transformations corresponding to the C i-th orthogonal factor in (1) and (2). C If QIND(I) < 0, then the array Q(:,:,-QIND(I)) is C initialized to the identity and modified by the C transformations corresponding to the i-th orthogonal C factor in (1) and (2). C If QIND(I) = 0, then the transformations corresponding C to the i-th orthogonal factor in (1), (2) are not applied. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of each factor in the array A. N >= 0. C C H (input) INTEGER C Hessenberg index. The factor A(:,:,H) is on entry in upper C Hessenberg form. 1 <= H <= K. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that each factor in A is already upper C triangular in rows and columns 1:ILO-1 and IHI+1:N. C 1 <= ILO <= IHI <= N, if N > 0; C ILO = 1 and IHI = 0, if N = 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures of the factors. Each entry in S must be either C 1 or -1. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading N-by-N-by-K part of this array C must contain the factors in upper Hessenberg-triangular C form, that is, A(:,:,H) is upper Hessenberg and the other C factors are upper triangular. C On exit, if JOB = 'S' and INFO = 0, the leading C N-by-N-by-K part of this array contains the factors of C A in periodic Schur form, that is, A(:,:,H) is upper quasi C triangular and the other factors are upper triangular. C On exit, if JOB = 'T' and INFO = 0, the leading C N-by-N-by-K part of this array contains the factors of C A as for the option JOB = 'S', but the product of the C triangular factors corresponding to a 2-by-2 block in C A(:,:,H) is diagonal. C On exit, if JOB = 'E', then the leading N-by-N-by-K part C of this array contains meaningless elements. 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 Q (input/output) DOUBLE PRECISION array, dimension C (LDQ1,LDQ2,K) C On entry, if COMPQ = 'U', the leading N-by-N-by-K part C of this array must contain the initial orthogonal factors C as described in (1) and (2). C On entry, if COMPQ = 'P', only parts of the leading C N-by-N-by-K part of this array must contain some C orthogonal factors as described by the parameters QIND. C If COMPQ = 'I', this array should not set on entry. C On exit, if COMPQ = 'U' or COMPQ = 'I', the leading C N-by-N-by-K part of this array contains the modified C orthogonal factors as described in (1) and (2). C On exit, if COMPQ = 'P', only parts of the leading C N-by-N-by-K part contain some modified orthogonal factors C as described by the parameters QIND. C This array is not referenced if COMPQ = 'N'. C C LDQ1 INTEGER C The first leading dimension of the array Q. LDQ1 >= 1, C and, if COMPQ <> 'N', LDQ1 >= MAX(1,N). C C LDQ2 INTEGER C The second leading dimension of the array Q. LDQ2 >= 1, C and, if COMPQ <> 'N', LDQ2 >= MAX(1,N). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C On exit, if IWARN = 0 and INFO = 0, the leading N elements C of this array contain the scaled real parts of the C eigenvalues of the matrix product A. The i-th eigenvalue C of A is given by C C (ALPHAR(I) + ALPHAI(I)*SQRT(-1))/BETA(I) * BASE**SCAL(I), C C where BASE is the machine base (often 2.0). C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C On exit, if IWARN = 0 and INFO = 0, the leading N elements C of this array contain the scaled imaginary parts of the C eigenvalues of A. C C BETA (output) DOUBLE PRECISION array, dimension (N) C On exit, if IWARN = 0 and INFO = 0, the leading N elements C of this array contain indicators for infinite eigenvalues. C That is, if BETA(I) = 0.0, then the i-th eigenvalue is C infinite. Otherwise BETA(I) is set to 1.0. C C SCAL (output) INTEGER array, dimension (N) C On exit, if IWARN = 0 and INFO = 0, the leading N elements C of this array contain the scaling parameters for the C eigenvalues of A. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. C On exit, if INFO = -22, IWORK(1) returns the minimum value C of LIWORK. C C LIWORK INTEGER C The length of the array IWORK. LIWORK >= MAX( 1,2*K ). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -24, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C If DEFL = 'C', LDWORK >= MAX( 1,MAX( 2*N,8*K ) ); C if DEFL = 'A', LDWORK >= MAX( 1,K + MAX( 2*N,8*K ) ). C C Warning Indicator C C IWARN INTEGER C = 0 : no warnings; C = 1,..,N-1 : A is in periodic Schur form, but the C algorithm was not able to reveal information C about the eigenvalues from the 2-by-2 C blocks. C ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i), C can be incorrect for i = 1, ..., IWARN+1. 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,..,N : the periodic QZ iteration did not converge. C A is not in periodic Schur form, but C ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i), for C i = INFO+1,...,N should be correct. C C METHOD C C A modified version of the periodic QZ algorithm is used [1], [2]. C C REFERENCES C C [1] Bojanczyk, A., Golub, G. H. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C In F.T. Luk (editor), Advanced Signal Processing Algorithms, C Architectures, and Implementations III, Proc. SPIE Conference, C vol. 1770, pp. 31-42, 1992. C C [2] Kressner, D. C An efficient and reliable implementation of the periodic QZ C algorithm. IFAC Workshop on Periodic Control Systems (PSYCO C 2001), Como (Italy), August 27-28 2001. Periodic Control C Systems 2001 (IFAC Proceedings Volumes), Pergamon. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C 3 C The algorithm requires 0(K N ) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PHGEQZ. C V. Sima, June 2010, July 2010, Nov. 2010. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER COMPQ, DEFL, JOB INTEGER H, IHI, ILO, INFO, IWARN, K, LDA1, LDA2, LDQ1, $ LDQ2, LDWORK, LIWORK, N C .. Array Arguments .. INTEGER IWORK(*), QIND(*), S(*), SCAL(*) DOUBLE PRECISION A(LDA1,LDA2,*), ALPHAI(*), ALPHAR(*), $ BETA(*), DWORK(*), Q(LDQ1,LDQ2,*) C .. Local Arrays .. INTEGER ISEED(4) DOUBLE PRECISION MACPAR(5) C .. Local Scalars .. LOGICAL ADEFL, LCMPQ, LINIQ, LPARQ, LSCHR, LSVD INTEGER AIND, I, IERR, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, J, J1, JDEF, JITER, JLO, L, LDEF, $ LM, MAXIT, NTRA, OPTDW, OPTIW, QI, SINV, TITER, $ ZITER DOUBLE PRECISION BASE, CS, CS1, CS2, LGBAS, SAFMAX, SAFMIN, $ SMLNUM, SN, SN1, SN2, TEMP, TEMP2, TEMP3, TOL, $ ULP C .. Workspace Pointers .. INTEGER MAPA, MAPQ, PDW, PFREE, PNORM C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS, LSAME C .. External Subroutines .. EXTERNAL DLABAD, DLARNV, DLARTG, DLASET, DROT, MA01BD, $ MB03AD, MB03BA, MB03BB, MB03BC, MB03BE, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the scalar input parameters. C LSVD = LSAME( JOB, 'T' ) LSCHR = LSAME( JOB, 'S' ) .OR. LSVD LINIQ = LSAME( COMPQ, 'I' ) LCMPQ = LSAME( COMPQ, 'U' ) .OR. LINIQ LPARQ = LSAME( COMPQ, 'P' ) ADEFL = LSAME( DEFL, 'A' ) IWARN = 0 IF ( ADEFL ) THEN OPTDW = MAX( 1, K + MAX( 2*N,8*K ) ) ELSE OPTDW = MAX( 1, MAX( 2*N,8*K ) ) END IF OPTIW = MAX( 1, 2*K ) C C Check the scalar input parameters. C INFO = 0 IF ( .NOT. ( LSCHR .OR. LSAME( JOB, 'E' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( ADEFL .OR. LSAME( DEFL, 'C' ) ) ) THEN INFO = -2 ELSE IF ( .NOT.( LCMPQ .OR. LPARQ .OR. LSAME( COMPQ, 'N' ) ) ) $ THEN INFO = -3 ELSE IF ( K.LT.0 ) THEN INFO = -5 ELSE IF ( N.LT.0 ) THEN INFO = -6 ELSE IF ( H.LT.1 .OR. H.GT.K ) THEN INFO = -7 ELSE IF ( ILO.LT.1 ) THEN INFO = -8 ELSE IF ( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -9 ELSE IF ( LDA1.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF ( LDA2.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF ( LDQ1.LT.1 .OR. ( ( LCMPQ .OR. LPARQ ) $ .AND. LDQ1.LT.N ) ) THEN INFO = -15 ELSE IF ( LDQ2.LT.1 .OR. ( ( LCMPQ .OR. LPARQ ) $ .AND. LDQ2.LT.N ) ) THEN INFO = -16 ELSE IF ( LIWORK.LT.OPTIW ) THEN IWORK(1) = OPTIW INFO = -22 ELSE IF ( LDWORK.LT.OPTDW ) THEN DWORK(1) = DBLE( OPTDW ) INFO = -24 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03BD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE IWORK(1) = 1 RETURN END IF C C Initialize Q. C DO 10 I = 1, K J = 0 IF ( LINIQ ) THEN J = I ELSE IF ( LPARQ ) THEN J = -QIND(I) END IF IF ( J.NE.0 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q(1,1,J), LDQ1 ) 10 CONTINUE C C Compute Maps for accessing A and Q. C MAPA = 0 MAPQ = K QI = 0 CALL MB03BA( K, H, S, SINV, IWORK(MAPA+1), IWORK(MAPQ+1) ) C C Machine Constants. C IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'SafeMinimum' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'Precision' ) CALL DLABAD( SAFMIN, SAFMAX ) SMLNUM = SAFMIN*( IN / ULP ) BASE = DLAMCH( 'Base' ) LGBAS = LOG( BASE ) C MACPAR(2) = DLAMCH( 'Underflow' ) IF ( LSVD ) THEN MACPAR(1) = DLAMCH( 'ORmax' ) MACPAR(3) = SAFMIN MACPAR(4) = DLAMCH( 'Epsilon' ) MACPAR(5) = BASE END IF IF ( K.GE.INT( LOG( MACPAR(2) ) / LOG( ULP ) ) ) THEN C C Start Iteration with a controlled zero shift. C ZITER = -1 ELSE ZITER = 0 END IF C C Compute norms. C IF ( ADEFL ) THEN PNORM = 0 PFREE = K DO 20 I = 1, K AIND = IWORK( MAPA + I ) DWORK(I) = DLANHS( 'Frobenius', IN, A(ILO,ILO,AIND), LDA1, $ DWORK( PFREE + 1 ) ) 20 CONTINUE ELSE PFREE = 0 END IF C C Set Eigenvalues IHI+1:N. C DO 30 J = IHI + 1, N CALL MA01BD( BASE, LGBAS, K, S, A(J,J,1), LDA1*LDA2, ALPHAR(J), $ BETA(J), SCAL(J) ) ALPHAI(J) = ZERO 30 CONTINUE C C If IHI < ILO, skip QZ steps. C IF ( IHI.LT.ILO ) $ GO TO 500 C C MAIN PERIODIC QZ ITERATION LOOP. C C Initialize dynamic indices. C C Eigenvalues ILAST+1:N have been found. C Column operations modify rows IFRSTM:whatever. C Row operations modify columns whatever:ILASTM. C C If only eigenvalues are being computed, then C IFRSTM is the row of the last splitting row above row ILAST; C this is always at least ILO. C IITER counts iterations since the last eigenvalue was found, C to tell when to use an observed zero or random shift. C MAXIT is the maximum number of QZ sweeps allowed. C ILAST = IHI IF ( LSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 TITER = 0 ISEED(1) = 1 ISEED(2) = 0 ISEED(3) = 0 ISEED(4) = 1 MAXIT = 30 * IN C DO 490 JITER = 1, MAXIT C C Special Case: ILAST = ILO. C IF ( ILAST.EQ.ILO ) $ GO TO 390 C C ************************************************************** C * CHECK FOR DEFLATION * C ************************************************************** C C Test 1: Deflation in the Hessenberg matrix. C IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK( PNORM + 1 )*ULP ) AIND = IWORK( MAPA + 1 ) JLO = ILO DO 40 J = ILAST, ILO + 1, -1 IF ( .NOT.ADEFL ) THEN TOL = ABS( A(J-1,J-1,AIND) ) + ABS( A(J,J,AIND) ) IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-ILO+1, A(ILO,ILO,AIND), LDA1, $ DWORK(PFREE+1) ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J,J-1,AIND) ).LE.TOL ) THEN A(J,J-1,AIND) = ZERO JLO = J IF ( J.EQ.ILAST ) $ GO TO 390 GO TO 50 END IF 40 CONTINUE C 50 CONTINUE C C Test 2: Deflation in the triangular matrices with index 1. C DO 70 LDEF = 2, K AIND = IWORK( MAPA + LDEF ) IF ( S(AIND).EQ.SINV ) THEN IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK( PNORM + LDEF )*ULP ) DO 60 J = ILAST, JLO, -1 IF ( .NOT.ADEFL ) THEN IF ( J.EQ.ILAST ) THEN TOL = ABS( A(J-1,J,AIND) ) ELSE IF ( J.EQ.JLO ) THEN TOL = ABS( A(J,J+1,AIND) ) ELSE TOL = ABS( A(J-1,J,AIND) ) $ + ABS( A(J,J+1,AIND) ) END IF IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+1, A(JLO,JLO,AIND), $ LDA1, DWORK(PFREE+1) ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J,J,AIND) ).LE.TOL ) THEN A(J,J,AIND) = ZERO GO TO 170 END IF 60 CONTINUE END IF 70 CONTINUE C C Test 3: Deflation in the triangular matrices with index -1. C DO 90 LDEF = 2, K AIND = IWORK( MAPA + LDEF ) IF ( S(AIND).NE.SINV ) THEN IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK( PNORM + LDEF )*ULP ) DO 80 J = ILAST, JLO, -1 IF ( .NOT.ADEFL ) THEN IF ( J.EQ.ILAST ) THEN TOL = ABS( A(J-1,J,AIND) ) ELSE IF ( J.EQ.JLO ) THEN TOL = ABS( A(J,J+1,AIND) ) ELSE TOL = ABS( A(J-1,J,AIND) ) $ + ABS( A(J,J+1,AIND) ) END IF IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+1, A(JLO,JLO,AIND), $ LDA1, DWORK(PFREE+1) ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J,J,AIND) ).LE.TOL ) THEN A(J,J,AIND) = ZERO GO TO 320 END IF 80 CONTINUE END IF 90 CONTINUE C C Test 4: Controlled zero shift. C IF ( ZITER.GE.7 .OR. ZITER.LT.0 ) THEN C C Make Hessenberg matrix upper triangular. C AIND = IWORK( MAPA + 1 ) PDW = PFREE + 1 DO 100 J = JLO, ILAST - 1 TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 100 CONTINUE IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 1 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 1 )) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 110 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 110 CONTINUE END IF C C Propagate Transformations back to A_1. C DO 150 L = K, 2, -1 AIND = IWORK( MAPA + L ) PDW = PFREE + 1 IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK( PNORM + L )*ULP ) IF ( S(AIND).EQ.SINV ) THEN DO 120 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) IF ( SN.NE.ZERO ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) C C Check for deflation. C IF ( .NOT.ADEFL ) THEN TOL = ABS( A(J,J,AIND) ) + $ ABS( A(J+1,J+1,AIND) ) IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+2, $ A(JLO,JLO,AIND), LDA1, $ DWORK(PFREE+2*N+1) ) TOL = MAX( ULP*TOL, SMLNUM ) IF ( ABS( A(J+1,J,AIND) ).LE.TOL ) THEN CS = ONE SN = ZERO A(J+1,J,AIND) = ZERO END IF END IF END IF IF ( SN.NE.ZERO ) THEN TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) END IF DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 120 CONTINUE ELSE DO 130 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) IF ( SN.NE.ZERO ) THEN CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) C C Check for deflation. C IF ( .NOT.ADEFL ) THEN TOL = ABS( A(J,J,AIND) ) + $ ABS( A(J+1,J+1,AIND) ) IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+2, $ A(JLO,JLO,AIND), LDA1, $ DWORK(PFREE+2*N+1) ) TOL = MAX( ULP*TOL, SMLNUM ) IF ( ABS( A(J+1,J,AIND) ).LE.TOL ) THEN CS = ONE SN = ZERO A(J+1,J,AIND) = ZERO END IF END IF END IF IF ( SN.NE.ZERO ) THEN TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO SN = -SN CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) END IF DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 130 CONTINUE END IF IF ( LCMPQ ) THEN QI = IWORK( MAPQ + L ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + L )) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 140 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 IF ( SN.NE.ZERO ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, $ SN ) 140 CONTINUE END IF 150 CONTINUE C C Apply the transformations to the right hand side of the C Hessenberg factor. C AIND = IWORK( MAPA + 1 ) PDW = PFREE + 1 ZITER = 0 DO 160 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) IF ( SN.NE.ZERO ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) ELSE ZITER = -1 END IF PDW = PDW + 2 160 CONTINUE C C No QZ iteration. C GO TO 480 END IF C C ************************************************************** C * HANDLE DEFLATIONS * C ************************************************************** C C Case I: Deflation occurs in the Hessenberg matrix. The QZ C iteration is only applied to the JLO:ILAST part. C IFIRST = JLO C C Go to the periodic QZ steps. C GO TO 400 C C Case II: Deflation occurs in a triangular matrix with index 1. C C Do an unshifted periodic QZ step. C 170 CONTINUE JDEF = J AIND = IWORK( MAPA + 1 ) PDW = PFREE + 1 DO 180 J = JLO, JDEF - 1 TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND), $ LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 180 CONTINUE IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 1 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 1 )) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 190 J = JLO, JDEF - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 190 CONTINUE END IF C C Propagate the transformations through the triangular matrices. C Due to the zero element on the diagonal of the LDEF-th factor, C the number of transformations drops by one. C DO 230 L = K, 2, -1 AIND = IWORK( MAPA + L ) IF ( L.LT.LDEF ) THEN NTRA = JDEF - 2 ELSE NTRA = JDEF - 1 END IF PDW = PFREE + 1 IF ( S(AIND).EQ.SINV ) THEN DO 200 J = JLO, NTRA CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 200 CONTINUE ELSE DO 210 J = JLO, NTRA CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO SN = -SN CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 210 CONTINUE END IF IF ( LCMPQ ) THEN QI = IWORK( MAPQ + L ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + L )) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 220 J = JLO, NTRA CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 220 CONTINUE END IF 230 CONTINUE C C Apply the transformations to the right hand side of the C Hessenberg factor. C AIND = IWORK( MAPA + 1 ) PDW = PFREE + 1 DO 240 J = JLO, JDEF - 2 CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) PDW = PDW + 2 240 CONTINUE C C Do an unshifted periodic QZ step. C PDW = PFREE + 1 DO 250 J = ILAST, JDEF + 1, -1 TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, A(J,J,AIND) ) A(J,J-1,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 250 CONTINUE IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 2 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 2 )) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 260 J = ILAST, JDEF + 1, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) 260 CONTINUE END IF C C Propagate the transformations through the triangular matrices. C DO 300 L = 2, K AIND = IWORK( MAPA + L ) IF ( L.GT.LDEF ) THEN NTRA = JDEF + 2 ELSE NTRA = JDEF + 1 END IF PDW = PFREE + 1 IF ( S(AIND).NE.SINV ) THEN DO 270 J = ILAST, NTRA, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J-1,J-1,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J-1,J-1,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, $ A(J,J,AIND), LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 270 CONTINUE ELSE DO 280 J = ILAST, NTRA, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, $ A(J,J-1,AIND), LDA1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J,J,AIND) ) A(J,J-1,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 280 CONTINUE END IF LM = L + 1 IF ( L.EQ.K ) $ LM = 1 IF ( LCMPQ ) THEN QI = IWORK( MAPQ + LM ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + LM )) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 290 J = ILAST, NTRA, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) 290 CONTINUE END IF 300 CONTINUE C C Apply the transformations to the left hand side of the C Hessenberg factor. C AIND = IWORK( MAPA + 1 ) PDW = PFREE + 1 DO 310 J = ILAST, JDEF + 2, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, A(J,J-1,AIND), $ LDA1, CS, SN ) 310 CONTINUE C C No QZ iteration. C GO TO 480 C C Case III: Deflation occurs in a triangular matrix with C index -1. C 320 CONTINUE JDEF = J PDW = PFREE + 1 IF ( JDEF.GT.( ( ILAST - JLO + 1 )/2 ) ) THEN C C Chase the zero downwards to the last position. C DO 340 J1 = JDEF, ILAST - 1 J = J1 AIND = IWORK( MAPA + LDEF ) TEMP = A(J,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J+1,AIND), CS, SN, $ A(J,J+1,AIND) ) A(J+1,J+1,AIND) = ZERO CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1, $ A(J+1,J+2,AIND), LDA1, CS, SN ) LM = LDEF + 1 IF ( LDEF.EQ.K ) $ LM = 1 IF ( LCMPQ ) THEN QI = IWORK( MAPQ + LM ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + LM )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) DO 330 L = 1, K - 1 AIND = IWORK( MAPA + LM ) IF ( LM.EQ.1 ) THEN CALL DROT( ILASTM-J+2, A(J,J-1,AIND), LDA1, $ A(J+1,J-1,AIND), LDA1, CS, SN ) TEMP = A(J+1,J,AIND) CALL DLARTG( TEMP, A(J+1,J-1,AIND), CS, SN, $ A(J+1,J,AIND) ) A(J+1,J-1,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM+1, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) J = J-1 ELSE IF ( S(AIND).EQ.SINV ) THEN CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) ELSE CALL DROT( J-IFRSTM+2, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) END IF LM = LM + 1 IF ( LM.GT.K ) $ LM = 1 IF ( LCMPQ ) THEN QI = IWORK( MAPQ + LM ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + LM )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, $ SN ) 330 CONTINUE AIND = IWORK( MAPA + LDEF ) CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) 340 CONTINUE C C Deflate the last element in the Hessenberg matrix. C AIND = IWORK( MAPA + 1 ) J = ILAST TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, A(J,J,AIND) ) A(J,J-1,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 2 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 2 )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) DO 350 L = 2, LDEF - 1 AIND = IWORK( MAPA + L ) IF ( S(AIND).NE.SINV ) THEN CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J-1,J-1,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J-1,J-1,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, $ A(J,J,AIND), LDA1, CS, SN ) ELSE CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, $ A(J,J-1,AIND), LDA1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J,J,AIND) ) A(J,J-1,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) END IF LM = L + 1 IF ( L.EQ.K ) $ LM = 1 IF ( LCMPQ ) THEN QI = IWORK( MAPQ + LM ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + LM )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) 350 CONTINUE AIND = IWORK( MAPA + LDEF ) CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) ELSE C C Chase the zero upwards to the first position. C DO 370 J1 = JDEF, JLO + 1, -1 J = J1 AIND = IWORK( MAPA + LDEF ) TEMP = A(J-1,J,AIND) CALL DLARTG( TEMP, A(J-1,J-1,AIND), CS, SN, $ A(J-1,J,AIND) ) A(J-1,J-1,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM-1, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) IF ( LCMPQ ) THEN QI = IWORK( MAPQ + LDEF ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + LDEF )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) LM = LDEF - 1 DO 360 L = 1, K - 1 AIND = IWORK( MAPA + LM ) IF ( LM.EQ.1 ) THEN CALL DROT( J-IFRSTM+2, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J,J-1,AIND) CALL DLARTG( TEMP, A(J+1,J-1,AIND), CS, SN, $ A(J,J-1,AIND) ) A(J+1,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) J = J + 1 ELSE IF ( S(AIND).NE.SINV ) THEN CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, $ A(J,J-1,AIND), LDA1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J,J,AIND) ) A(J,J-1,AIND) = ZERO SN = -SN CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) ELSE CALL DROT( J-IFRSTM+1, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J-1,J-1,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J-1,J-1,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, $ A(J,J,AIND), LDA1, CS, SN ) END IF IF ( LCMPQ ) THEN QI = IWORK( MAPQ + LM ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + LM )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, $ SN ) LM = LM - 1 IF ( LM.LE.0 ) $ LM = K 360 CONTINUE AIND = IWORK( MAPA + LDEF ) CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, A(J,J,AIND), $ LDA1, CS, SN ) 370 CONTINUE C C Deflate the first element in the Hessenberg matrix. C AIND = IWORK( MAPA + 1 ) J = JLO TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND), $ LDA1, CS, SN ) IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 1 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 1 )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) DO 380 L = K, LDEF + 1, -1 AIND = IWORK( MAPA + L ) IF ( S(AIND).EQ.SINV ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) ELSE CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO SN = -SN CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) END IF IF ( LCMPQ ) THEN QI = IWORK( MAPQ + L ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + L )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 380 CONTINUE AIND = IWORK( MAPA + LDEF ) CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND), $ LDA1, CS, SN ) END IF C C No QZ iteration. C GO TO 480 C C Special case: A 1x1 block splits off at the bottom. C 390 CONTINUE CALL MA01BD( BASE, LGBAS, K, S, A(ILAST,ILAST,1), LDA1*LDA2, $ ALPHAR(ILAST), BETA(ILAST), SCAL(ILAST) ) ALPHAI(ILAST) = ZERO C C Go to next block - exit if finished. C ILAST = ILAST - 1 IF ( ILAST.LT.ILO ) $ GO TO 500 C C Reset iteration counters. C IITER = 0 TITER = 0 IF ( ZITER.NE.-1 ) $ ZITER = 0 IF ( .NOT.LSCHR ) THEN ILASTM = ILAST IF ( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF C C No QZ iteration. C GO TO 480 C C ************************************************************** C * PERIODIC QZ STEP * C ************************************************************** C C It is assumed that IFIRST < ILAST. C 400 CONTINUE C IITER = IITER + 1 ZITER = ZITER + 1 IF( .NOT.LSCHR ) $ IFRSTM = IFIRST IF ( IFIRST+1.EQ.ILAST ) THEN C C Special case -- 2x2 block. C J = ILAST - 1 IF ( TITER.LT.2 ) THEN TITER = TITER + 1 C C Try to deflate the 2-by-2 problem. C PDW = PFREE + 1 DO 410 L = 1, K DWORK( PDW ) = A(J,J,L) DWORK( PDW+1 ) = A(J+1,J,L) DWORK( PDW+2 ) = A(J,J+1,L) DWORK( PDW+3 ) = A(J+1,J+1,L) PDW = PDW + 4 410 CONTINUE CALL MB03BE( K, IWORK(MAPA+1), S, SINV, DWORK(PFREE+1), $ 2, 2 ) IF ( ABS( DWORK(PFREE+2) ).LT.ULP*( $ MAX( ABS( DWORK(PFREE+1) ), $ ABS( DWORK(PFREE+3) ), $ ABS( DWORK(PFREE+4) ) ) ) ) THEN C C Construct a perfect shift polynomial. This may fail, C so we try it twice (indicated by TITER). C CS1 = ONE SN1 = ONE DO 420 L = K, 2, -1 AIND = IWORK(MAPA+L) TEMP = DWORK( PFREE + AIND*4 ) IF ( S(AIND).EQ.SINV ) THEN CALL DLARTG( CS1*A(J,J,AIND), SN1*TEMP, CS1, $ SN1, TEMP ) ELSE CALL DLARTG( CS1*TEMP, SN1*A(J,J,AIND), CS1, $ SN1, TEMP ) END IF 420 CONTINUE AIND = IWORK(MAPA+1) TEMP = DWORK( PFREE + AIND*4 ) CALL DLARTG( A(J,J,AIND)*CS1-TEMP*SN1, $ A(J+1,J,AIND)*CS1, CS1, SN1, TEMP ) GO TO 460 END IF END IF C C Looks like a complex block. C 1. Compute the product SVD of the triangular matrices C (optionally). C IF ( LSVD ) THEN CALL MB03BC( K, IWORK(MAPA+1), S, SINV, A(J,J,1), LDA1, $ LDA2, MACPAR, DWORK(PFREE+1), $ DWORK(PFREE+K+1), DWORK(PFREE+2*K+1) ) C C Update factors and transformations. C AIND = IWORK(MAPA+1) CS2 = DWORK(PFREE + 1) SN2 = DWORK(PFREE + K + 1) CALL DROT( ILASTM-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS2, SN2 ) DO 430 L = 2, K AIND = IWORK(MAPA+L) IF ( LCMPQ ) THEN QI = IWORK( MAPQ + L ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + L )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS2, $ SN2 ) CS1 = CS2 SN1 = SN2 CS2 = DWORK(PFREE + L) SN2 = DWORK(PFREE + K + L) IF (S(AIND).EQ.SINV) THEN CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1, $ A(J+1,J+2,AIND), LDA1, CS1, SN1 ) CALL DROT( J-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS2, SN2 ) ELSE CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1, $ A(J+1,J+2,AIND), LDA1, CS2, SN2 ) CALL DROT( J-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) END IF 430 CONTINUE IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 1 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 1 )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS2, SN2 ) AIND = IWORK(MAPA+1) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS2, SN2 ) END IF C C 2. Compute complex eigenvalues. C CALL MB03BB( BASE, LGBAS, ULP, K, IWORK(MAPA+1), S, SINV, $ A(J,J,1), LDA1, LDA2, ALPHAR(J), ALPHAI(J), $ BETA(J), SCAL(J), DWORK(PFREE + 1), IERR ) IF ( IERR.EQ.1 ) THEN C C The single shift periodic QZ did not converge, set C IWARN = J to indicate that the eigenvalues are not C assigned. C IWARN = MAX( J, IWARN ) END IF C C Go to next block and reset counters. C ILAST = IFIRST - 1 IF ( ILAST.LT.ILO ) $ GO TO 500 IITER = 0 TITER = 0 IF ( ZITER.NE.-1 ) $ ZITER = 0 IF ( .NOT.LSCHR ) THEN ILASTM = ILAST IF ( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF GO TO 480 END IF C C Now, it is assumed that ILAST-IFIRST+1 >= 3. C Complex double shift. C IF ( MOD( IITER, 30 ).EQ.0 ) THEN C C Exceptional shift. C CALL DLARNV( 3, ISEED, 1, TEMP ) CALL DLARNV( 3, ISEED, 1, TEMP2 ) CALL DLARTG( TEMP, TEMP2, CS1, SN1, TEMP3 ) CALL DLARNV( 3, ISEED, 1, TEMP ) CALL DLARNV( 3, ISEED, 1, TEMP2 ) CALL DLARTG( TEMP, TEMP2, CS2, SN2, TEMP3 ) ELSE CALL MB03AD( 'Double', K, ILAST-IFIRST+1, IWORK( MAPA + 1 ), $ S, SINV, A(IFIRST,IFIRST,1), LDA1, LDA2, CS1, $ SN1, CS2, SN2 ) END IF C C Do the sweeps. C DO 450 J1 = IFIRST - 1, ILAST - 3 J = J1 + 1 AIND = IWORK( MAPA + 1 ) IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 1 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 1 )) ) END IF C C Create a bulge if J1 = IFIRST - 1, otherwise chase the C bulge. C IF ( J1.LT.IFIRST ) THEN CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1, $ A(J+2,J,AIND), LDA1, CS2, SN2 ) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) ELSE TEMP = A(J+1,J-1,AIND) CALL DLARTG( TEMP, A(J+2,J-1,AIND), CS2, SN2, $ TEMP2 ) TEMP = A(J,J-1,AIND) CALL DLARTG( TEMP, TEMP2, CS1, SN1, A(J,J-1,AIND) ) A(J+1,J-1,AIND) = ZERO A(J+2,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1, $ A(J+2,J,AIND), LDA1, CS2, SN2 ) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) END IF IF ( QI.NE.0 ) THEN CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, SN2 ) CALL DROT( N, Q(1,J, QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) END IF C C Propagate information from the right to A_1. C DO 440 L = K, 2, -1 AIND = IWORK( MAPA + L ) IF ( S(AIND).EQ.SINV ) THEN CALL DROT( J+3-IFRSTM, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+2,J+1,AIND), CS2, SN2, $ A(J+1,J+1,AIND) ) A(J+2,J+1,AIND) = ZERO CALL DROT( ILASTM-J-1, A(J+1,J+2,AIND), LDA1, $ A(J+2,J+2,AIND), LDA1, CS2, SN2 ) CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS1, SN1 ) ELSE CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1, $ A(J+2,J,AIND), LDA1, CS2, SN2 ) TEMP = A(J+2,J+2,AIND) CALL DLARTG( TEMP, A(J+2,J+1,AIND), CS2, SN2, $ A(J+2,J+2,AIND) ) A(J+2,J+1,AIND) = ZERO SN2 = -SN2 CALL DROT( J+2-IFRSTM, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO SN1 = -SN1 CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) END IF IF ( LCMPQ ) THEN QI = IWORK( MAPQ + L ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + L )) ) END IF IF ( QI.NE.0 ) THEN CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, $ SN2 ) CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) END IF 440 CONTINUE AIND = IWORK( MAPA + 1 ) LM = MIN( J+3, ILASTM ) - IFRSTM + 1 CALL DROT( LM, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) CALL DROT( LM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) 450 CONTINUE C C To avoid IF statements, there is an extra piece of code for C the last step. C J = ILAST - 1 TEMP = A(J,J-1,AIND) CALL DLARTG( TEMP, A(J+1,J-1,AIND), CS1, SN1, A(J,J-1,AIND) ) A(J+1,J-1,AIND) = ZERO C 460 CONTINUE C CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) IF ( LCMPQ ) THEN QI = IWORK( MAPQ + 1 ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + 1 )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) C C Propagate information from the right to A_1. C DO 470 L = K, 2, -1 AIND = IWORK( MAPA + L ) IF ( S(AIND).EQ.SINV ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS1, SN1 ) ELSE CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO SN1 = -SN1 CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) END IF IF ( LCMPQ ) THEN QI = IWORK( MAPQ + L ) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK( MAPQ + L )) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) 470 CONTINUE AIND = IWORK( MAPA + 1 ) CALL DROT( ILASTM-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) C C End of iteration loop. C 480 CONTINUE 490 CONTINUE C C Drop through = non-convergence. C INFO = ILAST GO TO 520 C C Successful completion of all QZ steps. C 500 CONTINUE C C Set eigenvalues 1:ILO-1. C DO 510 J = 1, ILO - 1 CALL MA01BD( BASE, LGBAS, K, S, A(J,J,1), LDA1*LDA2, ALPHAR(J), $ BETA(J), SCAL(J) ) ALPHAI(J) = ZERO 510 CONTINUE C 520 CONTINUE C DWORK(1) = DBLE( OPTDW ) IWORK(1) = OPTIW RETURN C *** Last line of MB03BD *** END slicot-5.0+20101122/src/MB03BE.f000077500000000000000000000106121201767322700153570ustar00rootroot00000000000000 SUBROUTINE MB03BE( K, AMAP, S, SINV, A, LDA1, LDA2 ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 10 iterations of a real single shifted periodic QZ C algorithm to the 2-by-2 product of matrices stored in the array A. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading 2-by-2-by-K part of this array must C contain a 2-by-2 product (implicitly represented by its K C factors) in upper Hessenberg form. C On exit, the leading 2-by-2-by-K part of this array C contains the product after 10 iterations of a real shifted C periodic QZ algorithm. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= 2. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= 2. C C METHOD C C Ten iterations of a real single shifted periodic QZ algorithm are C applied to the 2-by-2 matrix product A. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLARL2. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER K, LDA1, LDA2, SINV C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. INTEGER I, L, AI DOUBLE PRECISION CS, SN, CT, ST, TEMP C .. External Subroutines .. EXTERNAL DLARTG, DROT, MB03AD C C .. Executable Statements .. C DO 20 I = 1, 10 CALL MB03AD( 'Single', K, 2, AMAP, S, SINV, A, LDA1, LDA2, $ CS, SN, CT, ST ) AI = AMAP(1) CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN ) C DO 10 L = K, 2, -1 AI = AMAP(L) IF ( S(AI).EQ.SINV ) THEN CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN ) TEMP = A(1,1,AI) CALL DLARTG( TEMP, A(2,1,AI), CS, SN, A(1,1,AI) ) A(2,1,AI) = ZERO TEMP = CS*A(1,2,AI) + SN*A(2,2,AI) A(2,2,AI) = CS*A(2,2,AI) - SN*A(1,2,AI) A(1,2,AI) = TEMP ELSE CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN ) TEMP = A(2,2,AI) CALL DLARTG( TEMP, A(2,1,AI), CS, SN, A(2,2,AI) ) A(2,1,AI) = ZERO SN = -SN TEMP = CS*A(1,1,AI) + SN*A(1,2,AI) A(1,2,AI) = CS*A(1,2,AI) - SN*A(1,1,AI) A(1,1,AI) = TEMP END IF 10 CONTINUE C AI = AMAP(1) CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN ) 20 CONTINUE C RETURN C *** Last line of MB03BE *** END slicot-5.0+20101122/src/MB03CD.f000077500000000000000000000515451201767322700153710ustar00rootroot00000000000000 SUBROUTINE MB03CD( UPLO, N1, N2, PREC, A, LDA, B, LDB, D, LDD, Q1, $ LDQ1, Q2, LDQ2, Q3, LDQ3, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 matrices Q1, Q2, Q3 for a real 2-by-2, C 3-by-3, or 4-by-4 regular block upper triangular pencil C C ( A11 A12 ) ( B11 B12 ) ( D11 D12 ) C aAB - bD = a ( ) ( ) - b ( ), (1) C ( 0 A22 ) ( 0 B22 ) ( 0 D22 ) C C such that the pencil a(Q3' A Q2 )(Q2' B Q1 ) - b(Q3' D Q1) is C still in block upper triangular form, but the eigenvalues in C Spec(A11 B11, D11), Spec(A22 B22, D22) are exchanged, where C Spec(X,Y) denotes the spectrum of the matrix pencil (X,Y). C C Optionally, to upper triangularize the real regular pencil in C block lower triangular form C C ( A11 0 ) ( B11 0 ) ( D11 0 ) C aAB - bD = a ( ) ( ) - b ( ), (2) C ( A21 A22 ) ( B21 B22 ) ( D21 D22 ) C C while keeping the eigenvalues in the same diagonal position. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies if the pencil is in lower or upper block C triangular form on entry, as follows: C = 'U': Upper block triangular, eigenvalues are exchanged C on exit; C = 'L': Lower block triangular, eigenvalues are not C exchanged on exit. C C Input/Output Parameters C C N1 (input/output) INTEGER C Size of the upper left block, N1 <= 2. C If UPLO = 'U' and INFO = 0, or UPLO = 'L' and INFO <> 0, C N1 and N2 are exchanged on exit; otherwise, N1 is C unchanged on exit. C C N2 (input/output) INTEGER C Size of the lower right block, N2 <= 2. C If UPLO = 'U' and INFO = 0, or UPLO = 'L' and INFO <> 0, C N1 and N2 are exchanged on exit; otherwise, N2 is C unchanged on exit. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. C C A (input or 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 of the pencil aAB - bD. C The (2,1) block, if UPLO = 'U', or the (1,2) block, if C UPLO = 'L', need not be set to zero. C On exit, if N1 = N2 = 1, this array contains the matrix C [ 0 1 ] C J' A J, where J = [ -1 0 ]; otherwise, this array is C unchanged on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= N1+N2. C C B (input or 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 of the pencil aAB - bD. C The (2,1) block, if UPLO = 'U', or the (1,2) block, if C UPLO = 'L', need not be set to zero. C On exit, if N1 = N2 = 1, this array contains the matrix C J' B J; otherwise, this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= N1+N2. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD, N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix D of the pencil aAB - bD. C On exit, if N1 = 2 or N2 = 2, the leading C (N1+N2)-by-(N1+N2) part of this array contains the C transformed matrix D in real Schur form. If N1 = 1 and C N2 = 1, this array contains the matrix J' D J. C C LDD INTEGER C The leading dimension of the array D. LDD >= N1+N2. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the first orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N1+N2. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the second orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N1+N2. C C Q3 (output) DOUBLE PRECISION array, dimension (LDQ3, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the third orthogonal transformation matrix. C C LDQ3 INTEGER C The leading dimension of the array Q3. LDQ3 >= N1+N2. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N1+N2 = 2 then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N1+N2 = 2, then LDWORK = 0; otherwise, C LDWORK >= 16*N1 + 10*N2 + 23, UPLO = 'U'; C LDWORK >= 10*N1 + 16*N2 + 23, UPLO = 'L'. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the QZ iteration failed in the LAPACK routine DGGEV; C = 2: another error occured while executing a routine in C DGGEV; C = 3: the QZ iteration failed in the LAPACK routine DGGES; C = 4: another error occured during execution of DGGES; C = 5: reordering of aAB - bD in the LAPACK routine DTGSEN C failed because the transformed matrix pencil aAB - bD C would be too far from generalized Schur form; C the problem is very ill-conditioned. C C METHOD C C The algorithm uses orthogonal transformations as described in [2] C (page 21). The QZ algorithm is used for N1 = 2 or N2 = 2, but it C always acts on an upper block triangular pencil. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 21, 2008. C C REVISIONS C C V. Sima, July 2009 (SLICOT version of the routine DBTFEX). C V. Sima, Nov. 2009, Oct. 2010, Nov. 2010. C C KEYWORDS C C Block triangular pencil, eigenvalue exchange. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE, TEN, HUND PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ HUND = 1.0D+2 ) C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, LDD, LDQ1, LDQ2, LDQ3, LDWORK, $ N1, N2 DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ Q3( LDQ3, * ) C C .. Local Scalars .. LOGICAL AEVINF, EVINF, LUPLO INTEGER CNT, EVSEL, I, IAEV, IDUM, IEVS, ITMP, J, M DOUBLE PRECISION ABSAEV, ABSEV, ADIF, CO1, CO2, CO3, E, G, SI1, $ SI2, SI3, TMP, TOL, TOLB C C .. Local Arrays .. LOGICAL BWORK( 1 ), OUT( 2 ), SLCT( 4 ) INTEGER IDM( 1 ) DOUBLE PRECISION DUM( 2 ) C C .. External Functions .. LOGICAL LSAME, SB02OW EXTERNAL LSAME, SB02OW C C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEQR2, DGGES, DGGEV, DLACPY, $ DLARTG, DLASET, DORG2R, DSWAP, DTGSEN C C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C C Decode the input arguments. C LUPLO = LSAME( UPLO, 'U' ) C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C M = N1 + N2 IF( M.GT.2 ) THEN C C Compute A*B, and, if UPLO = 'L', make the pencil upper block C triangular. Array Q2 is used as workspace. C IF( LUPLO ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N1, N1, N1, ONE, $ A, LDA, B, LDB, ZERO, Q2, LDQ2 ) CALL DLASET( 'Full', N2, N1, ZERO, ZERO, Q2( N1+1, 1 ), LDQ2 $ ) CALL DGEMM( 'No Transpose', 'No Transpose', N1, N2, M, ONE, $ A, LDA, B( 1, N1+1 ), LDB, ZERO, Q2( 1, N1+1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, N2, N2, ONE, $ A( N1+1, N1+1 ), LDA, B( N1+1, N1+1 ), LDB, $ ZERO, Q2( N1+1, N1+1 ), LDQ2 ) ELSE C CALL DGEMM( 'No Transpose', 'No Transpose', N2, N2, N2, ONE, $ A( N1+1, N1+1 ), LDA, B( N1+1, N1+1 ), LDB, $ ZERO, Q2, LDQ2 ) CALL DLASET( 'Full', N1, N2, ZERO, ZERO, Q2( N2+1, 1 ), LDQ2 $ ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, M, ONE, $ A( N1+1, 1 ), LDA, B, LDB, ZERO, Q2( 1, N2+1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N1, N1, N1, ONE, $ A, LDA, B, LDB, ZERO, Q2( N2+1, N2+1 ), LDQ2 ) IF( N1.EQ.1 ) THEN DUM( 1 ) = D( 1, 1 ) DUM( 2 ) = D( 2, 1 ) D( 1, 1 ) = D( 2, 2 ) D( 2, 1 ) = D( 3, 2 ) D( 1, 2 ) = D( 2, 3 ) D( 2, 2 ) = D( 3, 3 ) D( 1, 3 ) = DUM( 2 ) D( 2, 3 ) = D( 3, 1 ) D( 3, 3 ) = DUM( 1 ) D( 3, 1 ) = ZERO D( 3, 2 ) = ZERO ELSE IF( N2.EQ.1 ) THEN DUM( 1 ) = D( 3, 2 ) DUM( 2 ) = D( 3, 3 ) D( 2, 3 ) = D( 1, 2 ) D( 3, 3 ) = D( 2, 2 ) D( 2, 2 ) = D( 1, 1 ) D( 3, 2 ) = D( 2, 1 ) D( 1, 1 ) = DUM( 2 ) D( 1, 2 ) = D( 3, 1 ) D( 1, 3 ) = DUM( 1 ) D( 2, 1 ) = ZERO D( 3, 1 ) = ZERO ELSE C DO 10 J = 1, N1 CALL DSWAP( N1, D( 1, J ), 1, D( N1+1, N1+J ), 1 ) CALL DSWAP( N1, D( 1, N1+J ), 1, D( N1+1, J ), 1 ) 10 CONTINUE C END IF ITMP = N1 N1 = N2 N2 = ITMP END IF C C Apply the QZ algorithm and order the eigenvalues in C DWORK(1:3*N1) to the top. C C Workspace: need 11*N1. C Note that N1 and N2 are interchanged for UPLO = 'L'. C IEVS = 3*N1 + 1 IAEV = IEVS + 3*N1 CALL DLACPY( 'Full', M, M, D, LDD, Q1, LDQ1 ) CALL DLACPY( 'Full', M, M, Q2, LDQ2, Q3, LDQ3 ) CALL DGGEV( 'No Vector', 'No Vector', N1, Q1, LDQ1, Q3, LDQ3, $ DWORK, DWORK( N1+1 ), DWORK( 2*N1+1 ), DUM, 1, DUM, $ 1, DWORK( IEVS ), LDWORK-IEVS+1, INFO ) IF( INFO.GE.1 .AND. INFO.LE.N1 ) THEN INFO = 1 RETURN ELSE IF( INFO.GT.N1 ) THEN INFO = 2 RETURN END IF C C Workspace: need 16*N1 + 10*N2 + 23. C Note that N1 and N2 are interchanged for UPLO = 'L'. C ITMP = IAEV + 3*M CALL DCOPY( 3*N1, DWORK, 1, DWORK( IEVS ), 1 ) CALL DGGES( 'Vector Computation', 'Vector Computation', $ 'Not sorted', SB02OW, M, D, LDD, Q2, LDQ2, IDUM, $ DWORK( IAEV ), DWORK( IAEV+M ), DWORK( IAEV+2*M ), $ Q3, LDQ3, Q1, LDQ1, DWORK( ITMP ), LDWORK-ITMP+1, $ BWORK, INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.M ) THEN INFO = 3 RETURN ELSE IF( INFO.NE.M+2 ) THEN INFO = 4 RETURN ELSE INFO = 0 END IF END IF C TOL = PREC TOLB = TEN*PREC EVSEL = 0 DO 20 I = 1, M SLCT( I ) = .TRUE. 20 CONTINUE C C WHILE( EVSEL.EQ.0 ) DO C 30 CONTINUE IF( EVSEL.EQ.0 ) THEN CNT = 0 OUT( 1 ) = .FALSE. OUT( 2 ) = .FALSE. C DO 50 I = IAEV, IAEV + M - 1 AEVINF = ABS( DWORK( 2*M+I ) ).LT.PREC* $ ( ABS( DWORK( I ) ) + ABS( DWORK( M+I ) ) ) DO 40 J = 1, N1 C C Check if an eigenvalue is selected and check if it C is infinite. C EVINF = ABS( DWORK( 2*N1+J ) ).LT.PREC* $ ( ABS( DWORK( J ) ) + ABS( DWORK( N1+J ) ) ) IF( ( .NOT. EVINF .OR. AEVINF ) .AND. $ ( .NOT.AEVINF .OR. EVINF ) .AND. $ .NOT. OUT( J ) ) THEN IF( .NOT.EVINF .OR. .NOT.AEVINF ) THEN ADIF = ABS( DWORK( J )/DWORK( 2*N1+J ) - $ DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) - $ DWORK( M+I )/DWORK( 2*M+I ) ) ABSEV = ABS( DWORK( J )/DWORK( 2*N1+J ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) ) ABSAEV = ABS( DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( M+I )/DWORK( 2*M+I ) ) IF( ADIF.LE.TOL*MAX( TOLB, ABSEV, ABSAEV ) ) $ THEN SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF ELSE SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF END IF 40 CONTINUE 50 CONTINUE C IF( CNT.EQ.N1 ) THEN EVSEL = 1 ELSE C C CNT < N1, too few eigenvalues selected. C TOL = TEN*TOL CALL DCOPY( 3*N1, DWORK( IEVS ), 1, DWORK, 1 ) END IF GO TO 30 END IF C END WHILE 30 C C Workspace: need 7*N1 + 7*N2 + 16. C ITMP = 3*M + 1 CALL DTGSEN( 0, .TRUE., .TRUE., SLCT, M, D, LDD, Q2, LDQ2, $ DWORK, DWORK( M+1 ), DWORK( 2*M+1 ), $ Q3, LDQ3, Q1, LDQ1, IDUM, TMP, TMP, DUM, $ DWORK( ITMP ), LDWORK-ITMP+1, IDM, 1, INFO ) IF( INFO.EQ.1 ) THEN INFO = 5 RETURN END IF C C Interchange N1 and N2. C ITMP = N1 N1 = N2 N2 = ITMP C IF( .NOT.LUPLO ) THEN C C Permute the rows of Q1 and Q3. C IF( N1.EQ.1 ) THEN C DO 60 J = 1, M TMP = Q1( 3, J ) Q1( 3, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 1, J ) Q1( 1, J ) = TMP TMP = Q3( 3, J ) Q3( 3, J ) = Q3( 2, J ) Q3( 2, J ) = Q3( 1, J ) Q3( 1, J ) = TMP 60 CONTINUE C ELSE IF( N2.EQ.1 ) THEN C DO 70 J = 1, M TMP = Q1( 1, J ) Q1( 1, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 3, J ) Q1( 3, J ) = TMP TMP = Q3( 1, J ) Q3( 1, J ) = Q3( 2, J ) Q3( 2, J ) = Q3( 3, J ) Q3( 3, J ) = TMP 70 CONTINUE C ELSE C DO 80 J = 1, M CALL DSWAP( N1, Q1( 1, J ), 1, Q1( N1+1, J ), 1 ) CALL DSWAP( N1, Q3( 1, J ), 1, Q3( N1+1, J ), 1 ) 80 CONTINUE C END IF END IF C C Workspace: need 2*N1 + 2*N2. C IF( LUPLO ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N2, M, M, ONE, $ B, LDB, Q1, LDQ1, ZERO, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N1, M, N1, ONE, $ B( N2+1, N2+1 ), LDB, Q1( N2+1, 1 ), LDQ1, ZERO, $ Q2( N2+1, 1 ), LDQ2 ) ELSE CALL DGEMM( 'No Transpose', 'No Transpose', N1, M, N1, ONE, $ B, LDB, Q1, LDQ1, ZERO, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, M, M, ONE, $ B ( N1+1, 1 ), LDB, Q1, LDQ1, ZERO, $ Q2( N1+1, 1 ), LDQ2 ) END IF CALL DGEQR2( M, M, Q2, LDQ2, DWORK, DWORK( M+1 ), INFO ) CALL DORG2R( M, M, M, Q2, LDQ2, DWORK, DWORK( M+1 ), INFO ) C ELSE C C 2-by-2 case. C IF( .NOT.LUPLO ) THEN TMP = A( 1, 1 ) A( 1, 1 ) = A( 2, 2 ) A( 2, 2 ) = TMP A( 1, 2 ) = -A( 2, 1 ) A( 2, 1 ) = ZERO TMP = B( 1, 1 ) B( 1, 1 ) = B( 2, 2 ) B( 2, 2 ) = TMP B( 1, 2 ) = -B( 2, 1 ) B( 2, 1 ) = ZERO TMP = D( 1, 1 ) D( 1, 1 ) = D( 2, 2 ) D( 2, 2 ) = TMP D( 1, 2 ) = -D( 2, 1 ) D( 2, 1 ) = ZERO END IF C TMP = A( 2, 2 )*B( 2, 2 )*D( 1, 1 ) G = A( 1, 1 )*B( 1, 1 )*D( 2, 2 ) - TMP IF( ABS( G ).LT.HUND*PREC*ABS( TMP ) ) THEN C C The eigenvalues might be too close to interchange them. C IF( LUPLO ) THEN CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q1, LDQ1 ) CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q2, LDQ2 ) CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q3, LDQ3 ) ELSE Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = -ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = -ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = -ONE Q3( 1, 2 ) = ONE Q3( 2, 2 ) = ZERO END IF ELSE E = ( A( 1, 1 )*B( 1, 2 ) + A( 1, 2 )*B( 2, 2 ) )*D( 2, 2 ) $ - A( 2, 2 )*B( 2, 2 )*D( 1, 2 ) CALL DLARTG( E, G, CO1, SI1, TMP ) E = ( A( 1, 2 )*D( 2, 2 ) - A( 2, 2 )*D( 1, 2 ) )*B( 1, 1 ) $ + A( 2, 2 )*D( 1, 1 )*B( 1, 2 ) CALL DLARTG( E, G, CO2, SI2, TMP ) E = ( B( 1, 2 )*D( 1, 1 ) - B( 1, 1 )*D( 1, 2 ) )*A( 1, 1 ) $ + A( 1, 2 )*B( 2, 2 )*D( 1, 1 ) CALL DLARTG( E, G, CO3, SI3, TMP ) C IF( LUPLO ) THEN Q1( 1, 1 ) = CO1 Q1( 2, 1 ) = -SI1 Q1( 1, 2 ) = SI1 Q1( 2, 2 ) = CO1 Q2( 1, 1 ) = CO2 Q2( 2, 1 ) = -SI2 Q2( 1, 2 ) = SI2 Q2( 2, 2 ) = CO2 Q3( 1, 1 ) = CO3 Q3( 2, 1 ) = -SI3 Q3( 1, 2 ) = SI3 Q3( 2, 2 ) = CO3 ELSE Q1( 1, 1 ) = -SI1 Q1( 2, 1 ) = -CO1 Q1( 1, 2 ) = CO1 Q1( 2, 2 ) = -SI1 Q2( 1, 1 ) = -SI2 Q2( 2, 1 ) = -CO2 Q2( 1, 2 ) = CO2 Q2( 2, 2 ) = -SI2 Q3( 1, 1 ) = -SI3 Q3( 2, 1 ) = -CO3 Q3( 1, 2 ) = CO3 Q3( 2, 2 ) = -SI3 END IF END IF END IF C RETURN C *** Last line of MB03CD *** END slicot-5.0+20101122/src/MB03DD.f000077500000000000000000000466201201767322700153700ustar00rootroot00000000000000 SUBROUTINE MB03DD( UPLO, N1, N2, PREC, A, LDA, B, LDB, Q1, LDQ1, $ Q2, LDQ2, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 matrices Q1 and Q2 for a real 2-by-2, C 3-by-3, or 4-by-4 regular block upper triangular pencil C C ( A11 A12 ) ( B11 B12 ) C aA - bB = a ( ) - b ( ), (1) C ( 0 A22 ) ( 0 B22 ) C C such that the pencil a(Q2' A Q1) - b(Q2' B Q1) is still in block C upper triangular form, but the eigenvalues in Spec(A11, B11), C Spec(A22, B22) are exchanged, where Spec(X,Y) denotes the spectrum C of the matrix pencil (X,Y). C C Optionally, to upper triangularize the real regular pencil in C block lower triangular form C C ( A11 0 ) ( B11 0 ) C aA - bB = a ( ) - b ( ), (2) C ( A21 A22 ) ( B21 B22 ) C C while keeping the eigenvalues in the same diagonal position. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies if the pencil is in lower or upper block C triangular form on entry, as follows: C = 'U': Upper block triangular, eigenvalues are exchanged C on exit; C = 'T': Upper block triangular, B triangular, eigenvalues C are exchanged on exit; C = 'L': Lower block triangular, eigenvalues are not C exchanged on exit. C C Input/Output Parameters C C N1 (input/output) INTEGER C Size of the upper left block, N1 <= 2. C If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L' C and INFO <> 0, N1 and N2 are exchanged on exit; otherwise, C N1 is unchanged on exit. C C N2 (input/output) INTEGER C Size of the lower right block, N2 <= 2. C If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L' C and INFO <> 0, N1 and N2 are exchanged on exit; otherwise, C N2 is unchanged on exit. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. 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 of the pencil aA - bB. C On exit, if N1 = N2 = 1, this array is unchanged, if C UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains C [ 0 1 ] C the matrix J' A J, where J = [ -1 0 ]; otherwise, this C array contains the transformed quasi-triangular matrix in C generalized real Schur form. C C LDA INTEGER C The leading dimension of the array A. LDA >= 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 of the pencil aA - bB. C On exit, if N1 = N2 = 1, this array is unchanged, if C UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains C the matrix J' B J; otherwise, this array contains the C transformed upper triangular matrix in generalized real C Schur form. C C LDB INTEGER C The leading dimension of the array B. LDB >= N1+N2. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the first orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N1+N2. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the second orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N1+N2. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N1+N2 = 2 then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N1+N2 = 2, then LDWORK = 0; otherwise, C LDWORK >= 16*N1 + 10*N2 + 23, if UPLO = 'U'; C LDWORK >= 7*N1 + 7*N2 + 16, if UPLO = 'T'; C LDWORK >= 10*N1 + 16*N2 + 23, if UPLO = 'L'. C For good performance LDWORK should be generally larger. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the QZ iteration failed in the LAPACK routine DGGEV; C = 2: another error occured while executing a routine in C DGGEV; C = 3: the QZ iteration failed in the LAPACK routine DGGES C (if UPLO <> 'T') or DHGEQZ (if UPLO = 'T'); C = 4: another error occured during execution of DGGES or C DHGEQZ; C = 5: reordering of aA - bB in the LAPACK routine DTGSEN C failed because the transformed matrix pencil aA - bB C would be too far from generalized Schur form; C the problem is very ill-conditioned. C C METHOD C C The algorithm uses orthogonal transformations as described in [2] C (page 30). The QZ algorithm is used for N1 = 2 or N2 = 2, but it C always acts on an upper block triangular pencil. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C C REVISIONS C C V. Sima, July 2009 (SLICOT version of the routine DBTUEX). C V. Sima, Nov. 2009, Oct. 2010, Nov. 2010. C C KEYWORDS C C Block triangular pencil, eigenvalue exchange. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE, TEN, HUND PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ HUND = 1.0D+2 ) C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, N1, N2 DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ Q1( LDQ1, * ), Q2( LDQ2, * ) C C .. Local Scalars .. LOGICAL AEVINF, EVINF, LTRIU, LUPLO INTEGER CNT, EVSEL, I, IAEV, IDUM, IEVS, ITMP, J, M DOUBLE PRECISION ABSAEV, ABSEV, ADIF, CO1, CO2, E, G, SI1, $ SI2, TMP, TOL, TOLB C C .. Local Arrays .. LOGICAL BWORK( 1 ), OUT( 2 ), SLCT( 4 ) INTEGER IDM( 1 ) DOUBLE PRECISION DUM( 2 ) C C .. External Functions .. LOGICAL LSAME, SB02OW EXTERNAL LSAME, SB02OW C C .. External Subroutines .. EXTERNAL DCOPY, DGGES, DGGEV, DHGEQZ, DLACPY, DLARTG, $ DLASET, DSWAP, DTGSEN C C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C C Decode the input arguments. C LTRIU = LSAME( UPLO, 'T' ) LUPLO = LSAME( UPLO, 'U' ) .OR. LTRIU C C For efficiency, the input arguments are not tested. C INFO = 0 C C 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 M = N1 + N2 IF( M.GT.2 ) THEN IF( .NOT.LUPLO ) THEN C C Make the pencil upper block triangular. C IF( N1.EQ.1 ) THEN DUM( 1 ) = A( 1, 1 ) DUM( 2 ) = A( 2, 1 ) A( 1, 1 ) = A( 2, 2 ) A( 2, 1 ) = A( 3, 2 ) A( 1, 2 ) = A( 2, 3 ) A( 2, 2 ) = A( 3, 3 ) A( 1, 3 ) = DUM( 2 ) A( 2, 3 ) = A( 3, 1 ) A( 3, 3 ) = DUM( 1 ) A( 3, 1 ) = ZERO A( 3, 2 ) = ZERO DUM( 1 ) = B( 1, 1 ) DUM( 2 ) = B( 2, 1 ) B( 1, 1 ) = B( 2, 2 ) B( 2, 1 ) = B( 3, 2 ) B( 1, 2 ) = B( 2, 3 ) B( 2, 2 ) = B( 3, 3 ) B( 1, 3 ) = DUM( 2 ) B( 2, 3 ) = B( 3, 1 ) B( 3, 3 ) = DUM( 1 ) B( 3, 1 ) = ZERO B( 3, 2 ) = ZERO ELSE IF( N2.EQ.1 ) THEN DUM( 1 ) = A( 3, 2 ) DUM( 2 ) = A( 3, 3 ) A( 2, 3 ) = A( 1, 2 ) A( 3, 3 ) = A( 2, 2 ) A( 2, 2 ) = A( 1, 1 ) A( 3, 2 ) = A( 2, 1 ) A( 1, 1 ) = DUM( 2 ) A( 1, 2 ) = A( 3, 1 ) A( 1, 3 ) = DUM( 1 ) A( 2, 1 ) = ZERO A( 3, 1 ) = ZERO DUM( 1 ) = B( 3, 2 ) DUM( 2 ) = B( 3, 3 ) B( 2, 3 ) = B( 1, 2 ) B( 3, 3 ) = B( 2, 2 ) B( 2, 2 ) = B( 1, 1 ) B( 3, 2 ) = B( 2, 1 ) B( 1, 1 ) = DUM( 2 ) B( 1, 2 ) = B( 3, 1 ) B( 1, 3 ) = DUM( 1 ) B( 2, 1 ) = ZERO B( 3, 1 ) = ZERO ELSE C DO 10 J = 1, N1 CALL DSWAP( N1, A( 1, J ), 1, A( N1+1, N1+J ), 1 ) CALL DSWAP( N1, A( 1, N1+J ), 1, A( N1+1, J ), 1 ) CALL DSWAP( N1, B( 1, J ), 1, B( N1+1, N1+J ), 1 ) CALL DSWAP( N1, B( 1, N1+J ), 1, B( N1+1, J ), 1 ) 10 CONTINUE C END IF C ITMP = N1 N1 = N2 N2 = ITMP END IF C C Apply the QZ algorithm and order the eigenvalues in C DWORK(1:3*N1) to the top. C Note that N1 and N2 are interchanged for UPLO = 'L'. C IEVS = 3*N1 + 1 IAEV = IEVS + 3*N1 CALL DLACPY( 'Full', M, M, A, LDA, Q1, LDQ1 ) CALL DLACPY( 'Full', M, M, B, LDB, Q2, LDQ2 ) IF( LTRIU ) THEN C C Workspace: need 4*N1. C CALL DHGEQZ( 'Eigenvalues', 'No Vector', 'No Vector', N1, 1, $ N1, Q1, LDQ1, Q2, LDQ2, DWORK, DWORK( N1+1 ), $ DWORK( 2*N1+1 ), DUM, 1, DUM, 1, DWORK( IEVS ), $ LDWORK-IEVS+1, INFO ) ELSE C C Workspace: need 11*N1; C prefer larger. C CALL DGGEV( 'No Vector', 'No Vector', N1, Q1, LDQ1, Q2, $ LDQ2, DWORK, DWORK( N1+1 ), DWORK( 2*N1+1 ), $ DUM, 1, DUM, 1, DWORK( IEVS ), LDWORK-IEVS+1, $ INFO ) END IF IF( INFO.GE.1 .AND. INFO.LE.N1 ) THEN INFO = 1 RETURN ELSE IF( INFO.GT.N1 ) THEN INFO = 2 RETURN END IF C ITMP = IAEV + 3*M CALL DCOPY( 3*N1, DWORK, 1, DWORK( IEVS ), 1 ) IF( LTRIU ) THEN C C Workspace: need 10*N1 + 4*N2. C CALL DHGEQZ( 'Schur', 'Identity', 'Identity', M, 1, M, A, $ LDA, B, LDB, DWORK( IAEV ), DWORK( IAEV+M ), $ DWORK( IAEV+2*M ), Q2, LDQ2, Q1, LDQ1, $ DWORK( ITMP ), LDWORK-ITMP+1, INFO ) IF( INFO.GE.1 .AND. INFO.LE.M ) THEN INFO = 3 RETURN ELSE IF( INFO.NE.0 ) THEN INFO = 4 RETURN END IF ELSE C C Workspace: need 16*N1 + 10*N2 + 23; C prefer larger. C CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', SB02OW, M, $ A, LDA, B, LDB, IDUM, DWORK( IAEV ), $ DWORK( IAEV+M ), DWORK( IAEV+2*M ), Q2, LDQ2, $ Q1, LDQ1, DWORK( ITMP ), LDWORK-ITMP+1, BWORK, $ INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.M ) THEN INFO = 3 RETURN ELSE IF( INFO.NE.M+2 ) THEN INFO = 4 RETURN ELSE INFO = 0 END IF END IF END IF C TOL = PREC TOLB = TEN*PREC EVSEL = 0 DO 20 I = 1, M SLCT( I ) = .TRUE. 20 CONTINUE C C WHILE( EVSEL.EQ.0 ) DO C 30 CONTINUE IF( EVSEL.EQ.0 ) THEN CNT = 0 OUT( 1 ) = .FALSE. OUT( 2 ) = .FALSE. C DO 50 I = IAEV, IAEV + M - 1 AEVINF = ABS( DWORK( 2*M+I ) ).LT.PREC* $ ( ABS( DWORK( I ) ) + ABS( DWORK( M+I ) ) ) DO 40 J = 1, N1 C C Check if an eigenvalue is selected and check if it C is infinite. C EVINF = ABS( DWORK( 2*N1+J ) ).LT.PREC* $ ( ABS( DWORK( J ) ) + ABS( DWORK( N1+J ) ) ) IF( ( .NOT. EVINF .OR. AEVINF ) .AND. $ ( .NOT.AEVINF .OR. EVINF ) .AND. $ .NOT. OUT( J ) ) THEN IF( .NOT.EVINF .OR. .NOT.AEVINF ) THEN ADIF = ABS( DWORK( J )/DWORK( 2*N1+J ) - $ DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) - $ DWORK( M+I )/DWORK( 2*M+I ) ) ABSEV = ABS( DWORK( J )/DWORK( 2*N1+J ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) ) ABSAEV = ABS( DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( M+I )/DWORK( 2*M+I ) ) IF( ADIF.LE.TOL*MAX( TOLB, ABSEV, ABSAEV ) ) $ THEN SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF ELSE SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF END IF 40 CONTINUE 50 CONTINUE C IF( CNT.EQ.N1 ) THEN EVSEL = 1 ELSE C C CNT < N1, too few eigenvalues selected. C TOL = TEN*TOL CALL DCOPY( 3*N1, DWORK( IEVS ), 1, DWORK, 1 ) END IF GO TO 30 END IF C END WHILE 30 C C Workspace: need 7*N1 + 7*N2 + 16; C prefer larger. C ITMP = 3*M + 1 CALL DTGSEN( 0, .TRUE., .TRUE., SLCT, M, A, LDA, B, LDB, DWORK, $ DWORK( M+1 ), DWORK( 2*M+1 ), Q2, LDQ2, Q1, LDQ1, $ IDUM, TMP, TMP, DUM, DWORK( ITMP ), LDWORK-ITMP+1, $ IDM, 1, INFO ) IF( INFO.EQ.1 ) THEN INFO = 5 RETURN END IF C C Interchange N1 and N2. C ITMP = N1 N1 = N2 N2 = ITMP C IF( .NOT.LUPLO ) THEN C C Permute the rows of Q1 and Q2. C IF( N1.EQ.1 ) THEN C DO 60 J = 1, M TMP = Q1( 3, J ) Q1( 3, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 1, J ) Q1( 1, J ) = TMP TMP = Q2( 3, J ) Q2( 3, J ) = Q2( 2, J ) Q2( 2, J ) = Q2( 1, J ) Q2( 1, J ) = TMP 60 CONTINUE C ELSE IF( N2.EQ.1 ) THEN C DO 70 J = 1, M TMP = Q1( 1, J ) Q1( 1, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 3, J ) Q1( 3, J ) = TMP TMP = Q2( 1, J ) Q2( 1, J ) = Q2( 2, J ) Q2( 2, J ) = Q2( 3, J ) Q2( 3, J ) = TMP 70 CONTINUE C ELSE C DO 80 J = 1, M CALL DSWAP( N1, Q1( 1, J ), 1, Q1( N1+1, J ), 1 ) CALL DSWAP( N1, Q2( 1, J ), 1, Q2( N1+1, J ), 1 ) 80 CONTINUE C END IF END IF ELSE C C 2-by-2 case. C IF( .NOT.LUPLO ) THEN TMP = A( 1, 1 ) A( 1, 1 ) = A( 2, 2 ) A( 2, 2 ) = TMP A( 1, 2 ) = -A( 2, 1 ) A( 2, 1 ) = ZERO TMP = B( 1, 1 ) B( 1, 1 ) = B( 2, 2 ) B( 2, 2 ) = TMP B( 1, 2 ) = -B( 2, 1 ) B( 2, 1 ) = ZERO END IF C G = A( 1, 1 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 1 ) IF( ABS( G ).LT.HUND*PREC*ABS( A( 1, 1 )*B( 2, 2 ) ) ) THEN C C The eigenvalues might be too close to interchange them. C IF( LUPLO ) THEN CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q1, LDQ1 ) CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q2, LDQ2 ) ELSE Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = -ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = -ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO END IF ELSE E = A( 1, 2 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 2 ) CALL DLARTG( E, G, CO1, SI1, TMP ) E = A( 1, 2 )*B( 1, 1 ) - A( 1, 1 )*B( 1, 2 ) CALL DLARTG( E, G, CO2, SI2, TMP ) C IF( LUPLO ) THEN Q1( 1, 1 ) = CO1 Q1( 2, 1 ) = -SI1 Q1( 1, 2 ) = SI1 Q1( 2, 2 ) = CO1 Q2( 1, 1 ) = CO2 Q2( 2, 1 ) = -SI2 Q2( 1, 2 ) = SI2 Q2( 2, 2 ) = CO2 ELSE Q1( 1, 1 ) = -SI1 Q1( 2, 1 ) = -CO1 Q1( 1, 2 ) = CO1 Q1( 2, 2 ) = -SI1 Q2( 1, 1 ) = -SI2 Q2( 2, 1 ) = -CO2 Q2( 1, 2 ) = CO2 Q2( 2, 2 ) = -SI2 END IF END IF END IF C RETURN C *** Last line of MB03DD *** END slicot-5.0+20101122/src/MB03ED.f000077500000000000000000000316201201767322700153630ustar00rootroot00000000000000 SUBROUTINE MB03ED( N, PREC, A, LDA, B, LDB, D, LDD, Q1, LDQ1, Q2, $ LDQ2, Q3, LDQ3, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 matrices Q1, Q2, Q3 for a real 2-by-2 or C 4-by-4 regular pencil C C ( A11 0 ) ( B11 0 ) ( 0 D12 ) C aAB - bD = a ( ) ( ) - b ( ), (1) C ( 0 A22 ) ( 0 B22 ) ( D21 0 ) C C such that Q3' A Q2 and Q2' B Q1 are upper triangular, Q3' D Q1 is C upper quasi-triangular, and the eigenvalues with negative real C parts (if there are any) are allocated on the top. The submatrices C A11, A22, B11, B22 and D12 are upper triangular. If D21 is 2-by-2, C then all other blocks are nonsingular and the product C C -1 -1 -1 -1 C A22 D21 B11 A11 D12 B22 has a pair of complex conjugate C eigenvalues. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the input pencil, N = 2 or N = 4. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. C C A (input) DOUBLE PRECISION array, dimension (LDA, N) C The leading N-by-N upper triangular part of this array C must contain the upper triangular matrix A of the pencil C aAB - bD. The strictly lower triangular part and the C entries of the (1,2) block are not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= N. C C B (input) DOUBLE PRECISION array, dimension (LDB, N) C The leading N-by-N upper triangular part of this array C must contain the upper triangular matrix B of the pencil C aAB - bD. The strictly lower triangular part and the C entries of the (1,2) block are not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C D (input/output) DOUBLE PRECISION array, dimension (LDD, N) C On entry, the leading N-by-N part of this array must C contain the matrix D of the pencil aAB - bD. C On exit, if N = 4, the leading N-by-N part of this array C contains the transformed matrix D in real Schur form. C If N = 2, this array is unchanged on exit. C C LDD INTEGER C The leading dimension of the array D. LDD >= N. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N) C The leading N-by-N part of this array contains the first C orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C The leading N-by-N part of this array contains the second C orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N. C C Q3 (output) DOUBLE PRECISION array, dimension (LDQ3, N) C The leading N-by-N part of this array contains the third C orthogonal transformation matrix. C C LDQ3 INTEGER C The leading dimension of the array Q3. LDQ3 >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N = 2, then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N = 4, then LDWORK >= 79. For good performance LDWORK C should be generally larger. C If N = 2, then LDWORK >= 0. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the QZ iteration failed in the LAPACK routine DGGES; C = 2: another error occured during execution of DGGES. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 20 in [2]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 22, 2008. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine DBTFSX). C V. Sima, Oct. 2009, Nov. 2009, Oct. 2010, Nov. 2010. C C KEYWORDS C C Eigenvalue exchange, matrix pencil, upper (quasi-)triangular C matrix. 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, LDD, LDQ1, LDQ2, LDQ3, LDWORK, $ N DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ Q3( LDQ3, * ) C C .. Local Scalars .. LOGICAL COMPG INTEGER IDUM, IEVS, IWRK DOUBLE PRECISION A11, A22, B11, B22, CO, D12, D21, SI, TMP C C .. Local Arrays .. LOGICAL BWORK( 4 ) DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL SB02OW EXTERNAL SB02OW C C .. External Subroutines .. EXTERNAL DCOPY, DGEQR2, DGGES, DLACPY, DLARTG, DORG2R, $ DTRMM C C .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C IF( N.EQ.4 ) THEN DUM( 1 ) = ZERO CALL DCOPY( 16, DUM, 0, DWORK, 1 ) DWORK( 1 ) = B( 1, 1 ) DWORK( 5 ) = B( 1, 2 ) DWORK( 6 ) = B( 2, 2 ) DWORK( 11 ) = B( 3, 3 ) DWORK( 15 ) = B( 3, 4 ) DWORK( 16 ) = B( 4, 4 ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4, $ ONE, A, LDA, DWORK, N ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 2, $ ONE, A( 3, 3 ), LDA, DWORK( 11 ), N ) IEVS = N*N + 1 IWRK = IEVS + 3*N CALL DGGES( 'Vector Computation', 'Vector Computation', $ 'Sorted', SB02OW, N, D, LDD, DWORK, N, IDUM, $ DWORK( IEVS ), DWORK( IEVS+N ), DWORK( IEVS+2*N ), $ Q3, LDQ3, Q1, LDQ1, DWORK( IWRK ), LDWORK-IWRK+1, $ BWORK, INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.4 ) THEN INFO = 1 RETURN ELSE IF ( INFO.NE.6 ) THEN INFO = 2 RETURN ELSE INFO = 0 END IF END IF CALL DLACPY( 'Full', N, N, Q1, LDQ1, Q2, LDQ2 ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4, $ ONE, B, LDB, Q2, LDQ2 ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4, $ ONE, B( 3, 3 ), LDB, Q2( 3, 1 ), LDQ2 ) CALL DGEQR2( N, N, Q2, LDQ2, DWORK, DWORK( N+1 ), INFO ) CALL DORG2R( N, N, N, Q2, LDQ2, DWORK, DWORK( N+1 ), INFO ) ELSE C C The pencil has infinite eigenvalues. The code decides this when C A or B is (numerically) singular. Although the numerical C singularity of A*B with respect to PREC is detected, the C eigenvalues will not be infinite, but large, when neither A C nor B is (numerically) singular. This allows a more accurate C computation of the transformed A and B (using Q1, Q2, and Q3), C as well as of the eigenvalues. C A11 = ABS( A( 1, 1 ) ) A22 = ABS( A( 2, 2 ) ) B11 = ABS( B( 1, 1 ) ) B22 = ABS( B( 2, 2 ) ) D21 = ABS( D( 2, 1 ) ) D12 = ABS( D( 1, 2 ) ) COMPG = .FALSE. IF( A11*B11.LE.PREC*A22*B22 ) THEN IF( A11.LE.PREC*A22 ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = -ONE Q3( 1, 2 ) = -ONE Q3( 2, 2 ) = ZERO ELSE IF( B11.LE.PREC*B22 ) THEN Q1( 1, 1 ) = -ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = -ONE Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = ONE Q3( 1, 2 ) = ONE Q3( 2, 2 ) = ZERO ELSE COMPG = .TRUE. END IF ELSE IF( A22*B22.LE.PREC*A11*B11 ) THEN IF( A22.LE.PREC*A11 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = -ONE Q3( 2, 1 ) = ZERO Q3( 1, 2 ) = ZERO Q3( 2, 2 ) = -ONE ELSE IF( B22.LE.PREC*B11 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = -ONE Q1( 1, 2 ) = -ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE Q3( 1, 1 ) = ONE Q3( 2, 1 ) = ZERO Q3( 1, 2 ) = ZERO Q3( 2, 2 ) = ONE ELSE COMPG = .TRUE. END IF C C The pencil has a double zero eigenvalue. C ELSE IF( D21.LE.PREC*D12 ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE Q3( 1, 1 ) = ONE Q3( 2, 1 ) = ZERO Q3( 1, 2 ) = ZERO Q3( 2, 2 ) = ONE ELSE IF( D12.LE.PREC*D21 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = ONE Q3( 1, 2 ) = ONE Q3( 2, 2 ) = ZERO ELSE COMPG = .TRUE. END IF C IF( COMPG ) THEN C C The pencil has real eigenvalues. C CALL DLARTG( SIGN( ONE, A( 1, 1 )*B( 1, 1 )*A( 2, 2 )* $ B( 2, 2 ) )*SQRT( A22*B22*D12 ), $ SQRT( A11*B11*D21 ), CO, SI, TMP ) Q1( 1, 1 ) = CO Q1( 2, 1 ) = -SI Q1( 1, 2 ) = SI Q1( 2, 2 ) = CO CALL DLARTG( SIGN( ONE, A( 1, 1 )*A( 2, 2 ) )* $ SQRT( A22*B11*D12 ), SQRT( A11*B22*D21 ), CO, $ SI, TMP ) Q2( 1, 1 ) = CO Q2( 2, 1 ) = -SI Q2( 1, 2 ) = SI Q2( 2, 2 ) = CO CALL DLARTG( SQRT( A11*B11*D12 ), SQRT( A22*B22*D21 ), CO, $ SI, TMP ) Q3( 1, 1 ) = CO Q3( 2, 1 ) = -SI Q3( 1, 2 ) = SI Q3( 2, 2 ) = CO END IF END IF C RETURN C *** Last line of MB03ED *** END slicot-5.0+20101122/src/MB03FD.f000077500000000000000000000217311201767322700153660ustar00rootroot00000000000000 SUBROUTINE MB03FD( N, PREC, A, LDA, B, LDB, Q1, LDQ1, Q2, LDQ2, $ DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 matrices Q1 and Q2 for a real 2-by-2 or C 4-by-4 regular pencil C C ( A11 0 ) ( 0 B12 ) C aA - bB = a ( ) - b ( ), (1) C ( 0 A22 ) ( B21 0 ) C C such that Q2' A Q1 is upper triangular, Q2' B Q1 is upper quasi- C triangular, and the eigenvalues with negative real parts (if there C are any) are allocated on the top. The submatrices A11, A22, and C B12 are upper triangular. If B21 is 2-by-2, then all the other C blocks are nonsingular and the product C C -1 -1 C A11 B12 A22 B21 has a pair of complex conjugate eigenvalues. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the input pencil, N = 2 or N = 4. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. C C A (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 pencil aA - bB. C If N = 2, the diagonal elements only are referenced. C On exit, if N = 4, the leading N-by-N part of this array C contains the transformed upper triangular matrix of the C generalized real Schur form of the pencil aA - bB. C If N = 2, this array is unchanged on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= 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 of the pencil aA - bB. C If N = 2, the anti-diagonal elements only are referenced. C On exit, if N = 4, the leading N-by-N part of this array C contains the transformed real Schur matrix of the C generalized real Schur form of the pencil aA - bB. C If N = 2, this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N) C The leading N-by-N part of this array contains the first C orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C The leading N-by-N part of this array contains the second C orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N = 2, then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N = 4, then LDWORK >= 63. For good performance LDWORK C should be generally larger. C If N = 2, then LDWORK >= 0. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the QZ iteration failed in the LAPACK routine DGGES; C = 2: another error occured during execution of DGGES. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 29 in [2]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine MB03FD). C V. Sima, Oct. 2009, Nov. 2009, Oct. 2010, Nov. 2010. C C KEYWORDS C C Eigenvalue exchange, matrix pencil, upper (quasi-)triangular C matrix. 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, LDQ1, LDQ2, LDWORK, N DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ Q1( LDQ1, * ), Q2( LDQ2, * ) C C .. Local Scalars .. LOGICAL COMPG INTEGER IDUM DOUBLE PRECISION A11, A22, B12, B21, CO, SI, TMP C C .. Local Arrays .. LOGICAL BWORK( 4 ) C C .. External Functions .. LOGICAL SB02OW EXTERNAL SB02OW C C .. External Subroutines .. EXTERNAL DGGES, DLARTG C C .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C IF( N.EQ.4 ) THEN CALL DGGES( 'Vector Computation', 'Vector Computation', $ 'Sorted', SB02OW, N, B, LDB, A, LDA, IDUM, DWORK, $ DWORK( N+1 ), DWORK( 2*N+1 ), Q2, LDQ2, Q1, LDQ1, $ DWORK( 3*N+1 ), LDWORK-3*N, BWORK, INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.4 ) THEN INFO = 1 ELSE IF ( INFO.NE.6 ) THEN INFO = 2 ELSE INFO = 0 END IF END IF RETURN ELSE C C The pencil has infinite eigenvalues. The code decides this when C A is (numerically) singular. C A11 = ABS( A( 1, 1 ) ) A22 = ABS( A( 2, 2 ) ) B21 = ABS( B( 2, 1 ) ) B12 = ABS( B( 1, 2 ) ) COMPG = .FALSE. IF( A11.LE.PREC*A22 ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO ELSE IF( A22.LE.PREC*A11 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE ELSE COMPG = .TRUE. END IF IF( COMPG ) THEN C C The pencil has a double zero eigenvalue. C IF( B21.LE.PREC*B12 ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE ELSE IF( B12.LE.PREC*B21 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO ELSE COMPG = .TRUE. END IF END IF IF( COMPG ) THEN C C The pencil has real eigenvalues. C CALL DLARTG( SIGN( ONE, A( 1, 1 )*A( 2, 2 ) )* $ SQRT( A22*B12 ), SQRT( A11*B21 ), CO, SI, TMP ) Q1( 1, 1 ) = CO Q1( 2, 1 ) = -SI Q1( 1, 2 ) = SI Q1( 2, 2 ) = CO CALL DLARTG( SQRT( A11*B12 ), SQRT( A22*B21 ), CO, SI, TMP ) Q2( 1, 1 ) = CO Q2( 2, 1 ) = -SI Q2( 1, 2 ) = SI Q2( 2, 2 ) = CO END IF END IF C RETURN C *** Last line of MB03FD *** END slicot-5.0+20101122/src/MB03GD.f000077500000000000000000000275111201767322700153710ustar00rootroot00000000000000 SUBROUTINE MB03GD( N, B, LDB, D, LDD, MACPAR, Q, LDQ, U, LDU, $ DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 orthogonal matrix Q and an orthogonal symplectic C matrix U for a real regular 2-by-2 or 4-by-4 skew-Hamiltonian/ C Hamiltonian pencil a J B' J' B - b D with C C ( B11 B12 ) ( D11 D12 ) C B = ( ), D = ( ), C ( 0 B22 ) ( 0 -D11' ) C C such that J Q' J' D Q and U' B Q keep block triangular form, but C the eigenvalues are reordered. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil a J B' J' B - b D. N = 2 or N = 4. C C B (input) DOUBLE PRECISION array, dimension (LDB, N) C The leading N-by-N part of this array must contain the C non-trivial factor of the decomposition of the C skew-Hamiltonian input matrix J B' J' B. The (2,1) block C is not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C D (input) DOUBLE PRECISION array, dimension (LDD, N) C The leading N/2-by-N part of this array must contain the C first block row of the second matrix of a J B' J' B - b D. C The matrix D has to be Hamiltonian. The strict lower C triangle of the (1,2) block is not referenced. C C LDD INTEGER C The leading dimension of the array D. LDD >= N/2. C C MACPAR (input) DOUBLE PRECISION array, dimension (2) C Machine parameters: C MACPAR(1) (machine precision)*base, DLAMCH( 'P' ); C MACPAR(2) safe minimum, DLAMCH( 'S' ). C This argument is not used for N = 2. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, N) C The leading N-by-N part of this array contains the C orthogonal transformation matrix Q. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= N. C C U (output) DOUBLE PRECISION array, dimension (LDU, N) C The leading N-by-N part of this array contains the C orthogonal symplectic transformation matrix U. C C LDU INTEGER C The leading dimension of the array U. LDU >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N = 2 then DWORK is not referenced. C C LDWORK INTEGER C The length of the array DWORK. C If N = 2 then LDWORK >= 0; if N = 4 then LDWORK >= 12. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: B11 or B22 is a (numerically) singular matrix. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 22 in [1], but with an improved implementation. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 29, 2008. C V. Sima, Aug. 2009 (SLICOT version of the routine DHAFEX). C C REVISIONS C C V. Sima, Nov. 2009, July 2010, Nov. 2010. C C KEYWORDS C C Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, C structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. INTEGER INFO, LDB, LDD, LDQ, LDU, LDWORK, N C C .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( LDD, * ), DWORK( * ), $ MACPAR( * ), Q( LDQ, * ), U( LDU, * ) C C .. Local Scalars .. INTEGER I, ICS, IR, ITAU, IWRK1, IWRK2 DOUBLE PRECISION CL1, CL2, CO, CO2, CR1, CR2, EPS, F, F1, G, G1, $ R, R1, S, SFMIN, SI, SI2, SL1, SL2, SMAX1, $ SMAX2, SMIN1, SMIN2, SR1, SR2, T, T1 C C .. External Subroutines .. EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASV2, $ DORGR2, DORM2R, DSWAP, DSYR2K, MB01RU, MB04SU, $ MB04WU C C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C IF( N.EQ.4 ) THEN C C Set machine constants. C EPS = MACPAR( 1 ) SFMIN = MACPAR( 2 ) C C Compute the first two columns of H = inv( B' )*J'*D*inv( B )*J C in U, using the singular value decompositions of B11 and B22. C CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CO, SI, R ) F = CO*B( 1, 2 ) + SI*B( 2, 2 ) G = CO*B( 2, 2 ) - SI*B( 1, 2 ) CALL DLASV2( R, F, G, SMIN1, SMAX1, SR1, CR1, SL1, CL1 ) IF( ABS( SMIN1 ).LT.MAX( SFMIN, EPS*ABS( SMAX1 ) ) ) THEN INFO = 1 RETURN END IF C CALL DLARTG( B( 3, 3 ), B( 4, 3 ), CO2, SI2, R ) F = CO2*B( 3, 4 ) + SI2*B( 4, 4 ) G = CO2*B( 4, 4 ) - SI2*B( 3, 4 ) CALL DLASV2( R, F, G, SMIN2, SMAX2, SR2, CR2, SL2, CL2 ) IF( ABS( SMIN2 ).LT.MAX( SFMIN, EPS*ABS( SMAX2 ) ) ) THEN INFO = 1 RETURN END IF C C Compute inv( B11' )*D11' and copy it in U12. C R = ( CR1*D( 1, 1 ) + SR1*D( 1, 2 ) )/SMAX1 F = ( CR1*D( 2, 1 ) + SR1*D( 2, 2 ) )/SMAX1 T = ( CR1*D( 1, 2 ) - SR1*D( 1, 1 ) )/SMIN1 G = ( CR1*D( 2, 2 ) - SR1*D( 2, 1 ) )/SMIN1 C R1 = CL1*R - SL1*T F1 = CL1*F - SL1*G T1 = CL1*T + SL1*R G1 = CL1*G + SL1*F C U( 1, 3 ) = CO*R1 - SI*T1 U( 2, 3 ) = CO*T1 + SI*R1 U( 1, 4 ) = CO*F1 - SI*G1 U( 2, 4 ) = CO*G1 + SI*F1 C C Compute D11*inv( B11 )*B12 + B12'*inv( B11' )*D11' - D12 in Q. C Q( 1, 1 ) = D( 1, 3 ) Q( 1, 2 ) = D( 1, 4 ) Q( 2, 2 ) = D( 2, 4 ) C CALL DSYR2K( 'Upper', 'Transpose', 2, 2, ONE, U( 1, 3 ), LDU, $ B( 1, 3 ), LDB, -ONE, Q, LDQ ) C C Compute inv( B22 ) in U22. C R = CR2/SMAX2 T = SR2/SMAX2 F = -SR2/SMIN2 G = CR2/SMIN2 C R1 = CL2*R - SL2*F T1 = CL2*T - SL2*G F1 = CL2*F + SL2*R G1 = CL2*G + SL2*T C U( 3, 3 ) = CO2*R1 - SI2*F1 U( 4, 3 ) = CO2*T1 - SI2*G1 U( 3, 4 ) = CO2*F1 + SI2*R1 U( 4, 4 ) = CO2*G1 + SI2*T1 C C Compute H11 = -inv( B11' )*D11'*inv( B22 ) in U11. C CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 2, -ONE, $ U( 1, 3 ), LDU, U( 3, 3 ), LDU, ZERO, U, LDU ) C C Compute H21 = inv( B22' )*Q*inv( B22 ) in U21. C CALL MB01RU( 'Upper', 'Transpose', 2, 2, ZERO, ONE, U( 3, 1 ), $ LDU, U( 3, 3 ), LDU, Q, LDQ, DWORK, 4, INFO ) U( 4, 1 ) = U( 3, 2 ) C S = -( U( 1, 1 ) + U( 2, 2 ) ) C C Compute Y1, the first two columns of Y = H*H - s*H + t*I4, C where H = ( Hij ), i,j = 1,2, H12 = 0, t = det(H22). C H is real lower Hamiltonian block triangular with the C desired eigenvalues in the leading positions. C T = U( 1, 1 )*U( 2, 2 ) - U( 2, 1 )*U( 1, 2 ) C CALL DLACPY( 'Full', 4, 2, U, LDU, Q, LDQ ) Q( 1, 3 ) = U( 1, 1 ) - S Q( 2, 3 ) = U( 2, 1 ) Q( 3, 3 ) = U( 1, 1 ) Q( 4, 3 ) = U( 2, 1 ) Q( 1, 4 ) = U( 1, 2 ) Q( 2, 4 ) = U( 2, 2 ) - S Q( 3, 4 ) = U( 1, 2 ) Q( 4, 4 ) = U( 2, 2 ) CALL DGEMM( 'No Transpose', 'No Transpose', 4, 2, 2, ONE, $ Q, LDQ, Q( 1, 3 ), LDQ, ZERO, U, LDU ) CALL DGEMM( 'Transpose', 'No Transpose', 2, 2, 2, -ONE, $ Q( 3, 3 ), LDQ, Q( 3, 1 ), LDQ, ONE, U( 3, 1 ), $ LDU ) U( 1, 1 ) = U( 1, 1 ) + T U( 2, 2 ) = U( 2, 2 ) + T C C Compute the relevant part of the orthogonal symplectic C matrix U performing the symplectic QR factorization of Y1. C Workspace: need 10. C ICS = 1 ITAU = ICS + 4 IWRK2 = ITAU + 2 CALL MB04SU( 2, 2, U( 1, 1 ), LDU, U( 3, 1 ), LDU, $ DWORK( ICS ), DWORK( ITAU ), DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL MB04WU( 'No Transpose', 'No Transpose', 2, 2, 2, $ U( 1, 1 ), LDU, U( 3, 1 ), LDU, DWORK( ICS ), $ DWORK( ITAU ), DWORK( IWRK2 ), LDWORK-IWRK2+1, $ INFO ) C C Compute J*U in U. C U( 1, 3 ) = U( 1, 1 ) U( 2, 3 ) = U( 2, 1 ) U( 1, 4 ) = U( 1, 2 ) U( 2, 4 ) = U( 2, 2 ) C U( 1, 1 ) = -U( 3, 1 ) U( 2, 1 ) = -U( 4, 1 ) U( 1, 2 ) = -U( 3, 2 ) U( 2, 2 ) = -U( 4, 2 ) C U( 3, 1 ) = -U( 1, 3 ) U( 4, 1 ) = -U( 2, 3 ) U( 3, 2 ) = -U( 1, 4 ) U( 4, 2 ) = -U( 2, 4 ) C U( 3, 3 ) = U( 1, 1 ) U( 4, 3 ) = U( 2, 1 ) U( 3, 4 ) = U( 1, 2 ) U( 4, 4 ) = U( 2, 2 ) C C Compute U'*B using structure. C CALL DGEMM( 'Transpose', 'No Transpose', 4, 2, 2, ONE, U, $ LDU, B, LDB, ZERO, Q, LDQ ) CALL DGEMM( 'Transpose', 'No Transpose', 4, 2, 4, ONE, U, $ LDU, B( 1, 3 ), LDB, ZERO, Q( 1, 3 ), LDQ ) C C Determine Q using different elimination orders in the RQ and C QR factorizations of U'*B. C Workspace: need 12. C ITAU = 1 IWRK1 = ITAU + N CALL DGERQ2( N, N, Q, LDQ, DWORK( ITAU ), DWORK( IWRK1 ), $ INFO ) IR = IWRK1 IWRK2 = IR + 4 DWORK( IR ) = Q( 3, 3 ) DWORK( IR+1 ) = Q( 3, 4 ) DWORK( IR+2 ) = ZERO DWORK( IR+3 ) = Q( 4, 4 ) CALL DORGR2( N, N, N, Q, LDQ, DWORK( ITAU ), DWORK( IWRK2 ), $ INFO ) C DO 20 I = 2, N CALL DSWAP( N-I+1, Q( I, I-1 ), 1, Q( I-1, I ), LDQ ) 20 CONTINUE C CALL DGEQR2( 2, 2, DWORK( IR ), 2, DWORK( ITAU ), $ DWORK( IWRK2 ), INFO ) CALL DORM2R( 'Right', 'No Transpose', N, 2, 2, DWORK( IR ), 2, $ DWORK( ITAU ), Q( 1, 3 ), LDQ, DWORK( IWRK2 ), $ INFO ) ELSE C G = TWO*B( 1, 1 )*B( 2, 2 )*D( 1, 1 ) CALL DLARTG( B( 1, 1 )*B( 2, 2 )*D( 1, 2 ), G, CO, SI, R ) Q( 1, 1 ) = CO Q( 2, 1 ) = -SI Q( 1, 2 ) = SI Q( 2, 2 ) = CO CALL DLARTG( B( 1, 1 )*Q( 1, 1 ) + B( 1, 2 )*Q( 2, 1 ), $ B( 2, 2 )*Q( 2, 1 ), CO, SI, R ) U( 1, 1 ) = CO U( 2, 1 ) = SI U( 1, 2 ) = -SI U( 2, 2 ) = CO END IF C RETURN C *** Last line of MB03GD *** END slicot-5.0+20101122/src/MB03HD.f000077500000000000000000000230671201767322700153740ustar00rootroot00000000000000 SUBROUTINE MB03HD( N, A, LDA, B, LDB, MACPAR, Q, LDQ, DWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 an orthogonal matrix Q, for a real regular 2-by-2 or C 4-by-4 skew-Hamiltonian/Hamiltonian pencil C C ( A11 A12 ) ( B11 B12 ) C aA - bB = a ( T ) - b ( T ) C ( 0 A11 ) ( 0 -B11 ) C C T T C in structured Schur form, such that J Q J (aA - bB) Q is still C in structured Schur form but the eigenvalues are exchanged. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aA - bB. N = 2 or N = 4. C C A (input) DOUBLE PRECISION array, dimension (LDA, N) C If N = 4, the leading N/2-by-N upper trapezoidal part of C this array must contain the first block row of the skew- C Hamiltonian matrix A of the pencil aA - bB in structured C Schur form. Only the entries (1,1), (1,2), (1,4), and C (2,2) are referenced. C If N = 2, this array is not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= N/2. C C B (input) DOUBLE PRECISION array, dimension (LDB, N) C The leading N/2-by-N part of this array must contain the C first block row of the Hamiltonian matrix B of the C pencil aA - bB in structured Schur form. The entry (2,3) C is not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= N/2. C C MACPAR (input) DOUBLE PRECISION array, dimension (2) C Machine parameters: C MACPAR(1) (machine precision)*base, DLAMCH( 'P' ); C MACPAR(2) safe minimum, DLAMCH( 'S' ). C This argument is not used for N = 2. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, N) C The leading N-by-N part of this array contains the C orthogonal transformation matrix Q. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (24) C If N = 2, then DWORK is not referenced. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the leading N/2-by-N/2 block of the matrix B is C numerically singular. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 31 in [2]. The structure is exploited. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C V. Sima, Sep. 2009 (SLICOT version of the routine DHAUEX). C C REVISIONS C C V. Sima, Nov. 2009, Nov. 2010. C C KEYWORDS C C Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, C structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDQ, N C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ MACPAR( * ), Q( LDQ, * ) C C .. Local Scalars .. INTEGER ITAU, IWRK DOUBLE PRECISION CO, D, NRM, S, SI, SMIN, SMLN, T C C .. Local Arrays .. DOUBLE PRECISION PAR( 3 ) C C .. External Subroutines .. EXTERNAL DGEMM, DGEQR2, DLACPY, DLARTG, DLASCL, DORG2R, $ DROT, MB02UW C C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C IF( N.EQ.4 ) THEN C C Set machine constants. C PAR( 1 ) = MACPAR( 1 ) PAR( 2 ) = MACPAR( 2 ) C C Compute si*inv(B11)*[ A11 A12 B12 ], using blocks of A and B. C X11 = si*inv(B11)*A11. C Also, set SMIN to avoid overflows in matrix multiplications. C DWORK( 1 ) = A( 1, 1 ) DWORK( 2 ) = ZERO DWORK( 5 ) = A( 1, 2 ) DWORK( 6 ) = A( 2, 2 ) DWORK( 9 ) = ZERO DWORK( 10 ) = -A( 1, 4 ) DWORK( 11 ) = -DWORK( 1 ) DWORK( 12 ) = -DWORK( 5 ) DWORK( 13 ) = -DWORK( 10 ) DWORK( 14 ) = ZERO DWORK( 15 ) = ZERO DWORK( 16 ) = -DWORK( 6 ) DWORK( 17 ) = B( 1, 3 ) DWORK( 18 ) = B( 1, 4 ) DWORK( 21 ) = B( 1, 4 ) DWORK( 22 ) = B( 2, 4 ) C SMLN = TWO*PAR( 2 ) / PAR( 1 ) SMIN = SQRT( SMLN ) / $ MAX( ABS( DWORK( 1 ) ), SMLN, ABS( DWORK( 10 ) ), $ ABS( DWORK( 5 ) ) + ABS( DWORK( 6 ) ), $ ABS( DWORK( 18 ) ) + $ MAX( ABS( DWORK( 17 ) ), ABS( DWORK( 22 ) ) ) ) PAR( 3 ) = SMIN CALL MB02UW( .FALSE., 2, 6, PAR, B, LDB, DWORK, 4, SI, INFO ) IF( INFO.NE.0 ) $ RETURN C C Compute X22 = -d*inv(B11')*A11'. C CALL MB02UW( .TRUE., 2, 2, PAR, B, LDB, DWORK( 11 ), 4, D, $ INFO ) C C Take si = min( si, d ) as unique scaling factor. C IF( SI.LT.D ) THEN CALL DLASCL( 'G', 0, 0, D, SI, 2, 2, DWORK( 11 ), 4, INFO ) ELSE IF( SI.GT.D ) THEN CALL DLASCL( 'G', 0, 0, SI, D, 2, 6, DWORK, 4, INFO ) END IF C C Compute X12 = si*( inv(B11)*A12 - ( inv(B11)*B12 )*X22 ). C CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 2, -ONE, $ DWORK( 17 ), 4, DWORK( 11 ), 4, ONE, DWORK( 9 ), $ 4 ) C C Scale X11, X12, and X22, so that 1-norm of X11 is 1. C NRM = MAX( ABS( DWORK( 1 ) ) + ABS( DWORK( 2 ) ), $ ABS( DWORK( 5 ) ) + ABS( DWORK( 6 ) ), SMLN ) IF ( NRM.GT.ONE ) THEN CALL DLASCL( 'G', 0, 0, NRM, ONE, 2, 4, DWORK, 4, INFO ) CALL DLASCL( 'G', 0, 0, NRM, ONE, 2, 2, DWORK( 11 ), 4, $ INFO ) END IF C C Compute s = trace(X11). C S = DWORK( 1 ) + DWORK( 6 ) C C Compute Y2, the last two columns of Y = X*X - s*X + t*I4, C where X = ( Xij ), i,j = 1,2, X21 = 0, t = det(X11). C T = DWORK( 1 )*DWORK( 6 ) - DWORK( 2 )*DWORK( 5 ) C CALL DLACPY( 'Full', 4, 2, DWORK( 9 ), 4, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 4, ONE, $ DWORK, 4, DWORK( 9 ), 4, -S, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 2, ONE, $ DWORK( 11 ), 4, DWORK( 11 ), 4, -S, Q( 3, 1 ), $ LDQ ) Q( 3, 1 ) = Q( 3, 1 ) + T Q( 4, 2 ) = Q( 4, 2 ) + T C ITAU = 1 IWRK = 3 C C Triangularize Y2 and compute the orthogonal transformation C matrix. C CALL DGEQR2( 4, 2, Q, LDQ, DWORK( ITAU ), DWORK( IWRK ), INFO ) CALL DORG2R( 4, 4, 2, Q, LDQ, DWORK( ITAU ), DWORK( IWRK ), $ INFO ) C C Use the last two columns of Q to build a 2-by-4 matrix W. C Postmultiply A with the first column of Q, and premultiply C by W. Then, annihilate the second element of the result. C DWORK( 21 ) = A( 1, 1 )*Q( 1, 1 ) + A( 1, 2 )*Q( 2, 1 ) + $ A( 1, 4 )*Q( 4, 1 ) DWORK( 22 ) = A( 2, 2 )*Q( 2, 1 ) - A( 1, 4 )*Q( 3, 1 ) DWORK( 23 ) = A( 1, 1 )*Q( 3, 1 ) DWORK( 24 ) = A( 1, 2 )*Q( 3, 1 ) + A( 2, 2 )*Q( 4, 1 ) DWORK( 9 ) = Q( 3, 3 )*DWORK( 21 ) + Q( 4, 3 )*DWORK( 22 ) $ - Q( 1, 3 )*DWORK( 23 ) - Q( 2, 3 )*DWORK( 24 ) DWORK( 10 ) = Q( 3, 4 )*DWORK( 21 ) + Q( 4, 4 )*DWORK( 22 ) $ - Q( 1, 4 )*DWORK( 23 ) - Q( 2, 4 )*DWORK( 24 ) CALL DLARTG( DWORK( 9 ), DWORK( 10 ), CO, SI, T ) CALL DROT( 4, Q( 1, 3 ), 1, Q( 1, 4 ), 1, CO, SI ) C ELSE CALL DLARTG( B( 1, 2 ), TWO*B( 1, 1 ), CO, SI, T ) Q( 1, 1 ) = CO Q( 2, 1 ) = -SI Q( 1, 2 ) = SI Q( 2, 2 ) = CO END IF C RETURN C *** Last line of MB03HD *** END slicot-5.0+20101122/src/MB03ID.f000077500000000000000000001737241201767322700154030ustar00rootroot00000000000000 SUBROUTINE MB03ID( COMPQ, COMPU, N, A, LDA, C, LDC, D, LDD, B, $ LDB, F, LDF, Q, LDQ, U1, LDU1, U2, LDU2, NEIG, $ IWORK, LIWORK, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form, with C C ( 0 I ) ( A D ) ( B F ) C S = J Z' J' Z, J = ( ), Z = ( ), H = ( ), C ( -I 0 ) ( 0 C ) ( 0 -B' ) C C to the leading principal subpencil, while keeping the triangular C form. Above, A is upper triangular, B is upper quasi-triangular, C and C is lower triangular. C The matrices Z and H are transformed by an orthogonal symplectic C matrix U and an orthogonal matrix Q such that C C ( Aout Dout ) C Zout = U' Z Q = ( ), and C ( 0 Cout ) C (1) C ( Bout Fout ) C Hout = J Q' J' H Q = ( ), C ( 0 -Bout' ) C C where Aout, Bout and Cout remain in triangular form. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q C that fulfills (1) is computed. C Optionally, if COMPU = 'I' or COMPU = 'U', the orthogonal C symplectic matrix C C ( U1 U2 ) C U = ( ) C ( -U2 U1 ) C C that fulfills (1) is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned; C = 'U': the array Q contains an orthogonal matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C COMPU CHARACTER*1 C Specifies whether or not the orthogonal symplectic C transformations should be accumulated in the arrays U1 and C U2, as follows: C = 'N': U1 and U2 are not computed; C = 'I': the arrays U1 and U2 are initialized internally, C and the submatrices U1 and U2 defining the C orthogonal symplectic matrix U are returned; C = 'U': the arrays U1 and U2 contain the corresponding C submatrices of an orthogonal symplectic matrix U0 C on entry, and the updated submatrices U1 and U2 C of the matrix product U0*U are returned, where U C is the product of the orthogonal symplectic C transformations that are applied to the pencil C aS - bH to reorder the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. The elements of the C strictly lower triangular part of this array are not used. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C C (input/output) DOUBLE PRECISION array, dimension C (LDC, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the lower triangular matrix C. The elements of the C strictly upper triangular part of this array are not used. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Cout. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1, N/2). C C D (input/output) DOUBLE PRECISION array, dimension C (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix D. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Dout. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper quasi-triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper quasi-triangular part of C the matrix Bout. C The part below the first subdiagonal of this array is C not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) DOUBLE PRECISION array, dimension C (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the symmetric matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Fout. C The strictly lower triangular part of this array is not C referenced, except for the element F(N/2,N/2-1), but its C initial value is preserved. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C U1 (input/output) DOUBLE PRECISION array, dimension C (LDU1, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper left block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper left block U1 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices S and H. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper left block U1 of the C orthogonal symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= 1, if COMPU = 'N'; C LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'. C C U2 (input/output) DOUBLE PRECISION array, dimension C (LDU2, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper right block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper right block U2 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices S and H. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper right block U2 of the C orthogonal symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= 1, if COMPU = 'N'; C LDU2 >= MAX(1, N/2), if COMPU = 'U' or COMPU = 'I'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N+1. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The dimension of the array DWORK. C If COMPQ = 'N', C LDWORK >= MAX(2*N+48,171); C if COMPQ = 'I' or COMPQ = 'U', C LDWORK >= MAX(4*N+48,171). C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the periodic QZ algorithm did not converge in SLICOT C Library routine MB03BB; C = 2: an error occured during the execution of MB03CD; C = 3: an error occured during the execution of MB03GD. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aA - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real C parts in the pencil aS - bH. C I. Exchange the eigenvalues between the last diagonal block C in aA - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues of the R-th block to the (MM+1)-th C block, where R denotes the number of upper quasi- C triangular blocks in aA - bB and MM denotes the current C number of blocks in aA - bB with eigenvalues with negative C real parts. C C The algorithm uses a sequence of orthogonal transformations as C described on page 25 in [1]. To achieve those transformations the C elementary subroutines MB03CD and MB03GD are called for the C corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, November 21, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DHAFNX). C C REVISIONS C C V. Sima, Aug. 2009; Feb. 2010; Oct. 2010; Nov. 2010. C C KEYWORDS C C Eigenvalue reordering, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0, $ TEN = 1.0D+1 ) C C .. Scalar Arguments .. CHARACTER COMPQ, COMPU INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDQ, LDU1, LDU2, $ LDWORK, LIWORK, N, NEIG C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), DWORK( * ), F( LDF, * ), $ Q( LDQ, * ), U1( LDU1, * ), U2( LDU2, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LCMPU, LINIQ, LINIU, LUPDQ, LUPDU INTEGER DIM1, DIM2, HLP, I, I1, IA, IB, IB1, IB2, IB3, $ IBS, IC, IHUPLE, IQ1, IQ2, IQ3, IQLOLE, IQLORI, $ IQUPLE, IQUPRI, IR, IS, ITMP1, ITMP2, ITMP3, $ IUPD, IUUPLE, IUUPRI, IWRK1, IWRK2, IWRK3, $ IWRK4, IWRK5, IZLORI, IZUPLE, IZUPRI, J, K, $ LDW, M, MM, MP, NCOL, NCOLS, NROW, NROWS, $ OPTDW, R, SDIM, UPDS DOUBLE PRECISION A2, BASE, C2, F2, LGBAS, NRMB, PREC, Q11, Q12, $ Q21, Q22, TMPA, TMPC, TOL, U11, U12 C C .. Local Arrays .. INTEGER IDUM( 8 ) DOUBLE PRECISION DUM( 3, 4 ), PAR( 2 ), PRD( 2, 2, 3 ) C C .. External Functions .. LOGICAL LSAME INTEGER MA01CD DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS, LSAME, MA01CD C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASET, DSCAL, $ MA02AD, MB01RU, MB01RX, MB03BB, MB03CD, MB03GD, $ XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, LOG, MAX, MIN, MOD, SIGN C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LINIU = LSAME( COMPU, 'I' ) LUPDU = LSAME( COMPU, 'U' ) LCMPQ = LINIQ .OR. LUPDQ LCMPU = LINIU .OR. LUPDU C IF( LCMPQ ) THEN OPTDW = MAX( 4*N + 48, 171 ) ELSE OPTDW = MAX( 2*N + 48, 171 ) END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -15 ELSE IF( LDU1.LT.1 .OR. ( LCMPU .AND. LDU1.LT.M ) ) THEN INFO = -17 ELSE IF( LDU2.LT.1 .OR. ( LCMPU .AND. LDU2.LT.M ) ) THEN INFO = -19 ELSE IF( LIWORK.LT.N+1 ) THEN INFO = -22 ELSE IF( LDWORK.LT.OPTDW ) THEN INFO = -24 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB03ID', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN NEIG = 0 RETURN END IF C C Determine machine constants. C PREC = DLAMCH( 'Precision' ) BASE = DLAMCH( 'Base' ) LGBAS = LOG( BASE ) TOL = MIN( DBLE( M ), TEN )*PREC C PAR( 1 ) = PREC PAR( 2 ) = DLAMCH( 'Safe minimum' ) C C STEP 0: Determine location and size of diagonal blocks. C IWORK(J) and IWORK(IS+J) are used to indicate the C beginning index and the kind of eigenvalues of the C J-th diagonal block of the subpencil aA - bB. C To find IWORK(IS+J) for the block J of size dim, compute C -T -1 C sign( trace(C(rng,rng) *B(rng,rng)*A(rng,rng) ) ), C C where rng = J:J+dim-1. For dim = 2, it is assumed that C both eigenvalues of the matrix above have real parts with C the same sign (true for a structured Schur form). C I = 1 J = 1 IS = M + 1 C C Partition blocks. C NRMB = DLANHS( 'One', M, B, LDB, DWORK ) C C WHILE( I.LE.M-1 ) DO C 10 CONTINUE IF( I.LE.M-1 ) THEN IWORK( J ) = I IF( ABS( B( I+1, I ) ).LE.TOL*NRMB ) THEN C C 1-by-1 block. C B( I+1, I ) = ZERO IWORK( IS+J ) = SIGN( ONE, A( I, I )*B( I, I )*C( I, I ) ) I = I + 1 ELSE C C 2-by-2 block. C U11 = B( I+1, I )*A( I, I+1 ) U12 = B( I+1, I )*C( I+1, I ) TMPA = B( I+1, I+1 )*A( I, I ) - U11 TMPC = B( I, I )*C( I+1, I+1 ) - U12 IF( ABS( TMPA ).LE.PREC*ABS( U11 ) .AND. $ ABS( TMPC ).LE.PREC*ABS( U12 ) ) THEN C C Severe cancellation. Use the periodic QZ algorithm. C Workspace: 30. C IDUM( 1 ) = 1 IDUM( 2 ) = 2 IDUM( 3 ) = 3 IDUM( 4 ) = 1 IDUM( 5 ) = -1 IDUM( 6 ) = -1 CALL DLACPY( 'Full', 2, 2, B( I, I ), LDB, PRD, 2 ) CALL DLACPY( 'Upper', 2, 2, A( I, I ), LDA, $ PRD( 1, 1, 2 ), 2 ) CALL MA02AD( 'Lower', 2, 2, C( I, I ), LDC, $ PRD( 1, 1, 3 ), 2 ) PRD( 2, 1, 2 ) = ZERO PRD( 2, 1, 3 ) = ZERO CALL MB03BB( BASE, LGBAS, PREC, 3, IDUM, IDUM( 4 ), 1, $ PRD, 2, 2, DWORK, DWORK( 3 ), DWORK( 5 ), $ IDUM( 7 ), DWORK( 7 ), INFO ) IF( INFO.NE.0 ) $ RETURN IF( DWORK( 5 ).EQ.ZERO .OR. DWORK( 6 ).EQ.ZERO ) THEN IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = MA01CD( DWORK( 1 ), IDUM( 7 ), $ DWORK( 2 ), IDUM( 8 ) ) END IF ELSE IF( C( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN C C The pencil has infinite eigenvalues or it is singular. C IWORK( IS+J ) = 0 ELSE U11 = TMPA/A( I+1, I+1 ) + TMPC/C( I, I ) IF( U11.EQ.ZERO ) THEN IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = SIGN( ONE, U11 )* $ SIGN( ONE, A( I, I )*C( I+1, I+1 ) ) END IF END IF I = I + 2 END IF J = J + 1 GO TO 10 C C END WHILE 10 C END IF C IF( I.EQ.M ) THEN C C 1-by-1 block C IWORK( J ) = I IWORK( IS+J ) = SIGN( ONE, A( I, I )*B( I, I )*C( I, I ) ) J = J + 1 END IF C R = J - 1 C C Initialize Q if appropriate. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C C Initialize U1 and U2 if appropriate. C IF( LINIU ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, U1, LDU1 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, U2, LDU2 ) END IF C IF( M.GT.1 ) THEN C C Save the elements A(M,M-1), C(M-1,M), and F(M,M-1), which might C be overwritten. C A2 = A( M, M-1 ) C2 = C( M-1, M ) F2 = F( M, M-1 ) END IF C C STEP 1: Reorder the eigenvalues in the subpencil aA - bB. C MM = 0 MP = J C C I. Reorder the eigenvalues with negative real parts to the top. C C Set pointers for the inputs and outputs of MB03CD. C IQ1 = 1 IQ2 = IQ1 + 16 IQ3 = IQ2 + 16 IA = IQ3 + 16 IB = IA + 16 IC = IB + 16 IWRK1 = IC + 16 IWRK2 = IA C K = 1 IB3 = M + 1 IWORK( R+1 ) = IB3 C C WHILE( K.LE.R ) DO C 20 CONTINUE IF( K.LE.R ) THEN IF( IWORK( IS+K ).LT.0 ) THEN DO 30 J = K - 1, MM + 1, -1 C C IB1, IB2, and IB3 are pointers to 3 consecutive blocks. C IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1), C C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to C DWORK as inputs for MB03CD. Also, set the additional C zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC, $ DWORK( IC ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) IF( DIM1.EQ.2 ) THEN DWORK( IA+1 ) = ZERO DWORK( IC+1 ) = ZERO END IF IF( DIM2.EQ.2 ) THEN I1 = SDIM*( SDIM - 1 ) - 1 DWORK( IA+I1 ) = ZERO DWORK( IC+I1 ) = ZERO END IF DWORK( IB+SDIM-1 ) = ZERO IF( SDIM.EQ.4 ) THEN DWORK( IB+2 ) = ZERO DWORK( IB+7 ) = ZERO END IF C C Perform eigenvalue/matrix block exchange. C Workspace: IWRK1 + 16*DIM1 + 10*DIM2 + 22 <= IWRK1 + 74, C if SDIM > 2, and IWRK1 - 1, otherwise. C CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ), $ SDIM, DWORK( IA ), SDIM, DWORK( IB ), $ SDIM, DWORK( IQ1 ), SDIM, DWORK( IQ2 ), $ SDIM, DWORK( IQ3 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Copy the transformed diagonal block of B, if sdim > 2. C IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) END IF C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 NROW = IB3 - 1 NCOL = M - IB1 + 1 CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ), $ LDA, DUM, 3 ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ A( IB1+1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ), $ LDC, DUM( 1, 2 ), 3 ) CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO, $ C( IB1, IB1+1 ), LDC ) C C Update A. C Workspace: IWRK2 + 2*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), NROW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3, $ A( IB1+1, IB1 ), LDA ) C C Update C. C CALL DGEMM( 'No Transpose', 'No Transpose', NCOL, SDIM, $ SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), NCOL ) CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL, $ C( IB1, IB1 ), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NROW, $ SDIM, ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ), $ LDC, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM, $ C( IB1, 1 ), LDC ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3, $ C( IB1, IB1+1 ), LDC ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, M, SDIM, $ ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM, $ D( IB1, 1 ), LDD ) C C Update B. C IF( SDIM.GT.2 ) THEN NROW = NROWS NCOL = NCOLS IBS = IB3 LDW = MAX( 1, NROW ) ELSE IBS = IB1 LDW = NROW END IF CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ B( IB1, IBS ), LDB, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IBS ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ F( IB1, IB3 ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, IB3 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ3 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 2*N - 1, if COMPQ = 'I'; C IWRK2 + 4*N - 1, if COMPQ = 'U'. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ3 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U1. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U1( 1, IB1 ), LDU1, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U1( 1, IB1 ), LDU1 ) END IF C IF( LUPDU ) THEN C C Update U2. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U2( 1, IB1 ), LDU2, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U2( 1, IB1 ), LDU2 ) END IF C C Update index lists IWORK(1:M) and IWORK(M+2:N+1) if a C 1-by-1 and 2-by-2 block have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF C C Update IWORK(M+2:N+1). C HLP = IWORK( IS+J ) IWORK( IS+J ) = IWORK( IS+J+1 ) IWORK( IS+J+1 ) = HLP 30 CONTINUE MM = MM + 1 END IF K = K + 1 GO TO 20 C C END WHILE 20 C END IF C C II. Reorder the eigenvalues with positive real parts to the bottom. C K = R C C WHILE( K.GE.MM+1 ) DO C 40 CONTINUE IF( K.GE.MM+1 ) THEN IF( IWORK( IS+K ).GT.0 ) THEN DO 50 J = K, MP - 2 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1), C C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to C DWORK as inputs for MB03CD. Also, set the additional C zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC, $ DWORK( IC ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) IF( DIM1.EQ.2 ) THEN DWORK( IA+1 ) = ZERO DWORK( IC+1 ) = ZERO END IF IF( DIM2.EQ.2 ) THEN I1 = SDIM*( SDIM - 1 ) - 1 DWORK( IA+I1 ) = ZERO DWORK( IC+I1 ) = ZERO END IF DWORK( IB+SDIM-1 ) = ZERO IF( SDIM.EQ.4 ) THEN DWORK( IB+2 ) = ZERO DWORK( IB+7 ) = ZERO END IF C C Perform eigenvalue/matrix block exchange. C CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ), $ SDIM, DWORK( IA ), SDIM, DWORK( IB ), $ SDIM, DWORK( IQ1 ), SDIM, DWORK( IQ2 ), $ SDIM, DWORK( IQ3 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Copy the transformed diagonal block of B, if sdim > 2. C IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) END IF C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 NROW = IB3 - 1 NCOL = M - IB1 + 1 CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ), $ LDA, DUM, 3 ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ A( IB1+1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ), $ LDC, DUM( 1, 2 ), 3 ) CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO, $ C( IB1, IB1+1 ), LDC ) C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), NROW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3, $ A( IB1+1, IB1 ), LDA ) C C Update C. C CALL DGEMM( 'No Transpose', 'No Transpose', NCOL, SDIM, $ SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), NCOL ) CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL, $ C( IB1, IB1 ), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NROW, $ SDIM, ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ), $ LDC, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM, $ C( IB1, 1 ), LDC ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3, $ C( IB1, IB1+1 ), LDC ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, M, SDIM, $ ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM, $ D( IB1, 1 ), LDD ) C C Update B. C IF( SDIM.GT.2 ) THEN NROW = NROWS NCOL = NCOLS IBS = IB3 LDW = MAX( 1, NROW ) ELSE IBS = IB1 LDW = NROW END IF CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ B( IB1, IBS ), LDB, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IBS ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ F( IB1, IB3 ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, IB3 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ3 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ3 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U1. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U1( 1, IB1 ), LDU1, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U1( 1, IB1 ), LDU1 ) END IF C IF( LUPDU ) THEN C C Update U2. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U2( 1, IB1 ), LDU2, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U2( 1, IB1 ), LDU2 ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. IWORK(M+2:N+1) is not needed anymore, C so it is not necessary to update it. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 50 CONTINUE MP = MP - 1 END IF K = K - 1 GO TO 40 C C END WHILE 40 C END IF C C STEP 2: Reorder the remaining eigenvalues with negative real parts. C C Set pointers for the inputs and outputs of MB03GD. C IQUPLE = 1 IUUPLE = IQUPLE + 16 IZUPLE = IUUPLE + 16 IHUPLE = IZUPLE + 16 IWRK5 = IHUPLE + 16 IWRK3 = IZUPLE IWRK4 = IWRK3 + 2*N ITMP1 = IWRK3 + N ITMP2 = ITMP1 + 4 ITMP3 = ITMP2 + 4 C DO 70 K = R, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C IR = IWORK( R ) DIM1 = IWORK( R+1 ) - IR SDIM = 2*DIM1 C IF( DIM1.EQ.2 ) THEN A( M, IR ) = ZERO C( IR, M ) = ZERO C C Build the (small) symmetric matrix F(M-1:M,M-1:M). C F( M, IR ) = F( IR, M ) END IF C C Calculate position of submatrices in DWORK. C IZUPRI = IZUPLE + DIM1*SDIM IZLORI = IZUPRI + DIM1 IUUPRI = IUUPLE + DIM1*SDIM IQLOLE = IQUPLE + DIM1 IQUPRI = IQUPLE + DIM1*SDIM IQLORI = IQUPRI + DIM1 C C Generate input matrices for MB03GD built of submatrices of A, C D, C, B, and F. C CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IZUPLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, D( IR, IR ), LDD, $ DWORK( IZUPRI ), SDIM ) CALL DLACPY( 'Lower', DIM1, DIM1, C( IR, IR ), LDC, $ DWORK( IZLORI ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( IHUPLE ), SDIM ) CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDB, $ DWORK( IHUPLE+DIM1*SDIM ), SDIM ) IF( DIM1.EQ.2 ) THEN DWORK( IZUPLE+1 ) = ZERO DWORK( IZLORI+SDIM ) = ZERO END IF C C Perform eigenvalue exchange. C Workspace: IWRK5 + 11, if SDIM = 4. C CALL MB03GD( SDIM, DWORK( IZUPLE ), SDIM, DWORK( IHUPLE ), $ SDIM, PAR, DWORK( IQUPLE ), SDIM, DWORK( IUUPLE ), $ SDIM, DWORK( IWRK5 ), LDWORK-IWRK5+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF C IF( DIM1.EQ.2 ) THEN C C Update A by transformations from the right. C Workspace: IWRK3 + N - 1. C CALL DLACPY( 'Full', M, DIM1, A( 1, IR ), LDA, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, A( 1, IR ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLOLE ), SDIM, $ ONE, A( 1, IR ), LDA ) C C Update D by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, D( 1, IR ), $ LDD ) C C Compute intermediate product Cf*Q21, with C Cf = C(M-1:M,M-1:M). C CALL DGEMM( 'No Transpose', 'No Transpose', DIM1, DIM1, $ DIM1, ONE, C( IR, IR ), LDC, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) C C Update C by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', DIM1, DIM1, $ DIM1, ONE, C( IR, IR ), LDC, DWORK( IQLORI ), $ SDIM, ZERO, DWORK( IWRK3 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, DWORK( IWRK3 ), DIM1, $ C( IR, IR ), LDC ) C C Update A by transformations from the left. C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IUUPLE ), SDIM, A( IR, IR ), LDA, $ ZERO, DWORK( IWRK3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ -ONE, DWORK( IUUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ONE, DWORK( IWRK3 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, DWORK( IWRK3 ), DIM1, $ A( IR, IR ), LDA ) C C Update D by transformations from the left. C CALL DLACPY( 'Full', DIM1, M, D( IR, 1 ), LDD, $ DWORK( IWRK3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ ONE, DWORK( IUUPLE ), SDIM, DWORK( IWRK3 ), $ DIM1, ZERO, D( IR, 1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ -ONE, DWORK( IUUPRI ), SDIM, C( IR, 1 ), LDC, $ ONE, D( IR, 1 ), LDD ) C C Update C by transformations from the left. C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ ONE, DWORK( IUUPRI ), SDIM, DWORK( IWRK3 ), $ DIM1, ZERO, DWORK( ITMP1 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ ONE, DWORK( IUUPLE ), SDIM, C( IR, 1 ), LDC, $ ONE, DWORK( ITMP1 ), DIM1 ) CALL DLACPY( 'Full', DIM1, M, DWORK( ITMP1 ), DIM1, $ C( IR, 1 ), LDC ) C C Update B by transformations from the right. C CALL DLACPY( 'Full', M, DIM1, B( 1, IR ), LDB, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, B( 1, IR ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLOLE ), SDIM, $ ONE, B( 1, IR ), LDB ) C C Update F by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, F( 1, IR ), $ LDF ) C C Compute intermediate products Bf'*Q21 and Bf'*Q22, with C Bf = B(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI ), $ SDIM, ZERO, DWORK( ITMP2 ), DIM1 ) C C Update B by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, B( IR, IR ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( IR, IR ), LDB ) C C Update F by transformations from the left. C CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ZERO, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQLORI ), $ SDIM, F( IR, IR ), LDF, INFO ) CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ONE, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQUPRI ), $ SDIM, DWORK( ITMP2 ), DIM1, INFO ) CALL DLACPY( 'Upper', DIM1, DIM1, DWORK( ITMP1 ), DIM1, $ F( IR, IR ), LDF ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK4 + 2*N - 1. C CALL DLACPY( 'Full', N, DIM1, Q( 1, IR ), LDQ, $ DWORK( IWRK4 ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPLE ), SDIM, ZERO, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLOLE ), SDIM, ONE, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPRI ), SDIM, ZERO, DWORK( IWRK3 ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLORI ), SDIM, ONE, DWORK( IWRK3 ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( IWRK3 ), N, $ Q( 1, M+IR ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U. C Workspace: ITMP1 + N - 1. C CALL DLACPY( 'Full', M, DIM1, U1( 1, IR ), LDU1, $ DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, ONE, DWORK( ITMP1 ), M, $ DWORK( IUUPLE ), SDIM, ZERO, U1( 1, IR ), $ LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, -ONE, U2( 1, IR ), LDU2, $ DWORK( IUUPRI ), SDIM, ONE, U1( 1, IR ), $ LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, ONE, DWORK( ITMP1 ), M, $ DWORK( IUUPRI ), SDIM, ZERO, DWORK( IWRK3 ), $ M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, ONE, U2( 1, IR ), LDU2, $ DWORK( IUUPLE ), SDIM, ONE, DWORK( IWRK3 ), $ M ) CALL DLACPY( 'Full', M, DIM1, DWORK( IWRK3 ), M, $ U2( 1, IR ), LDU2 ) END IF C ELSE U11 = DWORK( IUUPLE ) U12 = DWORK( IUUPRI ) Q11 = DWORK( IQUPLE ) Q21 = DWORK( IQLOLE ) Q12 = DWORK( IQUPRI ) Q22 = DWORK( IQLORI ) C C Update A by transformations from the right. C CALL DCOPY( M, A( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M, Q11, A( 1, IR ), 1 ) CALL DAXPY( M, Q21, D( 1, IR ), 1, A( 1, IR ), 1 ) C C Update D by transformations from the right. C CALL DSCAL( M, Q22, D( 1, IR ), 1 ) CALL DAXPY( M, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 ) C C Compute intermediate product C(M,M)*Q21. C TMPC = C( IR, IR )*Q21 C C Update C by transformations from the right. C C( IR, IR ) = C( IR, IR )*Q22 C C Update A by transformations from the left. C A( IR, IR ) = U11*A( IR, IR ) - U12*TMPC C C Update D by transformations from the left. C CALL DCOPY( M, D( IR, 1 ), LDD, DWORK( IWRK3 ), 1 ) CALL DSCAL( M, U11, D( IR, 1 ), LDD ) CALL DAXPY( M, -U12, C( IR, 1 ), LDC, D( IR, 1 ), LDD ) C C Update C by transformations from the left. C CALL DSCAL( M, U11, C( IR, 1 ), LDC ) CALL DAXPY( M, U12, DWORK( IWRK3 ), 1, C( IR, 1 ), LDC ) C C Update B by transformations from the right. C CALL DCOPY( M-1, B( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, B( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, F( 1, IR ), 1, B( 1, IR ), 1 ) C C Update F by transformations from the right. C CALL DSCAL( M-1, Q22, F( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, F( 1, IR ), 1 ) C C Update B by transformations from the left. C B( M, M ) = -B( M, M ) C IF( LCMPQ ) THEN C C Update Q. C CALL DCOPY( N, Q( 1, IR ), 1, DWORK( IWRK4 ), 1 ) CALL DSCAL( N, Q11, Q( 1, IR ), 1 ) CALL DAXPY( N, Q21, Q( 1, IR+M ), 1, Q( 1, IR ), 1 ) CALL DSCAL( N, Q22, Q( 1, IR+M ), 1 ) CALL DAXPY( N, Q12, DWORK( IWRK4 ), 1, Q( 1, IR+M ), 1 ) END IF C IF( LCMPU ) THEN C C Update U. C CALL DCOPY( M, U1( 1, IR ), 1, DWORK( IWRK4 ), 1 ) CALL DSCAL( M, U11, U1( 1, IR ), 1 ) CALL DAXPY( M, -U12, U2( 1, IR ), 1, U1( 1, IR ), 1 ) CALL DSCAL( M, U11, U2( 1, IR ), 1 ) CALL DAXPY( M, U12, DWORK( IWRK4 ), 1, U2( 1, IR ), 1 ) END IF END IF C MM = MM + 1 DO 60 J = R - 1, MM, -1 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1), C C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to C DWORK as inputs for MB03CD. Also, set the additional C zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC, $ DWORK( IC ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, DWORK( IB+1 ), $ SDIM+1 ) IF( DIM1.EQ.2 ) THEN DWORK( IA+1 ) = ZERO DWORK( IC+1 ) = ZERO END IF IF( DIM2.EQ.2 ) THEN I1 = SDIM*( SDIM - 1 ) - 1 DWORK( IA+I1 ) = ZERO DWORK( IC+I1 ) = ZERO END IF DWORK( IB+SDIM-1 ) = ZERO IF( SDIM.EQ.4 ) THEN DWORK( IB+2 ) = ZERO DWORK( IB+7 ) = ZERO END IF C C Perform eigenvalue/matrix block exchange. C CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ), SDIM, $ DWORK( IA ), SDIM, DWORK( IB ), SDIM, $ DWORK( IQ1 ), SDIM, DWORK( IQ2 ), SDIM, $ DWORK( IQ3 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Copy the transformed diagonal block of B, if sdim > 2. C IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) END IF C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 NROW = IB3 - 1 NCOL = M - IB1 + 1 CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ), LDA, $ DUM, 3 ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ A( IB1+1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ), LDC, $ DUM( 1, 2 ), 3 ) CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO, $ C( IB1, IB1+1 ), LDC ) C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), NROW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, SDIM, $ ONE, DWORK( IQ2 ), SDIM, A( IB1, IB1 ), LDA, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3, $ A( IB1+1, IB1 ), LDA ) C C Update C. C CALL DGEMM( 'No Transpose', 'No Transpose', NCOL, SDIM, $ SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), NCOL ) CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL, $ C( IB1, IB1 ), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NROW, SDIM, $ ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ), LDC, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM, $ C( IB1, 1 ), LDC ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3, $ C( IB1, IB1+1 ), LDC ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, SDIM, $ ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ), SDIM, $ ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, M, SDIM, $ ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM, $ D( IB1, 1 ), LDD ) C C Update B. C IF( SDIM.GT.2 ) THEN NROW = NROWS NCOL = NCOLS IBS = IB3 LDW = MAX( 1, NROW ) ELSE IBS = IB1 LDW = NROW END IF CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, SDIM, $ ONE, DWORK( IQ3 ), SDIM, B( IB1, IBS ), LDB, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IBS ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, SDIM, $ ONE, DWORK( IQ3 ), SDIM, F( IB1, IB3 ), LDF, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, IB3 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ3 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, IB1 ), LDQ, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, M+IB1 ), LDQ, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, M+IB1 ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U1( 1, IB1 ), LDU1, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U1( 1, IB1 ), LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U2( 1, IB1 ), LDU2, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U2( 1, IB1 ), LDU2 ) END IF C C Update index list IWORK(1:M)if a 1-by-1 and 2-by-2 block C have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 60 CONTINUE 70 CONTINUE C IF( M.GT.1 ) THEN C C Restore the elements A(M,M-1), C(M-1,M), and F(M,M-1). C A( M, M-1 ) = A2 C( M-1, M ) = C2 F( M, M-1 ) = F2 END IF C IF( MM.GT.0 ) THEN NEIG = IWORK( MM+1 ) - 1 ELSE NEIG = 0 END IF C RETURN C *** Last line of MB03ID *** END slicot-5.0+20101122/src/MB03JD.f000077500000000000000000001353021201767322700153720ustar00rootroot00000000000000 SUBROUTINE MB03JD( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q, $ LDQ, NEIG, IWORK, LIWORK, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form, C C ( A D ) ( B F ) C S = ( ), H = ( ), C ( 0 A' ) ( 0 -B' ) C C with A upper triangular and B upper quasi-triangular, to the C leading principal subpencil, while keeping the triangular form: C C ( Aout Dout ) ( Bout Fout ) C Sout = ( ), Hout = ( ), where C ( 0 Aout' ) ( 0 -Bout' ) C C Aout is upper triangular and Bout is upper quasi-triangular. C Optionally, if COMPQ = 'I' or COMPQ = 'U', an orthogonal matrix Q C is determined such that the pencil C C ( 0 I ) C J Q' J' (aS - bH) Q = aSout - bHout, with J = ( ), C ( -I 0 ) C C keeps the triangular form, but all eigenvalues with strictly C negative real part are in the leading principal subpencil. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned; C = 'U': the array Q contains an orthogonal matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. The elements of the C strictly lower triangular part of this array are not used. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C D (input/output) DOUBLE PRECISION array, dimension C (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the skew-symmetric C matrix D. The diagonal need not be set to zero. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Dout. C The strictly lower triangular part of this array is C not referenced, except for the element D(N/2,N/2-1), but C its initial value is preserved. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper quasi-triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper quasi-triangular part of C the matrix Bout. C The part below the first subdiagonal of this array is C not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) DOUBLE PRECISION array, dimension C (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the symmetric matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Fout. C The strictly lower triangular part of this array is not C referenced, except for the element F(N/2,N/2-1), but its C initial value is preserved. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N+1. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The dimension of the array DWORK. C If COMPQ = 'N', C LDWORK >= MAX(2*N+32,108); C if COMPQ = 'I' or COMPQ = 'U', C LDWORK >= MAX(4*N+32,108). C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: error occured during execution of MB03DD; C = 2: error occured during execution of MB03HD. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aA - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real C parts in the pencil aS - bH. C I. Exchange the eigenvalues between the last diagonal block C in aA - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues of the R-th block to the (MM+1)-th C block, where R denotes the number of upper quasi- C triangular blocks in aA - bB and MM denotes the current C number of blocks in aA - bB with eigenvalues with negative C real parts. C C The algorithm uses a sequence of orthogonal transformations as C described on page 33 in [1]. To achieve those transformations the C elementary subroutines MB03DD and MB03HD are called for the C corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DHAUNX). C C REVISIONS C C V. Sima, Aug. 2009; Jan. 2010, Oct. 2010, Nov. 2010. C C KEYWORDS C C Eigenvalue reordering, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0, $ TEN = 1.0D+1 ) C C .. Scalar Arguments .. CHARACTER COMPQ INTEGER INFO, LDA, LDB, LDD, LDF, LDQ, LDWORK, LIWORK, $ N, NEIG C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), F( LDF, * ), Q( LDQ, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LINIQ, LUPDQ INTEGER DIM1, DIM2, HLP, I, IA, IAUPLE, IB, IB1, IB2, $ IB3, IBUPLE, IBUPRI, IC, ICS, IQ1, IQ2, IQLOLE, $ IQLORI, IQUPLE, IQUPRI, IR, IS, ITMP1, ITMP2, $ ITMP3, IUPD, IWRK1, IWRK2, IWRK3, IWRK4, IWRK5, $ J, K, LDW, M, MM, MP, NCOL, NCOLS, NROW, NROWS, $ OPTDW, R, SDIM, UPDS DOUBLE PRECISION A2, D1, D2, D3, F2, NRMA, NRMB, PREC, Q11, Q12, $ Q21, Q22, TMP, TOL C C .. Local Arrays .. DOUBLE PRECISION PAR( 2 ) C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANHS, DLANTR EXTERNAL DDOT, DLAMCH, DLANHS, DLANTR, LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLASET, $ DSCAL, MB01LD, MB01RU, MB01RX, MB03DD, MB03HD, $ XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SIGN C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ IF( LCMPQ ) THEN OPTDW = MAX( 4*N+32, 108 ) ELSE OPTDW = MAX( 2*N+32, 108 ) END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -12 ELSE IF( LIWORK.LT.N+1 ) THEN INFO = -15 ELSE IF( LDWORK.LT.OPTDW ) THEN INFO = -17 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB03JD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN NEIG = 0 RETURN END IF C C Determine machine constants. C PREC = DLAMCH( 'Precision' ) TOL = MIN( DBLE( N ), TEN )*PREC C PAR( 1 ) = PREC PAR( 2 ) = DLAMCH( 'Safe minimum' ) C C STEP 0: Determine location and size of diagonal blocks. C IWORK(J) and IWORK(IS+J) are used to indicate the C beginning index and the kind of eigenvalues of the C J-th diagonal block of the subpencil aA - bB. For a C 2-by-2 block, it is assumed that both eigenvalues have C real parts with the same sign (true for a structured C Schur form). C I = 1 J = 1 IS = M + 1 C NRMA = DLANTR( 'One', 'Upper', 'Non-diag', M, M, A, LDA, DWORK ) NRMB = DLANHS( 'One', M, B, LDB, DWORK ) C C Partition blocks. C C WHILE( I.LE.M-1 ) DO C 10 CONTINUE IF( I.LE.M-1 ) THEN IWORK( J ) = I IF( ABS( B( I+1, I ) ).LE.TOL*NRMB ) THEN C C 1-by-1 block. C B( I+1, I ) = ZERO IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR. $ ABS( B( I, I ) ).LE.TOL*NRMB ) THEN C C Eigenvalue is infinite, 0, or 0/0. C IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) ) END IF I = I + 1 ELSE C C 2-by-2 block. C IF( A( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN C C Eigenvalue is infinite. C IWORK( IS+J ) = 0 ELSE TMP = ( B( I, I ) - ( B( I+1, I ) / A( I+1, I+1 ) )* $ A( I, I+1 ) ) / A( I, I ) + $ B( I+1, I+1 ) / A( I+1, I+1 ) IF( TMP.EQ.ZERO ) THEN IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, TMP ) ) END IF END IF I = I + 2 END IF J = J + 1 GO TO 10 C C END WHILE 10 C END IF C IF( I.EQ.M ) THEN IWORK( J ) = I IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR. $ ABS( B( I, I ) ).LE.TOL*NRMB ) THEN C C Eigenvalue is infinite or zero. C IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) ) END IF J = J + 1 END IF C R = J - 1 C C Initialize Q if appropriate. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C IF( M.GT.1 ) THEN C C Save the lower triangle of the submatrix D(M-1:M,M-1:M) and the C elements A(M,M-1), F(M,M-1), which might be overwritten. C D1 = D( M-1, M-1 ) D2 = D( M, M-1 ) D3 = D( M, M ) A2 = A( M, M-1 ) F2 = F( M, M-1 ) END IF C C STEP 1: Reorder the eigenvalues in the subpencil aA - bB. C MM = 0 MP = J C C I. Reorder the eigenvalues with negative real parts to the top. C C Set pointers for the inputs and outputs of MB03DD. C IQ1 = 1 IQ2 = IQ1 + 16 IA = IQ2 + 16 IB = IA + 16 IWRK1 = IB + 16 IWRK2 = IA C K = 1 IB3 = M + 1 IWORK( R+1 ) = IB3 C C WHILE( K.LE.R ) DO C 20 CONTINUE IF( K.LE.R ) THEN IF( IWORK( IS+K ).LT.0 ) THEN DO 30 J = K - 1, MM + 1, -1 C C IB1, IB2, and IB3 are pointers to 3 consecutive blocks. C IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C Workspace: IWRK1 + 43. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) NROW = NROWS NCOL = NCOLS IC = ICS LDW = MAX( 1, NROW ) ELSE TMP = A( IB1+1, IB1 ) A( IB1+1, IB1 ) = ZERO NROW = IB3 - 1 NCOL = M - IB1 + 1 IC = IB1 LDW = NROW END IF C C Update A. C Workspace: IWRK2 + 2*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ), $ LDA, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IC ), LDA ) IF( SDIM.EQ.2 ) $ A( IB1+1, IB1 ) = TMP C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ D( IB1, ICS ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ), $ LDB, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IC ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, ICS ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 2*N - 1, if COMPQ = 'I'; C IWRK2 + 4*N - 1, if COMPQ = 'U'. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C C Update index lists IWORK(1:M) and IWORK(M+2:N+1) if a C 1-by-1 and 2-by-2 block have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF C C Update IWORK(M+2:N+1). C HLP = IWORK( IS+J ) IWORK( IS+J ) = IWORK( IS+J+1 ) IWORK( IS+J+1 ) = HLP 30 CONTINUE MM = MM + 1 END IF K = K + 1 GO TO 20 C C END WHILE 20 C END IF C C II. Reorder the eigenvalues with positive real parts to the bottom. C K = R C C WHILE( K.GE.MM+1 ) DO C 40 CONTINUE IF( K.GE.MM + 1 ) THEN IF( IWORK( IS+K ).GT.0 ) THEN DO 50 J = K, MP - 2 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) NROW = NROWS NCOL = NCOLS IC = ICS LDW = MAX( 1, NROW ) ELSE TMP = A( IB1+1, IB1 ) A( IB1+1, IB1 ) = ZERO NROW = IB3 - 1 NCOL = M - IB1 + 1 IC = IB1 LDW = NROW END IF C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ), $ LDA, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IC ), LDA ) IF( SDIM.EQ.2 ) $ A( IB1+1, IB1 ) = TMP C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ D( IB1, ICS ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ), $ LDB, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IC ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, ICS ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. IWORK(M+2:N+1) is not needed anymore, C so it is not necessary to update it. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 50 CONTINUE MP = MP - 1 END IF K = K - 1 GO TO 40 C C END WHILE 40 C END IF C C STEP 2: Reorder the remaining eigenvalues with negative real parts. C C Set pointers for the inputs and outputs of MB03HD. C IQUPLE = 1 IAUPLE = IQUPLE + 16 IBUPLE = IAUPLE + 8 IWRK5 = IBUPLE + 8 IWRK3 = IAUPLE IWRK4 = IWRK3 + 2*N ITMP1 = IWRK3 + N ITMP2 = ITMP1 + 4 ITMP3 = ITMP2 + 4 C DO 70 K = R, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C IR = IWORK( R ) DIM1 = IWORK( R+1 ) - IR SDIM = 2*DIM1 C IF( DIM1.EQ.2 ) THEN A( M, IR ) = ZERO C C Build the (small) full skew-symmetric matrix D(M-1:M,M-1:M) C and the (small) symmetric matrix F(M-1:M,M-1:M). C D( IR, IR ) = ZERO D( M, IR ) = -D( IR, M ) D( M, M ) = ZERO F( M, IR ) = F( IR, M ) END IF C C Calculate position of submatrices in DWORK. C IBUPRI = IBUPLE + DIM1*DIM1 IQLOLE = IQUPLE + DIM1 IQUPRI = IQUPLE + DIM1*SDIM IQLORI = IQUPRI + DIM1 C C Generate input matrices for MB03HD built of submatrices of A, C D, B, and F. C IF( DIM1.EQ.2 ) THEN CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IAUPLE ), DIM1 ) DWORK( IAUPLE+6 ) = D( IR, IR+1 ) CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( IBUPLE ), DIM1 ) CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDF, $ DWORK( IBUPRI ), DIM1 ) ELSE DWORK( IBUPLE ) = B( IR, IR ) DWORK( IBUPRI ) = F( IR, IR ) END IF C C Perform eigenvalue exchange. C Workspace: IWRK5 + 22, if SDIM = 4. C CALL MB03HD( SDIM, DWORK( IAUPLE ), DIM1, DWORK( IBUPLE ), $ DIM1, PAR, DWORK( IQUPLE ), SDIM, DWORK( IWRK5 ), $ INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C IF( DIM1.EQ.2 ) THEN C C Update A by transformations from the right. C Workspace: IWRK3 + N - 1. C CALL DLACPY( 'Full', M, DIM1, A( 1, IR ), LDA, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, A( 1, IR ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLOLE ), SDIM, $ ONE, A( 1, IR ), LDA ) C C Update D by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, D( 1, IR ), $ LDD ) C C Compute the intermediate product Af'*Q21 and the second C column of Af'*Q22, with Af = A(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) CALL DGEMV( 'Transpose', DIM1, DIM1, ONE, $ DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI+SDIM ), $ 1, ZERO, DWORK( ITMP2 ), 1 ) C C Update A by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IWRK3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ -ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, A( IR, IR ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( IWRK3 ), $ DIM1, ONE, A( IR, IR ), LDA ) C C Update D by transformations from the left. C D( IR, M ) = DDOT( DIM1, DWORK( IQLORI ), 1, D( IR, M ), 1 ) $ - DDOT( DIM1, DWORK( IQUPRI ), 1, DWORK( ITMP2 ), $ 1 ) C C Update B by transformations from the right. C CALL DLACPY( 'Full', M, DIM1, B( 1, IR ), LDB, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, B( 1, IR ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLOLE ), SDIM, $ ONE, B( 1, IR ), LDB ) C C Update F by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, F( 1, IR ), $ LDF ) C C Compute intermediate products Bf'*Q21 and Bf'*Q22, with C Bf = B(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI ), $ SDIM, ZERO, DWORK( ITMP2 ), DIM1 ) C C Update B by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, B( IR, IR ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( IR, IR ), LDB ) C C Update F by transformations from the left. C CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ZERO, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQLORI ), $ SDIM, F( IR, IR ), LDF, INFO ) CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ONE, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQUPRI ), $ SDIM, DWORK( ITMP2 ), DIM1, INFO ) CALL DLACPY( 'Upper', DIM1, DIM1, DWORK( ITMP1 ), DIM1, $ F( IR, IR ), LDF ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK4 + 2*N - 1. C CALL DLACPY( 'Full', N, DIM1, Q( 1, IR ), LDQ, $ DWORK( IWRK4 ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPLE ), SDIM, ZERO, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLOLE ), SDIM, ONE, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPRI ), SDIM, ZERO, DWORK( IWRK3 ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLORI ), SDIM, ONE, DWORK( IWRK3 ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( IWRK3 ), N, $ Q( 1, M+IR ), LDQ ) END IF ELSE Q11 = DWORK( IQUPLE ) Q21 = DWORK( IQLOLE ) Q12 = DWORK( IQUPRI ) Q22 = DWORK( IQLORI ) C C Update A by transformations from the right. C CALL DCOPY( M-1, A( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, A( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, D( 1, IR ), 1, A( 1, IR ), 1 ) C C Update D by transformations from the right. C CALL DSCAL( M-1, Q22, D( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 ) C C Update B by transformations from the right. C CALL DCOPY( M-1, B( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, B( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, F( 1, IR ), 1, B( 1, IR ), 1 ) C C Update F by transformations from the right. C CALL DSCAL( M-1, Q22, F( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, F( 1, IR ), 1 ) C C Update B by transformations from the left. C B( M, M ) = -B( M, M ) C IF( LCMPQ ) THEN C C Update Q. C CALL DCOPY( N, Q( 1, IR ), 1, DWORK( IWRK4 ), 1 ) CALL DSCAL( N, Q11, Q( 1, IR ), 1 ) CALL DAXPY( N, Q21, Q( 1, IR+M ), 1, Q( 1, IR ), 1 ) CALL DSCAL( N, Q22, Q( 1, IR+M ), 1 ) CALL DAXPY( N, Q12, DWORK( IWRK4 ), 1, Q( 1, IR+M ), 1 ) END IF C END IF C MM = MM + 1 DO 60 J = R - 1, MM, -1 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, DWORK( IB+1 ), $ SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) NROW = NROWS NCOL = NCOLS IC = ICS LDW = MAX( 1, NROW ) ELSE TMP = A( IB1+1, IB1 ) A( IB1+1, IB1 ) = ZERO NROW = IB3 - 1 NCOL = M - IB1 + 1 IC = IB1 LDW = NROW END IF C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ), $ LDA, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IC ), LDA ) IF( SDIM.EQ.2 ) $ A( IB1+1, IB1 ) = TMP C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ D( IB1, ICS ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ), $ LDB, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IC ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, ICS ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 4*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, IB1 ), LDQ, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, M+IB1 ), LDQ, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, M+IB1 ), LDQ ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 C ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 60 CONTINUE 70 CONTINUE C IF( M.GT.1 ) THEN C C Restore the lower triangle of the submatrix D(M-1:M,M-1:M) and C the elements A(M,M-1) and F(M,M-1). C D( M-1, M-1 ) = D1 D( M, M-1 ) = D2 D( M, M ) = D3 A( M, M-1 ) = A2 F( M, M-1 ) = F2 END IF C IF( MM.GT.0 ) THEN NEIG = IWORK( MM+1 ) - 1 ELSE NEIG = 0 END IF C RETURN C *** Last line of MB03JD *** END slicot-5.0+20101122/src/MB03KA.f000077500000000000000000000565761201767322700154070ustar00rootroot00000000000000 SUBROUTINE MB03KA( COMPQ, WHICHQ, WS, K, NC, KSCHUR, IFST, ILST, $ N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 formal matrix product C C T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1), (1) C C of length K, in the generalized periodic Schur form C C [ T11_k T12_k T13_k ] C T_k = [ 0 T22_k T23_k ], k = 1, ..., K, (2) C [ 0 0 T33_k ] C C where C C - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or C NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced C infinite eigenvalues, C - the submatrices T22_k are NC-by-NC and contain core eigenvalues, C which are generically neither zero nor infinite, C - the submatrices T33_k contain dimension-induced zero C eigenvalues, C C such that the block with starting row index IFST in (1) is moved C to row index ILST. The indices refer to the T22_k submatrices. C C Optionally, the transformation matrices Q_1,...,Q_K from the C reduction into generalized periodic Schur form are updated with C respect to the performed reordering. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute any of the matrices Q_k; C = 'U': each coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the products Q1_k*Q_k are C returned, where Q_k, k = 1, ..., K, performed the C reordering; C = 'W': the computation of each Q_k is specified C individually in the array WHICHQ. C C WHICHQ INTEGER array, dimension (K) C If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k C as follows: C = 0: do not compute Q_k; C > 0: the kth coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the product Q1_k*Q_k is C returned. C This array is not referenced if COMPQ <> 'W'. C C WS LOGICAL C = .FALSE. : do not perform the strong stability tests; C = .TRUE. : perform the strong stability tests; often, C this is not needed, and omitting them can save C some computations. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences T and Q (the C number of factors in the matrix product). K >= 2. C (For K = 1, a standard eigenvalue reordering problem is C obtained.) C C NC (input) INTEGER C The number of core eigenvalues. 0 <= NC <= min(N). C C KSCHUR (input) INTEGER C The index for which the matrix T22_kschur is upper quasi- C triangular. All other T22 matrices are upper triangular. C C IFST (input/output) INTEGER C ILST (input/output) INTEGER C Specify the reordering of the diagonal blocks, as follows: C The block with starting row index IFST in (1) is moved to C row index ILST by a sequence of direct swaps between adjacent C blocks in the product. C On exit, if IFST pointed on entry to the second row of a C 2-by-2 block in the product, it is changed to point to the C first row; ILST always points to the first row of the block C in its final position in the product (which may differ from C its input value by +1 or -1). C 1 <= IFST <= NC, 1 <= ILST <= NC. C C N (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the formal matrix product T, C such that the k-th coefficient T_k is an N(k+1)-by-N(k) C matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix, C if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1). C C NI (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the matrix sequence T11_k. C N(k) >= NI(k) + NC >= 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequence. Each entry in S must be either 1 or -1; C the value S(k) = -1 corresponds to using the inverse of C the factor T_k. C C T (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXT(k) the C matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1, C or at least N(k)-by-N(k+1), if S(k) = -1, in periodic C Schur form. C On exit, the matrices T_k are overwritten by the reordered C periodic Schur form. C C LDT INTEGER array, dimension (K) C The leading dimensions of the matrices T_k in the one- C dimensional array T. C LDT(k) >= max(1,N(k+1)), if S(k) = 1, C LDT(k) >= max(1,N(k)), if S(k) = -1. C C IXT INTEGER array, dimension (K) C Start indices of the matrices T_k in the one-dimensional C array T. C C Q (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXQ(k) a C matrix Q_k of size at least N(k)-by-N(k), provided that C COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0. C On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0, C Q_k is post-multiplied with the orthogonal matrix that C performed the reordering. C This array is not referenced if COMPQ = 'N'. C C LDQ INTEGER array, dimension (K) C The leading dimensions of the matrices Q_k in the one- C dimensional array Q. C LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and C WHICHQ(k) > 0; C This array is not referenced if COMPQ = 'N'. C C IXQ INTEGER array, dimension (K) C Start indices of the matrices Q_k in the one-dimensional C array Q. C This array is not referenced if COMPQ = 'N'. C C Tolerances C C TOL DOUBLE PRECISION array, dimension (3) C This array contains tolerance parameters. The weak and C strong stability tests use a threshold computed by the C formula MAX( c*EPS*NRM, SMLNUM ), where c is a constant, C NRM is the Frobenius norm of the current matrix formed by C concatenating K pairs of adjacent diagonal blocks of sizes C 1 and/or 2 in the T22_k submatrices from (2), which are C swapped, and EPS and SMLNUM are the machine precision and C safe minimum divided by EPS, respectively (see LAPACK C Library routine DLAMCH). The norm NRM is computed by this C routine; the other values are stored in the array TOL. C TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM, C respectively. TOL(1) should normally be at least 10. C C Workspace C C IWORK INTEGER array, dimension (4*K) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 10*K + MN, if all blocks between IFST and ILST C have order 1; C LDWORK >= 25*K + MN, if there is at least a block of C order 2, but no adjacent blocks of C order 2 can appear between IFST and C ILST during reordering; C LDWORK >= MAX(42*K + MN, 80*K - 48), if at least a pair of C adjacent blocks of order 2 can appear C between IFST and ILST during C reordering; C where MN = MXN, if MXN > 10, and MN = 0, otherwise, with C MXN = MAX(N(k),k=1,...,K). C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -21, the LDWORK argument was too small; C = 1: the reordering of T failed because some eigenvalues C are too close to separate (the problem is very ill- C conditioned); T may have been partially reordered. C The returned value of ILST is the index where this C was detected. C C METHOD C C An adaptation of the LAPACK Library routine DTGEXC is used. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, SLICOT Library version of the PEP routine PEP_DTGEXC. C V. Sima, July 2010. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, periodic C Sylvester-like equations, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER COMPQ LOGICAL WS INTEGER IFST, ILST, INFO, K, KSCHUR, LDWORK, NC C .. C .. Array Arguments .. INTEGER IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ), $ LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * ) DOUBLE PRECISION DWORK( * ), Q( * ), T( * ), TOL( * ) C .. C .. Local Scalars .. INTEGER HERE, I, IP1, IT, MINWRK, NBF, NBL, NBNEXT C .. C .. External Subroutines .. EXTERNAL MB03KB, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MOD C .. C .. Executable Statements .. C C For efficiency reasons the parameters are not checked, except for C workspace. C IF( NC.EQ.2 ) THEN NBF = 1 NBL = 1 ELSE IF( NC.EQ.3 ) THEN NBF = 1 NBL = 2 ELSE NBF = 2 NBL = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, 1, NBF, NBL, N, NI, $ S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, DWORK, -1, $ INFO ) MINWRK = MAX( 1, INT( DWORK(1) ) ) IF( LDWORK.NE.-1 .AND. LDWORK.LT.MINWRK ) $ INFO = -21 C C Quick return if possible C IF( LDWORK.EQ.-1 ) THEN DWORK(1) = DBLE( MINWRK ) RETURN ELSE IF( INFO.LT.0 ) THEN CALL XERBLA( 'MB03KA', -INFO ) RETURN END IF C C Set I and IP1 to point to KSCHUR and KSCHUR+1 to simplify C indices below. C I = KSCHUR IP1 = MOD( I, K ) + 1 C C Determine the first row of the block in T22_kschur corresponding C to the first block in the product and find out if it is 1-by-1 or C 2-by-2. C IF( IFST.GT.1 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + IFST - 2 )*LDT(I) + NI(IP1) + IFST $ - 1 ELSE IT = IXT(I) + ( NI(IP1) + IFST - 2 )*LDT(I) + NI(I) + IFST $ - 1 END IF IF( T( IT ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + IFST - 1 )*LDT(I) + NI(IP1) + IFST ELSE IT = IXT(I) + ( NI(IP1) + IFST - 1 )*LDT(I) + NI(I) + IFST END IF IF( T( IT ).NE.ZERO ) $ NBF = 2 END IF C C Determine the first row of the block in T_kschur corresponding C to the last block in the product and find out it is 1-by-1 or C 2-by-2. C IF( ILST.GT.1 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + ILST - 2 )*LDT(I) + NI(IP1) + ILST $ - 1 ELSE IT = IXT(I) + ( NI(IP1) + ILST - 2 )*LDT(I) + NI(I) + ILST $ - 1 END IF IF( T( IT ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + ILST - 1 )*LDT(I) + NI(IP1) + ILST ELSE IT = IXT(I) + ( NI(IP1) + ILST - 1 )*LDT(I) + NI(I) + ILST END IF IF( T( IT ).NE.ZERO ) $ NBL = 2 END IF C C If the specified and last block in the product were the same, C return. C IF( IFST.EQ.ILST ) $ RETURN C C If the specified block lies above the last block on the diagonal C of the product and the blocks have unequal sizes, update ILST. C IF( IFST.LT.ILST ) THEN 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 HERE = IFST C 10 CONTINUE C C Swap a block with next one below. C IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current next block is either 1-by-1 or 2-by-2. C NBNEXT = 1 IF( HERE+NBF+1.LE.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE + NBF - 1 )*LDT(I) + $ NI(IP1) + HERE + NBF ELSE IT = IXT(I) + ( NI(IP1) + HERE + NBF - 1 )*LDT(I) + $ NI(I) + HERE + NBF END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, NBF, $ NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT C C Test if a 2-by-2 block breaks into two 1-by-1 blocks. C IF( NBF.EQ.2 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1) $ + HERE ELSE IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I) $ + HERE END IF IF( T( IT ).EQ.ZERO ) $ NBF = 3 END IF ELSE C C Current next block consists of two 1-by-1 blocks each of C which must be swapped individually. C NBNEXT = 1 IF( HERE+3.LE.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE + 1 )*LDT(I) + NI(IP1) + $ HERE + 2 ELSE IT = IXT(I) + ( NI(IP1) + HERE + 1 )*LDT(I) + NI(I) + $ HERE + 2 END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1, 1, $ NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, 1, $ NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 ELSE C C Recompute NBNEXT in case 2-by-2 split. C IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE )*LDT(I) + NI(IP1) + HERE $ + 1 ELSE IT = IXT(I) + ( NI(IP1) + HERE )*LDT(I) + NI(I) + HERE $ + 1 END IF IF( T( IT ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN C C The 2-by-2 block did not split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ 1, NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, $ IXQ, TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE C C The 2-by-2 block did split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE + 1 RETURN END IF HERE = HERE + 2 END IF END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 C ELSE C HERE = IFST 20 CONTINUE C C Swap a block with next one above. 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.GE.3 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1) $ + HERE - 2 ELSE IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I) $ + HERE - 2 END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT, $ NBNEXT, NBF, N, NI, S, T, LDT, IXT, Q, LDQ, $ IXQ, TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT C C Test if a 2-by-2 block breaks into two 1-by-1 blocks. C IF( NBF.EQ.2 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1) $ + HERE ELSE IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I) $ + HERE END IF IF( T( IT ).EQ.ZERO ) $ NBF = 3 END IF C ELSE C C Current block consists of two 1-by-1 blocks each of which C must be swapped individually. C NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1) $ + HERE - 2 ELSE IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I) $ + HERE - 2 END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT, $ NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ, $ IXQ, TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 ELSE C C Recompute NBNEXT in case 2-by-2 split. C IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 2 )*LDT(I) + NI(IP1) $ + HERE - 1 ELSE IT = IXT(I) + ( NI(IP1) + HERE - 2 )*LDT(I) + NI(I) $ + HERE - 1 END IF IF( T( IT ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN C C The 2-by-2 block did not split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1, $ 2, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE C The 2-by-2 block did split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE - 1 RETURN END IF HERE = HERE - 2 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE C C Store optimal workspace values and return. C DWORK(1) = DBLE( MINWRK ) RETURN C C *** Last line of MB03KA *** END slicot-5.0+20101122/src/MB03KB.f000077500000000000000000001652551201767322700154030ustar00rootroot00000000000000 SUBROUTINE MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, J1, N1, N2, $ N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 formal matrix product C C T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1) (1) C C of length K in the generalized periodic Schur form C C [ T11_k T12_k T13_k ] C T_k = [ 0 T22_k T23_k ], k = 1, ..., K, (2) C [ 0 0 T33_k ] C C where C C - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or C NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced C infinite eigenvalues, C - the submatrices T22_k are NC-by-NC and contain core eigenvalues, C which are generically neither zero nor infinite, C - the submatrices T33_k contain dimension-induced zero C eigenvalues, C C such that pairs of adjacent diagonal blocks of sizes 1 and/or 2 in C the product (1) are swapped. C C Optionally, the transformation matrices Q_1,...,Q_K from the C reduction into generalized periodic Schur form are updated with C respect to the performed reordering. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute any of the matrices Q_k; C = 'U': each coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the products Q1_k*Q_k are C returned, where Q_k, k = 1, ..., K, performed the C reordering; C = 'W': the computation of each Q_k is specified C individually in the array WHICHQ. C C WHICHQ INTEGER array, dimension (K) C If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k C as follows: C = 0: do not compute Q_k; C > 0: the kth coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the product Q1_k*Q_k is C returned. C This array is not referenced if COMPQ <> 'W'. C C WS LOGICAL C = .FALSE. : do not perform the strong stability tests; C = .TRUE. : perform the strong stability tests; often, C this is not needed, and omitting them can save C some computations. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences T and Q (the C number of factors in the matrix product). K >= 2. C (For K = 1, a standard eigenvalue reordering problem is C obtained.) C C NC (input) INTEGER C The number of core eigenvalues. 0 <= NC <= min(N). C C KSCHUR (input) INTEGER C The index for which the matrix T22_kschur is upper quasi- C triangular. C C J1 (input) INTEGER C The index of the first row and column of the first block C to swap in T22_k. C 1 <= J1 <= NC-N1-N2+1. C C N1 (input) INTEGER C The order of the first block to swap. N1 = 0, 1 or 2. C C N2 (input) INTEGER C The order of the second block to swap. N2 = 0, 1 or 2. C C N (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the formal matrix product T, C such that the k-th coefficient T_k is an N(k+1)-by-N(k) C matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix, C if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1). C C NI (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the matrix sequence T11_k. C N(k) >= NI(k) + NC >= 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequence. Each entry in S must be either 1 or -1; C the value S(k) = -1 corresponds to using the inverse of C the factor T_k. C C T (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXT(k) the C matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1, C or at least N(k)-by-N(k+1), if S(k) = -1, in periodic C Schur form. C On exit, the matrices T_k are overwritten by the reordered C periodic Schur form. C C LDT INTEGER array, dimension (K) C The leading dimensions of the matrices T_k in the one- C dimensional array T. C LDT(k) >= max(1,N(k+1)), if S(k) = 1, C LDT(k) >= max(1,N(k)), if S(k) = -1. C C IXT INTEGER array, dimension (K) C Start indices of the matrices T_k in the one-dimensional C array T. C C Q (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXQ(k) a C matrix Q_k of size at least N(k)-by-N(k), provided that C COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0. C On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0, C Q_k is post-multiplied with the orthogonal matrix that C performed the reordering. C This array is not referenced if COMPQ = 'N'. C C LDQ INTEGER array, dimension (K) C The leading dimensions of the matrices Q_k in the one- C dimensional array Q. LDQ(k) >= 1, and C LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and C WHICHQ(k) > 0; C This array is not referenced if COMPQ = 'N'. C C IXQ INTEGER array, dimension (K) C Start indices of the matrices Q_k in the one-dimensional C array Q. C This array is not referenced if COMPQ = 'N'. C C Tolerances C C TOL DOUBLE PRECISION array, dimension (3) C This array contains tolerance parameters. The weak and C strong stability tests use a threshold computed by the C formula MAX( c*EPS*NRM, SMLNUM ), where c is a constant, C NRM is the Frobenius norm of the matrix formed by C concatenating K pairs of adjacent diagonal blocks of sizes C 1 and/or 2 in the T22_k submatrices from (2), which are C swapped, and EPS and SMLNUM are the machine precision and C safe minimum divided by EPS, respectively (see LAPACK C Library routine DLAMCH). The norm NRM is computed by this C routine; the other values are stored in the array TOL. C TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM, C respectively. TOL(1) should normally be at least 10. C C Workspace C C IWORK INTEGER array, dimension (4*K) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 10*K + MN, if N1 = 1, N2 = 1; C LDWORK >= 25*K + MN, if N1 = 1, N2 = 2; C LDWORK >= MAX(23*K + MN, 25*K - 12), if N1 = 2, N2 = 1; C LDWORK >= MAX(42*K + MN, 80*K - 48), if N1 = 2, N2 = 2; C where MN = MXN, if MXN > 10, and MN = 0, otherwise, with C MXN = MAX(N(k),k=1,...,K). C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -22, then LDWORK is too small; appropriate C value for LDWORK is returned in DWORK(1); the other C arguments are not tested, for efficiency; C = 1: the swap was rejected from stability reasons; the C blocks are not swapped and T and Q are unchanged. C C METHOD C C The algorithm described in [1] is used. Both weak and strong C stability tests are performed. C C REFERENCES C C [1] Granat, R., Kagstrom, B. and Kressner, D. C Computing periodic deflating subspaces associated with a C specified set of eigenvalues. C BIT Numerical Mathematics, vol. 47, 763-791, 2007. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C 3 C The algorithm requires 0(K NC ) floating point operations. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, an essentially new version of the PEP routine C PEP_DLAEXC, by R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Apr. 2010, May 2010, July 2010. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, 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 COMPQ LOGICAL WS INTEGER INFO, J1, K, KSCHUR, LDWORK, N1, N2, NC C .. C .. Array Arguments .. INTEGER IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ), $ LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * ) DOUBLE PRECISION DWORK( * ), Q( * ), T( * ), TOL( * ) C .. C .. Local Scalars .. LOGICAL FILL21, FILL43, FILLIN, SPECQ, WANTQ, WANTQL INTEGER A, B, C, I, I11, I12, I21, I22, IA, IB, IC, $ II, INDF1, INDF2, INDTAU, INDTT, INDV1, INDV2, $ INDVF, INDVP1, INDXC, INDXV, IP1, IPP, IQ, IS, $ IT, IT2, ITAU1, ITAU2, ITAUF, ITAUF1, ITAUF2, $ ITAUP1, IV1P1, IV2P1, J2, J3, J4, L, LTAU, $ LTAU1, LTAU2, LTT, MINWRK, MN, ND, ND2, TAU, $ TAU1, TAU1P1, TAU2, TAU2P1, TT, V, V1, V2, $ VLOC, VLOC1, VLOC2, W, WE DOUBLE PRECISION DNRM, DTAU1, DTAU2, EPS, SCALOC, SMLNUM, $ STRONG, TAULOC, THRESH, TMP, TMP1, TMP2, V_1, $ V_2, V_3, W_2, W_3, X_11, X_12, X_21, X_22 C .. C .. Local Arrays .. DOUBLE PRECISION TAUS( 2 ), TEMP( 16 ), TEMPM1( 16 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLANTR, DLAPY2 EXTERNAL DLANGE, DLANTR, DLAPY2, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DLACPY, DLARFG, DLARFX, DLASCL, MB03KC, $ MB03KE, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MOD C .. C .. Executable Statements .. C C Decode the input parameters C INFO = 0 WANTQ = LSAME( COMPQ, 'U' ) SPECQ = LSAME( COMPQ, 'W' ) C C Set the machine-dependent parameters. C EPS = TOL( 2 ) SMLNUM = TOL( 3 ) C C For efficiency reasons, the parameters are not checked. C C Set integer pointers to correct subsequences in T22_k and check C workspace. For simplicity, below these subsequences are denoted C by T11, T22 and T12 and are not to be confused with the T11_k, C T22_k and T12_k in (2). Also set integer pointers to be used in C Sylvester solver. C J2 = J1 + N1 I11 = 0 I21 = I11 + K I12 = I21 + K I22 = I12 + K MN = 0 C DO 10 I = 1, K MN = MAX( MN, N( I ) ) IP1 = MOD( I, K ) + 1 IF( S( I ).EQ.1 ) THEN II = IXT( I ) + NI( I )*LDT( I ) + NI( IP1 ) - 1 ELSE II = IXT( I ) + NI( IP1 )*LDT( I ) + NI( I ) - 1 END IF IWORK( I11+I ) = II + ( J1 - 1 )*LDT( I ) + J1 IWORK( I21+I ) = IWORK( I11+I ) + N1 IWORK( I12+I ) = IWORK( I11+I ) + N1*LDT( I ) IWORK( I22+I ) = IWORK( I12+I ) + N1 10 CONTINUE C C Divide workspace into different arrays and submatrices. C A = 1 IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN B = A + K C = B + K TAU = C + K V = TAU + K TT = V + K * 2 W = TT + K * 4 WE = TAU MN = MN + K * 10 ELSE IF( N1.EQ.1 .AND. N2.EQ.2 ) THEN B = A + K C = B + K * 4 TAU1 = C + K * 2 V1 = TAU1 + K TAU2 = V1 + K * 2 V2 = TAU2 + K TT = V2 + K * 2 LTAU = TT + K * 9 VLOC = LTAU + K W = VLOC + K * 2 WE = TAU1 MN = MN + K * 25 ELSE IF( N1.EQ.2 .AND. N2.EQ.1 ) THEN B = A + K * 4 C = B + K TAU = C + K * 2 V = TAU + K TT = V + K * 3 LTAU = TT + K * 9 VLOC = LTAU + K W = VLOC + K * 2 WE = TAU MN = MN + K * 23 ELSE IF( N1.EQ.2 .AND. N2.EQ.2 ) THEN B = A + K * 4 C = B + K * 4 TAU1 = C + K * 4 V1 = TAU1 + K TAU2 = V1 + K * 3 V2 = TAU2 + K TT = V2 + K * 3 LTAU1 = TT + K * 16 VLOC1 = LTAU1 + K LTAU2 = VLOC1 + K * 2 VLOC2 = LTAU2 + K W = VLOC2 + K * 2 WE = TAU1 MN = MN + K * 42 END IF C CALL MB03KE( .FALSE., .FALSE., -1, K, N1, N2, EPS, SMLNUM, S, T, $ T, T, SCALOC, DWORK, -1, INFO ) MINWRK = MAX( INT( DWORK( 1 ) ) + WE - 1, MN ) C C Quick return if possible. C DWORK( 1 ) = DBLE( MINWRK ) IF( LDWORK.EQ.-1 ) THEN RETURN ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -22 CALL XERBLA( 'MB03KB', -INFO ) RETURN ELSE IF( NC.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 .OR. N1.GT.NC .OR. $ J2.GT.NC .OR. J2 + N2 - 1.GT.NC ) THEN RETURN END IF C C Compute some local indices. C J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 C C Solve the periodic Sylvester-like equation associated with C the swap. C C Copy T11, T22 and T12 to workspace. Apply scaling to all of T22_k C for numerical stability. C IA = A IB = B IC = C ND = N1 + N2 ND2 = ND**2 C DNRM = ZERO C DO 20 I = 1, K IT = IWORK( I11+I ) IS = IWORK( I12+I ) IQ = IWORK( I22+I ) TMP = DLANTR( 'Frobenius', 'Upper', 'NonUnit', ND, ND, T( IT ), $ LDT( I ), DWORK ) IF( I.EQ.KSCHUR ) THEN IF( N1.EQ.2 ) $ TMP = DLAPY2( T( IT+1 ), TMP ) IF( N2.EQ.2 ) $ TMP = DLAPY2( T( IQ+1 ), TMP ) END IF DNRM = DLAPY2( DNRM, TMP ) TMP = MAX( TMP, SMLNUM ) IF( N1.EQ.1 ) THEN DWORK( IA ) = T( IT ) / TMP DWORK( IC ) = T( IS ) / TMP IF( N2.EQ.1 ) THEN DWORK( IB ) = T( IQ ) / TMP ELSE CALL DLACPY( 'All', N2, N2, T( IQ ), LDT( I ), $ DWORK( IB ), N2 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N2, N2, $ DWORK( IB ), N2, INFO ) DWORK( IC+1 ) = T( IS+LDT(I) ) / TMP END IF ELSE CALL DLACPY( 'All', N1, N1, T( IT ), LDT( I ), DWORK( IA ), $ N1 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N1, N1, DWORK( IA ), $ N1, INFO ) IF( N2.EQ.1 ) THEN DWORK( IB ) = T( IQ ) / TMP DWORK( IC ) = T( IS ) / TMP DWORK( IC+1 ) = T( IS+1 ) / TMP ELSE CALL DLACPY( 'All', N2, N2, T( IQ ), LDT( I ), $ DWORK( IB ), N2 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N2, N2, $ DWORK( IB ), N2, INFO ) CALL DLACPY( 'All', N1, N2, T( IS ), LDT( I ), $ DWORK( IC ), N1 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N1, N2, $ DWORK( IC ), N1, INFO ) END IF END IF IA = IA + N1**2 IB = IB + N2**2 IC = IC + N1*N2 20 CONTINUE C C Compute a machine-dependent threshold of the test for accepting C a swap. C THRESH = MAX( TOL( 1 )*EPS*DNRM, SMLNUM ) C C Call the periodic Sylvester-like equation solver. C Workspace: need WE - 1 + (4*K-3)*(N1*N2)**2 + K*N1*N2. C CALL MB03KE( .FALSE., .FALSE., -1, K, N1, N2, EPS, SMLNUM, S, $ DWORK( A ), DWORK( B ), DWORK( C ), SCALOC, $ DWORK( WE ), LDWORK-WE+1, INFO ) C C Swap the adjacent diagonal blocks. C L = N1 + N1 + N2 - 2 GO TO ( 30, 70, 140, 210 ) L C 30 CONTINUE C C Direct swap with N1 = 1 and N2 = 1. C C Generate elementary reflectors H_i such that: C C H_i( X_11_i ) = ( * ). C ( scale ) ( 0 ) C INDXC = C INDXV = V C DO 40 INDTAU = TAU, TAU + K - 1 X_11 = DWORK( INDXC ) DWORK( INDXV ) = X_11 DWORK( INDXV+1 ) = SCALOC CALL DLARFG( 2, DWORK( INDXV ), DWORK( INDXV+1 ), 1, $ DWORK( INDTAU ) ) DWORK( INDXV ) = ONE C C Next, do weak stability test. C TAULOC = DWORK( INDTAU ) TMP = SCALOC * ( ONE - TAULOC ) + $ TAULOC * DWORK( INDXV+1 ) * X_11 IF( ABS( TMP ).GT.THRESH ) $ GO TO 300 INDXC = INDXC + 1 INDXV = INDXV + 2 40 CONTINUE C IF( WS ) THEN C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace) and perform strong C stability test. C INDTAU = TAU INDXV = V INDTT = TT C DO 50 I = 1, K IP1 = MOD( I, K ) INDVP1 = V + IP1 * 2 ITAUP1 = TAU + IP1 CALL DLACPY( 'All', 2, 2, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 2 ) CALL DLACPY( 'All', 2, 2, TEMP, 2, DWORK( INDTT ), 2 ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), DWORK( INDTT ), 2, $ DWORK( W ) ) CALL DLARFX( 'Right', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), DWORK( INDTT ), 2, $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), DWORK( INDTT ), 2, $ DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), DWORK( INDTT ), 2, $ DWORK( W ) ) END IF C CALL DLACPY( 'All', 2, 2, DWORK( INDTT ), 2, TEMPM1, 2 ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 2, DWORK( W ) ) CALL DLARFX( 'Right', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 2, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 2, DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 2, DWORK( W ) ) END IF CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 2, 2, TEMPM1, 2, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C INDTAU = INDTAU + 1 INDXV = INDXV + 2 INDTT = INDTT + 4 50 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. C INDTAU = TAU INDXV = V C DO 60 I = 1, K IP1 = MOD( I, K ) C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C INDVP1 = V + IP1 * 2 ITAUP1 = TAU + IP1 C IP1 = IP1 + 1 IT = IWORK( I11+I ) - J1 + 1 IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), T( IT-NI( IP1 ) ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDXV ), $ DWORK( INDTAU ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT-NI( I ) ), LDT( I ), $ DWORK( W ) ) END IF C C Set to zero the fill-in element T(J2,J1,I). C T( IWORK( I21+I ) ) = ZERO C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDXV ), $ DWORK( INDTAU ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF INDTAU = INDTAU + 1 INDXV = INDXV + 2 60 CONTINUE C C Exit direct swap N1 = 1 and N2 = 1. C GOTO 290 C C Direct swap with N1 = 1 and N2 = 2. C 70 CONTINUE C C Generate elementary reflectors H(1)_i and H(2)_i such that C C H(2)_i H(1)_i ( X_11_i X_12_i ) = ( * * ). C ( scale 0 ) ( 0 * ) C ( 0 scale ) ( 0 0 ) C ITAU2 = TAU2 INDXC = C INDV1 = V1 INDV2 = V2 C DO 80 ITAU1 = TAU1, TAU1 + K - 1 C C Compute elementary reflector H(1)_i. C X_11 = DWORK( INDXC ) X_12 = DWORK( INDXC+1 ) DWORK( INDV1 ) = X_11 DWORK( INDV1+1 ) = SCALOC CALL DLARFG( 2, DWORK( INDV1 ), DWORK( INDV1+1 ), 1, $ DWORK( ITAU1 ) ) DWORK( INDV1 ) = ONE C C Compute elementary reflector H(2)_i. C DWORK( INDV2 ) = X_12 DWORK( INDV2+1 ) = ZERO CALL DLARFX( 'Left', 2, 1, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDV2 ), 2, DWORK( W ) ) DWORK( INDV2 ) = DWORK( INDV2+1 ) DWORK( INDV2+1 ) = SCALOC CALL DLARFG( 2, DWORK( INDV2 ), DWORK( INDV2+1 ), 1, $ DWORK( ITAU2 ) ) DWORK( INDV2 ) = ONE C C Next, do weak stability test. C TAUS( 1 ) = DWORK( ITAU1 ) TAUS( 2 ) = DWORK( ITAU2 ) V_1 = DWORK( INDV1+1 ) TMP1 = SCALOC * ( ONE - TAUS( 1 ) ) + TAUS( 1 ) * V_1 * X_11 TMP2 = -( SCALOC * TAUS( 1 ) * V_1 + X_11 * $ ( ONE - TAUS( 1 ) * V_1**2 ) ) * ( ONE - TAUS( 2 ) ) $ + TAUS( 2 ) * DWORK( INDV2+1 ) * X_12 IF( DLAPY2( TMP1, TMP2 ).GT.THRESH ) $ GO TO 300 ITAU2 = ITAU2 + 1 INDXC = INDXC + 2 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 80 CONTINUE C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace). C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 INDTT = TT LTT = 3 C DO 90 I = 1, K IP1 = MOD( I, K ) IV1P1 = V1 + IP1 * 2 IV2P1 = V2 + IP1 * 2 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ DWORK( INDTT ), 3 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 3, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+1 ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+3 ), 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+3 ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+1 ), 3, DWORK( W ) ) END IF ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 INDTT = INDTT + 9 90 CONTINUE C C Check for fill-in elements in the new 2-by-2 block. C FILLIN = .FALSE. INDTT = TT + 1 DO 100 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH ) $ FILLIN = .TRUE. INDTT = INDTT + 9 100 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 1, S, DWORK( TT ), LTT, $ DWORK( VLOC ), DWORK( LTAU ) ) END IF C IF( WS ) THEN C C Perform strong stability test. C ITAU1 = TAU1 ITAU2 = TAU2 ITAUF = LTAU INDV1 = V1 INDV2 = V2 INDVF = VLOC INDTT = TT C DO 110 I = 1, K IP1 = MOD( I, K ) CALL DLACPY( 'All', 3, 3, DWORK( INDTT ), 3, TEMPM1, 3 ) C C Apply possible transformations from fill-in removal. C IF( FILLIN ) THEN INDVP1 = VLOC + IP1 * 2 ITAUP1 = LTAU + IP1 C C Apply on top-left 2-by-2 block. C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1, 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1, 3, DWORK( W ) ) END IF END IF C C Take the "large" transformations. C IV1P1 = V1 + IP1 * 2 IV2P1 = V2 + IP1 * 2 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 C C Apply H(1)_i+1 * H(2)_i+1 from left or right depending on S. C Apply H(2)_i * H(1)_i from right or left depending on S. C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 3, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 2 ), 3, DWORK( W ) $ ) CALL DLARFX( 'Left', 2, 3, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 4 ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 4 ), 3, DWORK( W ) $ ) CALL DLARFX( 'Right', 3, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 2 ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 3, DWORK( W ) ) END IF C C Compute residual norm. C CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 3 ) CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 3, 3, TEMPM1, 3, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 ITAUF = ITAUF + 1 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 INDVF = INDVF + 2 INDTT = INDTT + 9 110 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. ITAU1 = TAU1 ITAU2 = TAU2 ITAUF = LTAU INDV1 = V1 INDV2 = V2 INDVF = VLOC C DO 120 I = 1, K IP1 = MOD( I, K ) IT = IWORK( I11+I ) - J1 + 1 C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C IV1P1 = V1 + IP1 * 2 IV2P1 = V2 + IP1 * 2 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 IP1 = IP1 + 1 C IF( S( I ).EQ.1 ) THEN IT = IT - NI( IP1 ) IT2 = IT + LDT( I ) CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IWORK( I21+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IT ), LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) ELSE IT = IT - NI( I ) IT2 = IT + LDT( I ) CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IWORK( I21+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), DWORK( W ) $ ) CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDV1 ), $ DWORK( ITAU1 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) IQ = IQ + LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDV2 ), $ DWORK( ITAU2 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF C C Apply Householder transformations from fill-in removal and C accumulate transformations in matrices Q_i, i=1,...,K. C IF ( FILLIN ) THEN IV1P1 = VLOC + ( IP1 - 1 ) * 2 TAU1P1 = LTAU + ( IP1 - 1 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J2, 2, DWORK( INDVF ), $ DWORK( ITAUF ), T( IT ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDVF ), $ DWORK( ITAUF ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDVF ), $ DWORK( ITAUF ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF END IF C ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 ITAUF = ITAUF + 1 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 INDVF = INDVF + 2 120 CONTINUE C C Set to zero the fill-in elements. C DO 130 I = 1, K T( IWORK( I21+I )+1 ) = ZERO T( IWORK( I22+I )+1 ) = ZERO IF( I.NE.KSCHUR ) $ T( IWORK( I21+I ) ) = ZERO 130 CONTINUE C C Exit direct swap N1 = 1 and N2 = 2. C GOTO 290 C C Direct swap with N1 = 2 and N2 = 1. C 140 CONTINUE C C Generate elementary reflectors H_i such that: C C H_i( X_11_i ) = ( * ). C ( X_21_i ) ( 0 ) C ( scale ) ( 0 ) C INDXC = C INDXV = V C DO 150 INDTAU = TAU, TAU + K - 1 X_11 = DWORK( INDXC ) X_21 = DWORK( INDXC+1 ) DWORK( INDXV ) = X_11 DWORK( INDXV+1 ) = X_21 DWORK( INDXV+2 ) = SCALOC C CALL DLARFG( 3, DWORK( INDXV ), DWORK( INDXV+1 ), 1, $ DWORK( INDTAU ) ) DWORK( INDXV ) = ONE C C Next, do weak stability test: check that C ||H_11_i - X_i * H_21_i||_F <= tol, i = 1, ..., K. C V_2 = DWORK( INDXV+2 ) TAULOC = DWORK( INDTAU ) TMP1 = SCALOC * ( ONE - TAULOC ) + TAULOC * V_2 * X_11 TMP2 = TAULOC * ( V_2 * X_21 - SCALOC * DWORK( INDXV+1 ) ) IF( DLAPY2( TMP1, TMP2 ).GT.THRESH ) $ GO TO 300 INDXC = INDXC + 2 INDXV = INDXV + 3 150 CONTINUE C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace). C INDTAU = TAU INDXV = V INDTT = TT LTT = 3 C DO 160 I = 1, K IP1 = MOD( I, K ) INDVP1 = V + IP1 * 3 ITAUP1 = TAU + IP1 CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ DWORK( INDTT ), 3 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 3, DWORK( INDVP1 ), DWORK( ITAUP1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 3, DWORK( INDXV ), DWORK( INDTAU ), $ DWORK( INDTT ), 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), DWORK( INDTT ), 3, $ DWORK( W ) ) CALL DLARFX( 'Left', 3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), DWORK( INDTT ), 3, $ DWORK( W ) ) END IF INDTAU = INDTAU + 1 INDXV = INDXV + 3 INDTT = INDTT + 9 160 CONTINUE C C Check for fill-in elements. C FILLIN = .FALSE. INDTT = TT + 5 DO 170 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH ) $ FILLIN = .TRUE. INDTT = INDTT + 9 170 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 2, S, DWORK( TT ), LTT, $ DWORK( VLOC ), DWORK( LTAU ) ) END IF C IF( WS ) THEN C C Perform strong stability test. C INDTAU = TAU INDXV = V ITAUF = LTAU INDVF = VLOC INDTT = TT C DO 180 I = 1, K IP1 = MOD( I, K ) CALL DLACPY( 'All', 3, 3, DWORK( INDTT ), 3, TEMPM1, 3 ) IF( FILLIN ) THEN INDVP1 = VLOC + IP1 * 2 ITAUP1 = LTAU + IP1 IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1( 5 ), 3, $ DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1( 4 ), 3, $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1( 4 ), 3, $ DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1( 5 ), 3, $ DWORK( W ) ) END IF END IF C INDVP1 = V + IP1 * 3 ITAUP1 = TAU + IP1 IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Left', 3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 3, DWORK( W ) ) END IF CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 3 ) CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 3, 3, TEMPM1, 3, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C INDTAU = INDTAU + 1 INDXV = INDXV + 3 ITAUF = ITAUF + 1 INDVF = INDVF + 2 INDTT = INDTT + 9 180 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. C INDTAU = TAU INDXV = V ITAUF = LTAU INDVF = VLOC C DO 190 I = 1, K IP1 = MOD( I, K ) IT = IWORK( I11+I ) - J1 + 1 C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C INDVP1 = V + IP1 * 3 ITAUP1 = TAU + IP1 IP1 = IP1 + 1 IF( S( I ).EQ.1 ) THEN IT = IT - NI( IP1 ) CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), T( IT ), LDT( I ), DWORK( W ) $ ) ELSE IT = IT - NI( I ) CALL DLARFX( 'Left', 3, N( IP1 )-J1+1, DWORK( INDXV ), $ DWORK( INDTAU ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT ), LDT( I ), DWORK( W ) $ ) END IF WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N(I), 3, DWORK( INDXV ), $ DWORK( INDTAU ), Q( IQ ), LDQ( I ), DWORK( W ) $ ) END IF C C Apply Householder transformations from fill-in removal and C accumulate transformations in matrices Q_i, i=1,...,K. C IF ( FILLIN ) THEN INDVP1 = VLOC + ( IP1 - 1 ) * 2 ITAUP1 = LTAU + IP1 - 1 IT2 = IT + LDT( I ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT2+J1 ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDVF ), $ DWORK( ITAUF ), T( IT2 ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Left', 2, N( IP1 )-J1, DWORK( INDVF ), $ DWORK( ITAUF ), T( IT2+J1 ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT2 ), LDT( I ), $ DWORK( W ) ) END IF WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + J1*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDVF ), $ DWORK( ITAUF ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF END IF INDTAU = INDTAU + 1 INDXV = INDXV + 3 ITAUF = ITAUF + 1 INDVF = INDVF + 2 190 CONTINUE C C Set to zero the fill-in elements below the main diagonal. C DO 200 I = 1, K IT = IWORK( I11+I ) + 1 T( IT ) = ZERO T( IT+1 ) = ZERO IF( I.NE.KSCHUR ) $ T( IT+LDT( I )+1 ) = ZERO 200 CONTINUE C C Exit direct swap N1 = 2 and N2 = 1. C GOTO 290 C C Direct swap with N1 = 2 and N2 = 2. C 210 CONTINUE C C Generate elementary reflectors H(1)_i and H(2)_i such that C C H(2)_i H(1)_i ( X_11_i X_12_i ) = ( * * ). C ( X_21_i X_22_i ) ( 0 * ) C ( scale 0 ) ( 0 0 ) C ( 0 scale ) ( 0 0 ) C INDXC = C ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 C DO 220 ITAU1 = TAU1, TAU1 + K - 1 X_11 = DWORK( INDXC ) X_21 = DWORK( INDXC+1 ) X_12 = DWORK( INDXC+2 ) X_22 = DWORK( INDXC+3 ) C C Compute elementary reflector H(1)_i. C DWORK( INDV1 ) = X_11 DWORK( INDV1+1 ) = X_21 DWORK( INDV1+2 ) = SCALOC CALL DLARFG( 3, DWORK( INDV1 ), DWORK( INDV1+1 ), 1, $ DWORK( ITAU1 ) ) DWORK( INDV1 ) = ONE C C Compute elementary reflector H(2)_i. C DWORK( INDV2 ) = X_12 DWORK( INDV2+1 ) = X_22 DWORK( INDV2+2 ) = ZERO CALL DLARFX( 'Left', 3, 1, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDV2 ), 3, DWORK( W ) ) DWORK( INDV2 ) = DWORK( INDV2+1 ) DWORK( INDV2+1 ) = DWORK( INDV2+2 ) DWORK( INDV2+2 ) = SCALOC CALL DLARFG( 3, DWORK( INDV2 ), DWORK( INDV2+1 ), 1, $ DWORK( ITAU2 ) ) DWORK( INDV2 ) = ONE C C Next, do weak stability test: check that C ||QQ_11_i - X_i * QQ_21_i||_F <= tol, i = 1, ...,K, C where QQ_i = H(1)_i * H(2)_i. C V_2 = DWORK( INDV1+1 ) V_3 = DWORK( INDV1+2 ) W_2 = DWORK( INDV2+1 ) W_3 = DWORK( INDV2+2 ) DTAU1 = DWORK( ITAU1 ) DTAU2 = DWORK( ITAU2 ) TEMP( 1 ) = SCALOC*( ONE - DTAU1 ) + X_11*DTAU1*V_3 TEMP( 3 ) = SCALOC*( DTAU2*W_2*DTAU1*V_3 - $ DTAU1*V_2*( ONE - DTAU2 ) ) - $ X_11*( -DTAU1*V_2*V_3*( ONE - DTAU2 ) - $ ( ONE - DTAU1*V_3**2 )*DTAU2*W_2 ) + X_12*DTAU2*W_3 TEMP( 2 ) = -SCALOC*DTAU1*V_2 + X_21*DTAU1*V_3 TEMP( 4 ) = SCALOC*( ( ONE - DTAU1*V_2**2 )*( ONE - DTAU2 ) + $ DTAU1*V_2*V_3*DTAU2*W_2 ) - $ X_21*( -DTAU1*V_2*V_3*( ONE - DTAU2 ) - $ ( ONE - DTAU1*V_3**2 )*DTAU2*W_2 ) + X_22*DTAU2*W_3 IF( DLANGE( 'Frobenius', 2, 2, TEMP, 2, DWORK ).GT.THRESH ) $ GO TO 300 INDXC = INDXC + 4 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 220 CONTINUE C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace). C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 INDTT = TT LTT = 4 C DO 230 I = 1, K IP1 = MOD( I, K ) IV1P1 = V1 + IP1 * 3 IV2P1 = V2 + IP1 * 3 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 CALL DLACPY( 'All', 4, 4, T( IWORK( I11+I ) ), LDT( I ), $ DWORK( INDTT ), 4 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 4, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+1 ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+4 ), 4, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 4, 3, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+4 ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+1), 4, DWORK( W ) ) END IF ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 INDTT = INDTT + 16 230 CONTINUE C C Check for fill-in elements. C FILLIN = .FALSE. FILL21 = .FALSE. INDTT = TT + 1 DO 240 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH ) THEN FILLIN = .TRUE. FILL21 = .TRUE. END IF INDTT = INDTT + 16 240 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 1, S, DWORK( TT ), LTT, $ DWORK( VLOC1 ), DWORK( LTAU1 ) ) END IF C C Check for fill-in elements again. C FILLIN = .FALSE. FILL43 = .FALSE. INDTT = TT + 11 DO 250 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.EPS ) THEN FILLIN = .TRUE. FILL43 = .TRUE. END IF INDTT = INDTT + 16 250 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 3, S, DWORK( TT ), LTT, $ DWORK( VLOC2 ), DWORK( LTAU2 ) ) END IF C IF( WS ) THEN C C Perform strong stability test. C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 INDTT = TT IF( FILLIN ) THEN ITAUF1 = LTAU1 ITAUF2 = LTAU2 INDF1 = VLOC1 INDF2 = VLOC2 END IF C DO 260 I = 1, K IP1 = MOD( I, K ) CALL DLACPY( 'All', 4, 4, DWORK( INDTT ), 4, TEMPM1, 4 ) C C Apply possible transformations from fill-in removal. C IF( FILLIN ) THEN IV1P1 = VLOC1 + IP1 * 2 IV2P1 = VLOC2 + IP1 * 2 TAU1P1 = LTAU1 + IP1 TAU2P1 = LTAU2 + IP1 C C Apply on top-left 2-by-2 block. C IF( FILL21 ) THEN IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 4, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) $ ) CALL DLARFX( 'Right', 2, 2, DWORK( INDF1 ), $ DWORK( ITAUF1 ), TEMPM1, 4, DWORK( W ) $ ) ELSE CALL DLARFX( 'Right', 2, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) $ ) CALL DLARFX( 'Left', 2, 4, DWORK( INDF1 ), $ DWORK( ITAUF1 ), TEMPM1, 4, DWORK( W ) $ ) END IF END IF C C Apply on down-right 2-by-2 block. C IF( FILL43 ) THEN IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 11 ), 4, $ DWORK( W ) ) CALL DLARFX( 'Right', 4, 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), TEMPM1( 9 ), 4, $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', 4, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 9 ), 4, $ DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), TEMPM1( 11 ), 4, $ DWORK( W ) ) END IF END IF END IF C C Take the "large" transformations. C IV1P1 = V1 + IP1 * 3 IV2P1 = V2 + IP1 * 3 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 C C Apply H(2)_i+1, H(1)_i+1, H(2)_i, H(1)_i from left or right C depending on S. C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 4, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 2 ), 4, DWORK( W ) $ ) CALL DLARFX( 'Left', 3, 4, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 5 ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 4, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 4, 3, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 5 ), 4, DWORK( W ) $ ) CALL DLARFX( 'Right', 4, 3, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 2 ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 4, DWORK( W ) ) END IF C C Compute residual norm. C CALL DLACPY( 'All', 4, 4, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 4 ) CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 4, 4, TEMPM1, 4, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 INDTT = INDTT + 16 IF( FILLIN ) THEN ITAUF1 = ITAUF1 + 1 ITAUF2 = ITAUF2 + 1 INDF1 = INDF1 + 2 INDF2 = INDF2 + 2 END IF 260 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 IF( FILLIN ) THEN ITAUF1 = LTAU1 ITAUF2 = LTAU2 INDF1 = VLOC1 INDF2 = VLOC2 END IF C DO 270 I = 1, K IP1 = MOD( I, K ) IPP = IP1 + 1 IT = IWORK( I11+I ) - J1 + 1 C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C IV1P1 = V1 + IP1 * 3 IV2P1 = V2 + IP1 * 3 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 C IF( S( I ).EQ.1 ) THEN IT = IT - NI( IPP ) IT2 = IT + LDT( I ) CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IWORK( I11+I )+1 ), $ LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J4, 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IT ), LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J4, 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) ELSE IT = IT - NI( I ) IT2 = IT + LDT( I ) CALL DLARFX( 'Right', NI( I )+J4, 3, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), DWORK( W ) $ ) CALL DLARFX( 'Right', NI( I )+J4, 3, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) CALL DLARFX( 'Left', 3, N( IPP )-J1+1, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 3, N( IPP )-J1+1, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IWORK( I11+I )+1 ), $ LDT( I ), DWORK( W ) ) END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) IQ = IQ + LDQ( I ) CALL DLARFX( 'Right', N( I ), 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF C C Apply Householder transformations from fill-in removal and C accumulate transformations. C IF ( FILLIN ) THEN IV1P1 = VLOC1 + IP1 * 2 IV2P1 = VLOC2 + IP1 * 2 TAU1P1 = LTAU1 + IP1 TAU2P1 = LTAU2 + IP1 C IF( FILL21 ) THEN IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J2, 2, DWORK( INDF1 ), $ DWORK( ITAUF1 ), T( IT ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IPP )-J1+1, DWORK( INDF1 ), $ DWORK( ITAUF1 ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) END IF END IF C IF( FILL43 ) THEN IT = IWORK( I22+I ) IT2 = IT2 + LDT( I ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J4, 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), T( IT2 ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', NI( I )+J4, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT2 ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IPP )-J2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), T( IT ), LDT( I ), $ DWORK( W ) ) END IF END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IF( FILL21 ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDF1 ), $ DWORK( ITAUF1 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF IF( FILL43 ) THEN IQ = IXQ( I ) + J2*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF END IF END IF ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 IF( FILLIN ) THEN ITAUF1 = ITAUF1 + 1 ITAUF2 = ITAUF2 + 1 INDF1 = INDF1 + 2 INDF2 = INDF2 + 2 END IF 270 CONTINUE C C Set to zero the fill-in elements below the main diagonal. C DO 280 I = 1, K IT = IWORK( I21+I ) T( IT ) = ZERO T( IT+1 ) = ZERO IT = IT + LDT( I ) T( IT ) = ZERO T( IT+1 ) = ZERO IF( I.NE.KSCHUR ) THEN T( IWORK( I11+I )+1 ) = ZERO T( IWORK( I22+I )+1 ) = ZERO END IF 280 CONTINUE C C Exit direct swap N1 = 2 and N2 = 2. C C Normal exit. C 290 CONTINUE C C Store optimal workspace values and return. C DWORK( 1 ) = DBLE( MINWRK ) RETURN C C Exit with INFO = 1 if swap was rejected. C 300 CONTINUE INFO = 1 RETURN C C *** Last line of MB03KB *** END slicot-5.0+20101122/src/MB03KC.f000077500000000000000000000212031201767322700153640ustar00rootroot00000000000000 SUBROUTINE MB03KC( K, KHESS, N, R, S, A, LDA, V, TAU ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 2-by-2 general, formal matrix product A of length K, C C A_K^s(K) * A_K-1^s(K-1) * ... * A_1^s(1), C C to the periodic Hessenberg-triangular form using a K-periodic C sequence of elementary reflectors (Householder matrices). The C matrices A_k, k = 1, ..., K, are stored in the N-by-N-by-K array A C starting in the R-th row and column, and N can be 3 or 4. C C Each elementary reflector H_k is represented as C C H_k = I - tau_k * v_k * v_k', (1) C C where I is the 2-by-2 identity, tau_k is a real scalar, and v_k is C a vector of length 2, k = 1,...,K, and it is constructed such that C the following holds for k = 1,...,K: C C H_{k+1} * A_k * H_k = T_k, if s(k) = 1, C (2) C H_k * A_k * H_{k+1} = T_k, if s(k) = -1, C C with H_{K+1} = H_1 and all T_k upper triangular except for C T_{khess} which is full. Clearly, C C T_K^s(K) *...* T_1^s(1) = H_1 * A_K^s(K) *...* A_1^s(1) * H_1. C C The reflectors are suitably applied to the whole, extended N-by-N C matrices Ae_k, not only to the submatrices A_k, k = 1, ..., K. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of matrices in the sequence A_k. K >= 2. C C KHESS (input) INTEGER C The index for which the returned matrix A_khess should be C in the Hessenberg form on output. 1 <= KHESS <= K. C C N (input) INTEGER C The order of the extended matrices. N = 3 or N = 4. C C R (input) INTEGER C The starting row and column index for the C 2-by-2 submatrices. R = 1, or R = N-1. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures of the factors. Each entry in S must be either C 1 or -1; the value S(k) = -1 corresponds to using the C inverse of the factor A_k. C C A (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXA(k) = C (k-1)*N*LDA+1 the N-by-N matrix Ae_k stored with leading C dimension LDA. C On exit, this array contains at position IXA(k) the C N-by-N matrix Te_k stored with leading dimension LDA. C C LDA INTEGER C Leading dimension of the matrices Ae_k and Te_k in the C one-dimensional array A. LDA >= N. C C V (output) DOUBLE PRECISION array, dimension (2*K) C On exit, this array contains the K vectors v_k, C k = 1,...,K, defining the elementary reflectors H_k as C in (1). The k-th reflector is stored in V(2*k-1:2*k). C C TAU (output) DOUBLE PRECISION array, dimension (K) C On exit, this array contains the K values of tau_k, C k = 1,...,K, defining the elementary reflectors H_k C as in (1). C C METHOD C C A K-periodic sequence of elementary reflectors (Householder C matrices) is used. The computations start for k = khess with the C left reflector in (1), which is the identity matrix. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, an essentially new version of the PEP routine C PEP_DGEHR2, by R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Apr. 2010, May 2010. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. INTEGER K, KHESS, LDA, N, R C .. C .. Array Arguments .. INTEGER S( * ) DOUBLE PRECISION A( * ), TAU( * ), V( * ) C .. C .. Local Scalars .. INTEGER I, I1, I2, IC, INC, IP1, IR, IX, NO C .. C .. Local Arrays .. DOUBLE PRECISION TMP( 1 ), WORK( 2 ) C .. C .. External Subroutines .. EXTERNAL DLARFG, DLARFX C .. C .. Intrinsic Functions .. INTRINSIC MOD C .. C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C C Compute the periodic Hessenberg form of A with the Hessenberg C matrix at position KHESS - start construction from I = KHESS, C i.e., to the left of (and including) the Hessenberg matrix in the C corresponding matrix product. C C Since the problem is 2-by-2, the orthogonal matrix working on C A_{khess} from the left, if s(khess) = 1, or from the right, C if s(khess) = -1, hence H_{khess+1}, will be the identity. C IR = ( R - 1 )*LDA IC = IR + R - 1 NO = N - R INC = N*LDA I1 = KHESS*INC + 1 IP1 = MOD( KHESS, K ) + 1 C TAU( IP1 ) = ZERO V( 2*IP1-1 ) = ZERO V( 2*IP1 ) = ZERO C DO 10 I = KHESS + 1, K IP1 = MOD( I, K ) IX = I1 + IC I2 = IP1*INC + 1 IP1 = IP1 + 1 C C Compute and apply the reflector H_{i+1} working on A_i^s(i) C from the left. C IF( S( I ).EQ.1 ) THEN WORK( 1 ) = ONE WORK( 2 ) = A( IX+1 ) CALL DLARFG( 2, A( IX ), WORK( 2 ), 1, TAU( IP1 ) ) V( 2*IP1-1 ) = ONE V( 2*IP1 ) = WORK( 2 ) CALL DLARFX( 'Left', 2, NO, WORK, TAU( IP1 ), A( IX+LDA ), $ LDA, TMP ) ELSE WORK( 1 ) = A( IX+1 ) WORK( 2 ) = ONE CALL DLARFG( 2, A( IX+LDA+1 ), WORK, 1, TAU( IP1 ) ) V( 2*IP1-1 ) = WORK( 1 ) V( 2*IP1 ) = ONE CALL DLARFX( 'Right', R, 2, WORK, TAU( IP1 ), A( I1+IR ), $ LDA, TMP ) END IF A( IX+1 ) = ZERO C C Apply the reflector to A_{mod(i,K)+1}. C IF( S( IP1 ).EQ.1 ) THEN CALL DLARFX( 'Right', R+1, 2, WORK, TAU( IP1 ), A( I2+IR ), $ LDA, TMP ) ELSE CALL DLARFX( 'Left', 2, NO+1, WORK, TAU( IP1 ), A( I2+IC ), $ LDA, TMP ) END IF I1 = I1 + INC 10 CONTINUE C C Continue to the right of the Hessenberg matrix. C I1 = 1 C DO 20 I = 1, KHESS - 1 IP1 = MOD( I, K ) IX = I1 + IC I2 = IP1*INC + 1 IP1 = IP1 + 1 C C Compute and apply the reflector H_{i+1} working on A_i^s(i) C from the left. C IF( S( I ).EQ.1 ) THEN WORK( 1 ) = ONE WORK( 2 ) = A( IX+1 ) CALL DLARFG( 2, A( IX ), WORK( 2 ), 1, TAU( IP1 ) ) V( 2*IP1-1 ) = ONE V( 2*IP1 ) = WORK( 2 ) CALL DLARFX( 'Left', 2, NO, WORK, TAU( IP1 ), A( IX+LDA ), $ LDA, TMP ) ELSE WORK( 1 ) = A( IX+1 ) WORK( 2 ) = ONE CALL DLARFG( 2, A( IX+LDA+1 ), WORK, 1, TAU( IP1 ) ) V( 2*IP1-1 ) = WORK( 1 ) V( 2*IP1 ) = ONE CALL DLARFX( 'Right', R, 2, WORK, TAU( IP1 ), A( I1+IR ), $ LDA, TMP ) END IF A( IX+1 ) = ZERO C C Apply the reflector to A_{mod(i,K)+1}. C IF( S( IP1 ).EQ.1 ) THEN CALL DLARFX( 'Right', R+1, 2, WORK, TAU( IP1 ), A( I2+IR ), $ LDA, TMP ) ELSE CALL DLARFX( 'Left', 2, NO+1, WORK, TAU( IP1 ), A( I2+IC ), $ LDA, TMP ) END IF I1 = I1 + INC 20 CONTINUE C C The periodic Hessenberg-triangular form has been computed. C RETURN C C *** Last line of MB03KC *** END slicot-5.0+20101122/src/MB03KD.f000077500000000000000000000450471201767322700154010ustar00rootroot00000000000000 SUBROUTINE MB03KD( COMPQ, WHICHQ, STRONG, K, NC, KSCHUR, N, NI, S, $ SELECT, T, LDT, IXT, Q, LDQ, IXQ, M, TOL, $ IWORK, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 formal matrix product C C T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1), (1) C C of length K, in the generalized periodic Schur form, C C [ T11_k T12_k T13_k ] C T_k = [ 0 T22_k T23_k ], k = 1, ..., K, (2) C [ 0 0 T33_k ] C C where C C - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or C NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced C infinite eigenvalues, C - the submatrices T22_k are NC-by-NC and contain core eigenvalues, C which are generically neither zero nor infinite, C - the submatrices T33_k contain dimension-induced zero C eigenvalues, C C such that the M selected eigenvalues pointed to by the logical C vector SELECT end up in the leading part of the matrix sequence C T22_k. C C Given that N(k) = N(k+1) for all k where S(k) = -1, the T11_k are C void and the first M columns of the updated orthogonal C transformation matrix sequence Q_1, ..., Q_K span a periodic C deflating subspace corresponding to the same eigenvalues. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrices Q_k, as follows: C = 'N': do not compute any of the matrices Q_k; C = 'I': each coefficient of Q is initialized internally to C the identity matrix, and the orthogonal matrices C Q_k are returned, where Q_k, k = 1, ..., K, C performed the reordering; C = 'U': each coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the products Q1_k*Q_k are C returned; C = 'W': the computation of each Q_k is specified C individually in the array WHICHQ. C C WHICHQ INTEGER array, dimension (K) C If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k C as follows: C = 0: do not compute Q_k; C = 1: the kth coefficient of Q is initialized to the C identity matrix, and the orthogonal matrix Q_k is C returned; C = 2: the kth coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the product Q1_k*Q_k is C returned. C This array is not referenced if COMPQ <> 'W'. C C STRONG CHARACTER*1 C Specifies whether to perform the strong stability tests, C as follows: C = 'N': do not perform the strong stability tests; C = 'S': perform the strong stability tests; often, this is C not needed, and omitting them can save some C computations. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences T and Q (the C number of factors in the matrix product). K >= 2. C (For K = 1, a standard eigenvalue reordering problem is C obtained.) C C NC (input) INTEGER C The number of core eigenvalues. 0 <= NC <= min(N). C C KSCHUR (input) INTEGER C The index for which the matrix T22_kschur is upper quasi- C triangular. All other T22 matrices are upper triangular. C C N (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the formal matrix product T, C such that the k-th coefficient T_k is an N(k+1)-by-N(k) C matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix, C if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1). C C NI (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the matrix sequence T11_k. C N(k) >= NI(k) + NC >= 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequence. Each entry in S must be either 1 or -1; C the value S(k) = -1 corresponds to using the inverse of C the factor T_k. C C SELECT (input) LOGICAL array, dimension (NC) C SELECT specifies the eigenvalues in the selected cluster. C To select a real eigenvalue w(j), SELECT(j) must be set to C .TRUE.. To select a complex conjugate pair of eigenvalues C w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, C either SELECT(j) or SELECT(j+1) or both must be set to C .TRUE.; a complex conjugate pair of eigenvalues must be C either both included in the cluster or both excluded. C C T (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXT(k) the C matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1, C or at least N(k)-by-N(k+1), if S(k) = -1, in periodic C Schur form. C On exit, the matrices T_k are overwritten by the reordered C periodic Schur form. C C LDT INTEGER array, dimension (K) C The leading dimensions of the matrices T_k in the one- C dimensional array T. C LDT(k) >= max(1,N(k+1)), if S(k) = 1, C LDT(k) >= max(1,N(k)), if S(k) = -1. C C IXT INTEGER array, dimension (K) C Start indices of the matrices T_k in the one-dimensional C array T. C C Q (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXQ(k) a C matrix Q_k of size at least N(k)-by-N(k), provided that C COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) = 2. C On exit, if COMPQ = 'I' or COMPQ = 'W' and WHICHQ(k) = 1, C Q_k contains the orthogonal matrix that performed the C reordering. If COMPQ = 'U', or COMPQ = 'W' and C WHICHQ(k) = 2, Q_k is post-multiplied with the orthogonal C matrix that performed the reordering. C This array is not referenced if COMPQ = 'N'. C C LDQ INTEGER array, dimension (K) C The leading dimensions of the matrices Q_k in the one- C dimensional array Q. C LDQ(k) >= max(1,N(k)), if COMPQ = 'I', or COMPQ = 'U', or C COMPQ = 'W' and WHICHQ(k) > 0; C This array is not referenced if COMPQ = 'N'. C C IXQ INTEGER array, dimension (K) C Start indices of the matrices Q_k in the one-dimensional C array Q. C This array is not referenced if COMPQ = 'N'. C C M (output) INTEGER C The number of selected core eigenvalues which were C reordered to the top of T22_k. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance parameter c. The weak and strong stability C tests performed for checking the reordering use a C threshold computed by the formula MAX(c*EPS*NRM, SMLNUM), C where NRM is the varying Frobenius norm of the matrices C formed by concatenating K pairs of adjacent diagonal C blocks of sizes 1 and/or 2 in the T22_k submatrices from C (2), which are swapped, and EPS and SMLNUM are the machine C precision and safe minimum divided by EPS, respectively C (see LAPACK Library routine DLAMCH). The value c should C normally be at least 10. C C Workspace C C IWORK INTEGER array, dimension (4*K) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 10*K + MN, if all blocks involved in reordering C have order 1; C LDWORK >= 25*K + MN, if there is at least a block of C order 2, but no adjacent blocks of C order 2 are involved in reordering; C LDWORK >= MAX(42*K + MN, 80*K - 48), if there is at least C a pair of adjacent blocks of order 2 C involved in reordering; C where MN = MXN, if MXN > 10, and MN = 0, otherwise, with C MXN = MAX(N(k),k=1,...,K). C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 = 1: the reordering of T failed because some eigenvalues C are too close to separate (the problem is very ill- C conditioned); T may have been partially reordered. C C METHOD C C An adaptation of the LAPACK Library routine DTGSEN is used. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, SLICOT Library version of the PEP routine PEP_DTGSEN. C V. Sima, July, 2010. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, periodic C Sylvester-like equations, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER COMPQ, STRONG INTEGER INFO, K, KSCHUR, LDWORK, M, NC DOUBLE PRECISION TOL C .. C .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ), $ LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * ) DOUBLE PRECISION DWORK( * ), Q( * ), T( * ) C .. C .. Local Scalars .. CHARACTER COMPQC LOGICAL INITQ, PAIR, SPECQ, SWAP, WANTQ, WANTQL, WS INTEGER I, IP1, IT, L, LL, LS, MAXN, MINK, MINN, $ MINSUM, MNWORK, NKP1, SUMD C .. C .. Local Arrays .. DOUBLE PRECISION TOLA( 3 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. C .. External Subroutines .. EXTERNAL DLASET, MB03KA, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MOD C .. C .. Local Functions .. INTEGER INDP1 INDP1( I, K ) = MOD( I, K ) + 1 C .. C .. Executable Statements .. C C Decode and test the input parameters. C INFO = 0 INITQ = LSAME( COMPQ, 'I' ) WANTQ = LSAME( COMPQ, 'U' ) .OR. INITQ SPECQ = LSAME( COMPQ, 'W' ) WS = LSAME( STRONG, 'S' ) C C Test all input arguments. C IF( K.LT.2 ) THEN INFO = -4 C C Check options for generating orthogonal factors. C ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. WANTQ .OR. SPECQ ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( STRONG, 'N' ) .OR. WS ) ) THEN INFO = -3 ELSE IF( TOL.LE.ZERO ) THEN INFO = -18 END IF IF( INFO.EQ.0 .AND. SPECQ ) THEN DO 10 L = 1, K IF( WHICHQ(L).LT.0 .OR. WHICHQ(L).GT.2 ) $ INFO = -2 10 CONTINUE END IF C C Check whether any of the dimensions is negative. C At the same time the sequence of consecutive sums of dimension C differences is formed and its minimum is determined. C Also, the maximum of all dimensions is computed. C IF( INFO.EQ.0 ) THEN SUMD = 0 MINK = K MINSUM = 0 MAXN = 0 MINN = N(K) C DO 20 L = 1, K IF( L.LT.K .AND. N(L).LT.MINN ) $ MINN = N(L) NKP1 = N(INDP1(L,K)) IF ( N(L).LT.0 ) $ INFO = -7 IF ( S(L).EQ.-1 ) $ SUMD = SUMD + ( NKP1 - N(L) ) IF ( SUMD.LT.MINSUM ) THEN MINSUM = SUMD MINK = L END IF MAXN = MAX( MAXN, N(L) ) C C Check the condition N(l) >= NI(l) + NC >= 0. C IF( INFO.EQ.0 .AND. ( N(L).LT.NI(L)+NC .OR. NI(L).LT.0 ) ) $ INFO = -8 20 CONTINUE END IF C C Check the condition 0 <= NC <= min(N). C IF( INFO.EQ.0 .AND. ( NC.LT.0 .OR. NC.GT.MINN ) ) $ INFO = -5 C C Check KSCHUR. C IF( INFO.EQ.0 .AND. ( KSCHUR.LT.1 .OR. KSCHUR.GT.K ) ) $ INFO = -6 C C Check that the complete sum is zero; otherwise T is singular. C IF( INFO.EQ.0 .AND. SUMD.NE.0 ) $ INFO = -7 C C Check signatures. C IF( INFO.EQ.0 ) THEN DO 30 L = 1, K IF( ABS( S(L) ).NE.1 ) $ INFO = -9 30 CONTINUE END IF C C Check the leading dimensions of T_k. C IF( INFO.EQ.0 ) THEN DO 40 L = 1, K NKP1 = N(INDP1(L,K)) IF ( S(L).EQ.1 ) THEN IF ( LDT(L).LT.MAX( 1, NKP1 ) ) $ INFO = -12 ELSE IF ( LDT(L).LT.MAX( 1, N(L) ) ) $ INFO = -12 END IF 40 CONTINUE END IF C C Check the leading dimensions of Q_k. C IF( INFO.EQ.0 .AND. ( WANTQ .OR. SPECQ ) ) THEN DO 50 L = 1, K WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ(L).NE.0 IF ( WANTQL ) THEN IF ( LDQ( L ).LT.MAX( 1, N(L) ) ) $ INFO = -15 END IF 50 CONTINUE END IF C C Set M to the dimension of the specified periodic invariant C subspace. C M = 0 I = KSCHUR PAIR = .FALSE. IP1 = INDP1( I, K ) DO 70 L = 1, NC IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( L.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + L - 1 )*LDT(I) + NI(IP1) + L ELSE IT = IXT(I) + ( NI(IP1) + L - 1 )*LDT(I) + NI(I) + L END IF IF( T(IT).EQ.ZERO ) THEN IF( SELECT( L ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( L ) .OR. SELECT( L+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( NC ) ) $ M = M + 1 END IF END IF 70 CONTINUE C C Set COMPQ for MB03KA, if needed. C IF( INITQ ) THEN COMPQC = 'U' ELSE COMPQC = COMPQ END IF C C Check workspace. C IF( INFO.EQ.0 ) THEN CALL MB03KA( COMPQC, WHICHQ, WS, K, NC, KSCHUR, 1, 1, N, NI, S, $ T, LDT, IXT, Q, LDQ, IXQ, DWORK, IWORK, DWORK, -1, $ INFO ) MNWORK = MAX( 1, INT( DWORK(1) ) ) IF( LDWORK.NE.-1 .AND. LDWORK.LT.MNWORK ) $ INFO = -21 END IF C C Quick return if possible. C IF( LDWORK.EQ.-1 ) THEN DWORK(1) = DBLE( MNWORK ) RETURN ELSE IF( INFO.LT.0 ) THEN CALL XERBLA( 'MB03KD', -INFO ) RETURN END IF C C Compute some machine-dependent parameters. C TOLA( 1 ) = TOL TOLA( 2 ) = DLAMCH( 'Precision' ) TOLA( 3 ) = DLAMCH( 'Safe minimum' ) / TOLA( 2 ) C C Initialization of orthogonal factors. C DO 80 L = 1, K IF ( SPECQ ) $ INITQ = WHICHQ(L).EQ.1 IF ( INITQ ) $ CALL DLASET( 'All', N(L), N(L), ZERO, ONE, Q( IXQ( L ) ), $ LDQ( L ) ) 80 CONTINUE C C Collect the selected blocks at the top-left corner of T22_k. C LS = 0 PAIR = .FALSE. I = KSCHUR IP1 = INDP1( I, K ) DO 90 L = 1, NC IF( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT( L ) IF( L.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + L - 1 )*LDT(I) + NI(IP1) + L ELSE IT = IXT(I) + ( NI(IP1) + L - 1 )*LDT(I) + NI(I) + L END IF IF( T(IT).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( L+1 ) END IF END IF IF( SWAP ) THEN LS = LS + 1 C C Swap the L-th block to position LS in T22_k. C LL = L IF( L.NE.LS ) THEN CALL MB03KA( COMPQC, WHICHQ, WS, K, NC, KSCHUR, LL, $ LS, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOLA, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN C C Blocks too close to swap; exit. C GO TO 100 END IF END IF IF( PAIR ) $ LS = LS + 1 END IF END IF 90 CONTINUE C 100 CONTINUE C C Store optimal workspace length and return. C DWORK(1) = DBLE( MNWORK ) RETURN C C *** Last line of MB03KD *** END slicot-5.0+20101122/src/MB03KE.f000077500000000000000000000703641201767322700154020ustar00rootroot00000000000000 SUBROUTINE MB03KE( TRANA, TRANB, ISGN, K, M, N, PREC, SMIN, S, A, $ B, C, SCALE, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 small periodic Sylvester-like equations (PSLE) C C op(A(i))*X( i ) + isgn*X(i+1)*op(B(i)) = -scale*C(i), S(i) = 1, C op(A(i))*X(i+1) + isgn*X( i )*op(B(i)) = -scale*C(i), S(i) = -1. C C i = 1, ..., K, where op(A) means A or A**T, for the K-periodic C matrix sequence X(i) = X(i+K), where A, B and C are K-periodic C matrix sequences and A and B are in periodic real Schur form. The C matrices A(i) are M-by-M and B(i) are N-by-N, with 1 <= M, N <= 2. C C ARGUMENTS C C Mode Parameters C C TRANA LOGICAL C Specifies the form of op(A) to be used, as follows: C = .FALSE.: op(A) = A, C = .TRUE. : op(A) = A**T. C C TRANB LOGICAL C Specifies the form of op(B) to be used, as follows: C = .FALSE.: op(B) = B, C = .TRUE. : op(B) = B**T. C C ISGN INTEGER C Specifies which sign variant of the equations to solve. C ISGN = 1 or ISGN = -1. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences A, B, C and X. C K >= 2. (For K = 1, a standard Sylvester equation is C obtained.) C C M (input) INTEGER C The order of the matrices A(i) and the number of rows of C the matrices C(i) and X(i), i = 1, ..., K. 1 <= M <= 2. C C N (input) INTEGER C The order of the matrices B(i) and the number of columns C of the matrices C(i) and X(i), i = 1, ..., K. C 1 <= N <= 2. C C PREC (input) DOUBLE PRECISION C The relative machine precision. See the LAPACK Library C routine DLAMCH. C C SMIN (input) DOUBLE PRECISION C The machine safe minimum divided by PREC. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequences for A and B. Each entry in S must be C either 1 or -1. Notice that it is assumed that the same C exponents are tied to both A and B on reduction to the C periodic Schur form. C C A (input) DOUBLE PRECISION array, dimension (M*M*K) C On entry, this array must contain the M-by-M matrices C A(i), for i = 1, ..., K, stored with the leading dimension C M. Matrix A(i) is stored starting at position M*M*(i-1)+1. C C B (input) DOUBLE PRECISION array, dimension (N*N*K) C On entry, this array must contain the N-by-N matrices C B(i), for i = 1, ..., K, stored with the leading dimension C N. Matrix B(i) is stored starting at position N*N*(i-1)+1. C C C (input/output) DOUBLE PRECISION array, dimension (M*N*K) C On entry, this array must contain the M-by-N matrices C C(i), for i = 1, ..., K, stored with the leading dimension C M. Matrix C(i) is stored starting at position M*N*(i-1)+1. C On exit, the matrices C(i) are overwritten by the solution C sequence X(i). C C SCALE (output) DOUBLE PRECISION C The scale factor, scale, set less than or equal to 1 to C avoid overflow in X. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -21, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= (4*K-3) * (M*N)**2 + K * M*N. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -21, then LDWORK is too small; appropriate C value for LDWORK is returned in DWORK(1); the other C arguments are not tested, for efficiency; C = 1: the solution would overflow with scale = 1, so C SCALE was set less than 1. This is a warning, not C an error. C C METHOD C C A version of the algorithm described in [1] is used. The routine C uses a sparse Kronecker product representation Z of the PSLE and C solves for X(i) from an associated linear system Z*x = c using C structured (overlapping) variants of QR factorization and backward C substitution. C C REFERENCES C C [1] Granat, R., Kagstrom, B. and Kressner, D. C Computing periodic deflating subspaces associated with a C specified set of eigenvalues. C BIT Numerical Mathematics, vol. 47, 763-791, 2007. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, an essentially new version of the PEP routine C PEP_DGESY2, by R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Apr. 2010, Oct. 2010. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, periodic C Sylvester-like equations, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C .. C .. Scalar Arguments .. LOGICAL TRANA, TRANB INTEGER INFO, ISGN, K, LDWORK, M, N DOUBLE PRECISION PREC, SCALE, SMIN C .. C .. Array Arguments .. INTEGER S( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), DWORK( * ) C .. C .. Local Scalars .. LOGICAL DOSCAL, LQUERY INTEGER CB, EYE, I, IA1, IA3, IB1, IB3, IC1, IDENOM, $ II, IM1, INUM, IXA, IXB, IXC, IZ, J, JJ, KM2, $ KM3, KMN, L, LDW, LEN, MINWRK, MM, MN, MN6, $ MN7, NN, ZC, ZD, ZI, ZI2, ZIS DOUBLE PRECISION AC, AD, BETA, BIGNUM, DMIN, ELEM, SCALOC, SGN, $ SPIV, TAU, TEMP C .. C .. External Functions .. INTEGER IDAMAX C .. C .. External Subroutines .. EXTERNAL DAXPY, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, MOD C .. C .. Executable Statements .. C C Decode the input parameters. C For efficiency reasons, the parameters are not checked. C INFO = 0 LQUERY = LDWORK.EQ.-1 C MN = M*N KMN = K*MN C MINWRK = ( 4*K - 3 ) * MN**2 + KMN IF( .NOT. LQUERY .AND. LDWORK.LT.MINWRK ) $ INFO = -21 C C Quick return if possible. C DWORK( 1 ) = DBLE( MINWRK ) IF( LQUERY ) THEN RETURN ELSE IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03KE', -INFO ) RETURN END IF C C Find the overflow threshold. C BIGNUM = PREC / SMIN C C --- Use QR-factorizations and backward substitution --- C C This variant does not utilize the sparsity structure of the C individual blocks of the matrix Z - storage of each block Z_i,i C is compatible with the BLAS. Numerics is stable since excessive C pivot growth is avoided. C MM = M*M NN = N*N SGN = DBLE( ISGN ) LDW = 3*MN IF( M.EQ.2 .AND. N.EQ.2 ) THEN MN6 = LDW + LDW MN7 = MN6 + LDW KM2 = KMN + KMN KM3 = KM2 + KMN END IF C C Divide workspace for superdiagonal + diagonal + subdiagonal blocks C and right-most block column stored in a "block-packed" format. For C simplicity, an additional block Z_{0,1} appears in the first block C column in Z. C ZD = 1 ZC = ZD + LDW*MN*( K - 1 ) C C Also give workspace for right hand side in CB. C CB = ZC + MN*KMN C C Fill the Z part of the workspace with zeros. C DO 10 J = 1, CB - 1 DWORK( J ) = ZERO 10 CONTINUE C C Build matrix Z in ZD and ZC. C IXA = 1 IXB = 1 IXC = 1 IM1 = K ZI = ZD + MN C DO 20 I = 1, K - 1 C C Build Z_{i,i}, i = 1,...,K-1. C IF( S( IM1 ).EQ.-1 ) THEN C IA1 = ( IM1 - 1 )*MM + 1 DWORK( ZI ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZI + 1 ) = A( IA1 + 1 ) DWORK( ZI + LDW ) = A( IA3 ) ELSE DWORK( ZI + 1 ) = A( IA3 ) DWORK( ZI + LDW ) = A( IA1 + 1 ) END IF DWORK( ZI + LDW + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZI + ( LDW + 1 )*M DWORK( ZI2 ) = DWORK( ZI ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZI + 1 ) DWORK( ZI2 + LDW ) = DWORK( ZI + LDW ) DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 ) END IF END IF C ELSE C IB1 = ( IM1 - 1 )*NN + 1 DWORK( ZI ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB3 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB1 + 1 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB3 ) DWORK( ZI + LDW ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB3 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW ) = SGN*B( IB3 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF END IF C END IF C C Build Z_{i+1,i}, i = 1,...,K-1. C ZI = ZI + MN IF( S( I ).EQ.1 ) THEN C IA1 = IXA DWORK( ZI ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZI + 1 ) = A( IA1 + 1 ) DWORK( ZI + LDW ) = A( IA3 ) ELSE DWORK( ZI + 1 ) = A( IA3 ) DWORK( ZI + LDW ) = A( IA1 + 1 ) END IF DWORK( ZI + LDW + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZI + ( LDW + 1 )*M DWORK( ZI2 ) = DWORK( ZI ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZI + 1 ) DWORK( ZI2 + LDW ) = DWORK( ZI + LDW ) DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 ) END IF END IF C ELSE C IB1 = IXB DWORK( ZI ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB3 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB1 + 1 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB3 ) DWORK( ZI + LDW ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB3 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW ) = SGN*B( IB3 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF END IF END IF C IXA = IXA + MM IXB = IXB + NN IM1 = I ZI = ZI + MN*( LDW - 1 ) 20 CONTINUE C C Build Z_{K,K}. C IXA = IXA - MM IXB = IXB - NN ZI = ZC + KMN - MN IF( S( K - 1 ).EQ.-1 ) THEN C IA1 = IXA DWORK( ZI ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZI + 1 ) = A( IA1 + 1 ) DWORK( ZI + KMN ) = A( IA3 ) ELSE DWORK( ZI + 1 ) = A( IA3 ) DWORK( ZI + KMN ) = A( IA1 + 1 ) END IF DWORK( ZI + KMN + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZI + ( KMN + 1 )*M DWORK( ZI2 ) = DWORK( ZI ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZI + 1 ) DWORK( ZI2 + KMN ) = DWORK( ZI + KMN ) DWORK( ZI2 + KMN + 1 ) = DWORK( ZI + KMN + 1 ) END IF END IF C ELSE C IB1 = IXB DWORK( ZI ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZI + KMN + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB3 ) DWORK( ZI + KMN + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + KM2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + KM3 + 1 ) = DWORK( ZI + KM2 ) DWORK( ZI + KM3 + 3 ) = DWORK( ZI + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB3 ) DWORK( ZI + KMN ) = SGN*B( IB1 + 1 ) DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZI + KMN + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + KMN + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + KM2 ) = SGN*B( IB3 ) DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + KM3 + 1 ) = DWORK( ZI + KM2 ) DWORK( ZI + KM3 + 3 ) = DWORK( ZI + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZI + KMN ) = SGN*B( IB3 ) DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF END IF END IF C C Build Z_{1,K}. C IF( S( K ).EQ.1 ) THEN C IA1 = IA1 + MM DWORK( ZC ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZC + 1 ) = A( IA1 + 1 ) DWORK( ZC + KMN ) = A( IA3 ) ELSE DWORK( ZC + 1 ) = A( IA3 ) DWORK( ZC + KMN ) = A( IA1 + 1 ) END IF DWORK( ZC + KMN + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZC + ( KMN + 1 )*M DWORK( ZI2 ) = DWORK( ZC ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZC + 1 ) DWORK( ZI2 + KMN ) = DWORK( ZC + KMN ) DWORK( ZI2 + KMN + 1 ) = DWORK( ZC + KMN + 1 ) END IF END IF C ELSE C IB1 = IB1 + NN DWORK( ZC ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZC + KMN + 1 ) = DWORK( ZC ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 2 ) = SGN*B( IB3 ) DWORK( ZC + KMN + 3 ) = DWORK( ZC + 2 ) DWORK( ZC + KM2 ) = SGN*B( IB1 + 1 ) DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZC + KM3 + 1 ) = DWORK( ZC + KM2 ) DWORK( ZC + KM3 + 3 ) = DWORK( ZC + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 1 ) = SGN*B( IB3 ) DWORK( ZC + KMN ) = SGN*B( IB1 + 1 ) DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZC + KMN + 1 ) = DWORK( ZC ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZC + KMN + 3 ) = DWORK( ZC + 2 ) DWORK( ZC + KM2 ) = SGN*B( IB3 ) DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZC + KM3 + 1 ) = DWORK( ZC + KM2 ) DWORK( ZC + KM3 + 3 ) = DWORK( ZC + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZC + KMN ) = SGN*B( IB3 ) DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF END IF END IF C C Prepare right hand side in CB. C ZI = CB + MN DO 30 L = 1, K - 1 IC1 = IXC DWORK( ZI ) = -C( IC1 ) IF( M.EQ.1 ) THEN IF( N.EQ.2 ) $ DWORK( ZI + 1 ) = -C( IC1 + 1 ) ELSE DWORK( ZI + 1 ) = -C( IC1 + 1 ) IF( N.EQ.2 ) THEN DWORK( ZI + 2 ) = -C( IC1 + 2 ) DWORK( ZI + 3 ) = -C( IC1 + 3 ) END IF END IF IXC = IXC + MN ZI = ZI + MN 30 CONTINUE C ZI = CB IC1 = IXC DWORK( ZI ) = -C( IC1 ) IF( M.EQ.1 ) THEN IF( N.EQ.2 ) $ DWORK( ZI + 1 ) = -C( IC1 + 1 ) ELSE DWORK( ZI + 1 ) = -C( IC1 + 1 ) IF( N.EQ.2 ) THEN DWORK( ZI + 2 ) = -C( IC1 + 2 ) DWORK( ZI + 3 ) = -C( IC1 + 3 ) END IF END IF C C Solve the Kronecker product system for X_i, i = 1,...,K C using overlapping (structured) QR-factorization and C backward substitution. C C Step 1: Reduce the system to triangular form via overlapping C QR-factorizations. C C The method here is based on successively formed C Householder reflections which are applied one by one C to the matrix Z and the right hand side c. The size C of each reflection is chosen as the number of elements C in each column from the last non-zero element up to C the diagonal. C C Notation: C L = current position of the column to work with; C I = corresponding block column in Z; C II = corresponding row and column position in Z-block; C LEN = length of the current Householder reflection. C I = 1 II = 0 ZIS = ZD + MN ZI2 = ZD + MN*LDW C C Treat Z_{K,K} separately from [Z_{i,i}',Z_{i+1,i}']' (see below). C DMIN is the minimum modulus of the final diagonal values. C DMIN = BIGNUM C DO 50 L = 1, KMN - MN II = II + 1 ZI = ZIS + 2*MN LEN = 2*MN - II + 1 C C REPEAT 40 CONTINUE ZI = ZI - 1 ELEM = DWORK( ZI ) IF( ELEM.EQ.ZERO ) THEN LEN = LEN - 1 GO TO 40 END IF C UNTIL ELEM.NE.ZERO. C IF( LEN.GT.1 ) THEN C C Generate Householder reflection to zero out the current C column. The new main diagonal value is stored temporarily C in BETA. C ZI = ZI - LEN + 1 CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU ) BETA = DWORK( ZI ) DWORK( ZI ) = ONE C C Apply reflection to Z and c: first to the rest of the C corresponding rows and columns of [Z_{i,i}',Z_{i+1,i}']' C of size LEN-by-(MN-II) ... C CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU, $ DWORK( ZI + LDW ), LDW, DWORK ) C C ... then to the corresponding part of C [Z_{i,i+1}',Z_{i+1,i+1}']' of size LEN-by-MN ... C IF( I.LT.K - 1 ) $ CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU, $ DWORK( ZI2 ), LDW, DWORK ) C C ... next to the corresponding part of C [Z_{i,K}',Z_{i+1,K}']' of size LEN-by-MN ... C CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU, $ DWORK( ZC + L - 1 ), KMN, DWORK ) C C ... and finally to c(L:L+LEN-1). C CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU, $ DWORK( CB + L - 1 ), KMN, DWORK ) C C Store the new diagonal value. C DWORK( ZI ) = BETA DMIN = MIN( DMIN, ABS( BETA ) ) END IF C ZIS = ZIS + LDW ZI2 = ZI2 + 1 IF( MOD( L, MN ).EQ.0 ) THEN I = I + 1 II = 0 ZI2 = ZD + I*MN*LDW END IF 50 CONTINUE C II = 0 ZI = ZC + KMN - MN C C Z_{K,K} is treated separately. C DO 60 L = KMN - MN + 1, KMN II = II + 1 LEN = MN - II + 1 IF( LEN.GT.1 ) THEN C C Generate Householder reflection. C CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU ) BETA = DWORK( ZI ) DWORK( ZI ) = ONE C C Apply reflection to Z and c: first to Z_{i,i} ... C CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU, $ DWORK( ZI + KMN ), KMN, DWORK ) C C ... and finally to c(L:L+LEN-1). C CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU, $ DWORK( CB + L - 1 ), KMN, DWORK ) C C Store the new diagonal value. C DWORK( ZI ) = BETA DMIN = MIN( DMIN, ABS( BETA ) ) END IF ZI = ZI + KMN + 1 C 60 CONTINUE C C Step 2: Use backward substitution on the computed triangular C system. C C Here, we take the possible irregularities above the C diagonal of the resulting R-factor into account by C checking the number of elements from the main diagonal C to the last non-zero element above the diagonal that C resides in the current column. C Pivots less than SPIV = MAX( PREC*DMIN, SMIN ) are set C to SPIV. C SCALE = ONE DOSCAL = .FALSE. DMIN = MAX( DMIN, SMIN ) SPIV = MAX( PREC*DMIN, SMIN ) C C Check for scaling. C I = IDAMAX( KMN, DWORK( CB ), 1 ) AC = ABS( DWORK( CB + I - 1 ) ) IF( TWO*SMIN*AC.GT.DMIN ) THEN TEMP = ( ONE / TWO ) / AC CALL DSCAL( KMN, TEMP, DWORK( CB ), 1 ) SCALE = SCALE*TEMP END IF C ZI = CB - 1 C DO 70 I = KMN, KMN - MN + 1, -1 C AD = ABS( DWORK( ZI ) ) AC = ABS( DWORK( CB + I - 1 ) ) IF( AD.LT.SPIV ) THEN AD = SPIV DWORK( ZI ) = SPIV END IF SCALOC = ONE IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN IF( AC.GT.BIGNUM*AD ) THEN INFO = 1 SCALOC = BIGNUM*AD / AC DOSCAL = .TRUE. SCALE = SCALE * SCALOC END IF END IF TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI ) IF( DOSCAL ) THEN DOSCAL = .FALSE. CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 ) END IF DWORK( CB + I - 1 ) = TEMP C CALL DAXPY( I - 1, -TEMP, DWORK( ZI - I + 1 ), 1, DWORK( CB ), $ 1 ) C ZI = ZI - KMN - 1 70 CONTINUE C ZIS = ZC - LDW ZI = ZIS + 2*MN - 1 IZ = 0 C DO 90 I = KMN - MN, 1, -1 AD = ABS( DWORK( ZI ) ) AC = ABS( DWORK( CB + I - 1 ) ) IF( AD.LT.SPIV ) THEN AD = SPIV DWORK( ZI ) = SPIV END IF SCALOC = ONE IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN IF( AC.GT.BIGNUM*AD ) THEN INFO = 1 SCALOC = BIGNUM*AD / AC DOSCAL = .TRUE. SCALE = SCALE * SCALOC END IF END IF TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI ) IF( DOSCAL ) THEN DOSCAL = .FALSE. CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 ) END IF DWORK( CB + I - 1 ) = TEMP LEN = MN + MOD( I - 1, MN ) + 1 ZI2 = ZIS 80 CONTINUE IF( DWORK( ZI2 ).EQ.ZERO ) THEN LEN = LEN - 1 ZI2 = ZI2 + 1 GO TO 80 END IF C J = MAX( 1, I - LEN + 1 ) CALL DAXPY( I - J, -TEMP, DWORK( ZI - I + J ), 1, $ DWORK( CB + J - 1 ), 1 ) C IF( MN.GT.1 ) THEN IF( MOD( I, MN ).EQ.1 ) THEN IZ = 1 - MN ELSE IZ = 1 END IF END IF ZI = ZI - LDW - IZ ZIS = ZIS - LDW 90 CONTINUE C C Reshape the solution into C. C IC1 = 1 ZI = CB C DO 100 L = 1, K C( IC1 ) = DWORK( ZI ) IF( M.EQ.1 ) THEN IF( N.EQ.2 ) $ C( IC1 + 1 ) = DWORK( ZI + 1 ) ELSE C( IC1 + 1 ) = DWORK( ZI + 1 ) IF( N.EQ.2 ) THEN C( IC1 + 2 ) = DWORK( ZI + 2 ) C( IC1 + 3 ) = DWORK( ZI + 3 ) END IF END IF IC1 = IC1 + MN ZI = ZI + MN 100 CONTINUE C C Store the minimal workspace on output. C DWORK( 1 ) = DBLE( MINWRK ) RETURN C C *** Last line of MB03KE *** END slicot-5.0+20101122/src/MB03LD.f000077500000000000000000000701721201767322700153770ustar00rootroot00000000000000 SUBROUTINE MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, $ BWORK, IWORK, LIWORK, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To compute the relevant eigenvalues of a real N-by-N skew- C Hamiltonian/Hamiltonian pencil aS - bH, with C C ( A D ) ( B F ) C S = ( ) and H = ( ), (1) C ( E A' ) ( G -B' ) C C where the notation M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'C', an orthogonal basis of the right C deflating subspace of aS - bH corresponding to the eigenvalues C with strictly negative real part is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the right deflating subspace C corresponding to the strictly negative eigenvalues of C aS - bH. C = 'N': do not compute the deflating subspace; C = 'C': compute the deflating subspace and store it in the C leading subarray of Q. C C ORTH CHARACTER*1 C If COMPQ = 'C', specifies the technique for computing the C orthogonal basis of the deflating subspace, as follows: C = 'Q': QR factorization (the fastest technique); C = 'P': QR factorization with column pivoting; C = 'S': singular value decomposition. C If COMPQ = 'N', the ORTH value is not used. C Usually, ORTH = 'Q' gives acceptable results, but badly C scaled or ill-conditioned problems might need to set C ORTH = 'P' or even ORTH = 'S'. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N has to be even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, the leading N/2-by-N/2 part of this array C contains the upper triangular matrix Aout (see METHOD). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C skew-symmetric matrix E, and the N/2-by-N/2 upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array must contain the upper triangular part of the C skew-symmetric matrix D. C The entries on the diagonal and the first superdiagonal of C this array need not be set, but are assumed to be zero. C On exit, the leading N/2-by-N/2 lower triangular part and C the first superdiagonal contains the transpose of the C upper quasi-triangular matrix C2out (see METHOD), and the C (N/2-1)-by-(N/2-1) upper triangular part of the submatrix C in the columns 3 to N/2+1 of this array contains the C strictly upper triangular part of the skew-symmetric C matrix Dout (see METHOD), without the main diagonal, which C is zero. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the upper triangular matrix C1out (see METHOD). C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C FG (input/output) DOUBLE PRECISION array, dimension C (LDFG, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C symmetric matrix F. C On exit, the leading N/2-by-N/2 part of the submatrix in C the columns 2 to N/2+1 of this array contains the matrix C Vout (see METHOD). C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, N/2). C C NEIG (output) INTEGER C If COMPQ = 'C', the number of eigenvalues in aS - bH with C strictly negative real part. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading N-by-NEIG part of C this array contains an orthogonal basis of the right C deflating subspace corresponding to the eigenvalues of C aA - bB with strictly negative real part. The remaining C part of this array is used as workspace. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bT, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. C C Workspace C C BWORK LOGICAL array, dimension (N/2) C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = -20, IWORK(1) returns the minimum value C of LIWORK. C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= MAX( N/2 + 32, 2*N + 1 ). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -22, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 3*(N/2)**2 + 2*N**2 + MAX( N, 32 ), C if COMPQ = 'N'; C LDWORK >= 8*N**2 + MAX( 8*N + 32, N/2 + 168, 272 ), C if COMPQ = 'C'. C For good performance LDWORK should be generally larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: periodic QZ iteration failed in the SLICOT Library C routines MB04BD or MB04HD (QZ iteration did not C converge or computation of the shifts failed); C = 2: standard QZ iteration failed in the SLICOT Library C routines MB04HD or MB03DD (called by MB03JD); C = 3: a numerically singular matrix was found in the SLICOT C Library routine MB03HD (called by MB03JD). C C METHOD C C First, the decompositions of S and H are computed via orthogonal C transformations Q1 and Q2 as follows: C C ( Aout Dout ) C Q1' S J Q1 J' = ( ), C ( 0 Aout' ) C C ( Bout Fout ) C J' Q2' J S Q2 = ( ) =: T, (2) C ( 0 Bout' ) C C ( C1out Vout ) ( 0 I ) C Q1' H Q2 = ( ), where J = ( ), C ( 0 C2out' ) ( -I 0 ) C C and Aout, Bout, C1out are upper triangular, C2out is upper quasi- C triangular and Dout and Fout are skew-symmetric. C C Then, orthogonal matrices Q3 and Q4 are found, for the extended C matrices C C ( Aout 0 ) ( 0 C1out ) C Se = ( ) and He = ( ), C ( 0 Bout ) ( -C2out 0 ) C C such that S11 := Q4' Se Q3 is upper triangular and C H11 := Q4' He Q3 is upper quasi-triangular. The following matrices C are computed: C C ( Dout 0 ) ( 0 Vout ) C S12 := Q4' ( ) Q4 and H12 := Q4' ( ) Q4. C ( 0 Fout ) ( Vout' 0 ) C C Then, an orthogonal matrix Q is found such that the eigenvalues C with strictly negative real parts of the pencil C C ( S11 S12 ) ( H11 H12 ) C a ( ) - b ( ) C ( 0 S11' ) ( 0 -H11' ) C C are moved to the top of this pencil. C C Finally, an orthogonal basis of the right deflating subspace C corresponding to the eigenvalues with strictly negative real part C is computed. See also page 12 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 2010. C C REVISIONS C C V. Sima, Nov. 2010. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ, ORTH INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, $ LIWORK, N, NEIG C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DE( LDDE, * ), $ DWORK( * ), FG( LDFG, * ), Q( LDQ, * ) C C .. Local Scalars .. LOGICAL LINIQ, LQUERY, QR, QRP, SVD CHARACTER*14 CMPQ INTEGER IB, IC2, IFO, IH11, IH12, IQ1, IQ2, IQ3, IQ4, $ IRT, IS11, IS12, IWRK, J, M, MINDW, MINIW, MM, $ N2, NM, NMM, NN, OPTDW C C .. Local Arrays .. DOUBLE PRECISION DUM( 3 ) C C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQP3, DGEQRF, DGESVD, $ DLACPY, DORGQR, DSCAL, DTRMM, MA02AD, MB01LD, $ MB03JD, MB04BD, MB04HD, XERBLA C C .. Intrinsic Functions .. INTRINSIC INT, MAX, MOD, SQRT C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 N2 = N*2 NN = N*N MM = M*M NEIG = 0 LINIQ = LSAME( COMPQ, 'C' ) IF( LINIQ ) THEN QR = LSAME( ORTH, 'Q' ) QRP = LSAME( ORTH, 'P' ) SVD = LSAME( ORTH, 'S' ) END IF MINIW = MAX( M + 32, N2 + 1 ) IF( N.EQ.0 ) THEN MINDW = 1 ELSE IF( LINIQ ) THEN MINDW = 8*NN + MAX( 8*N + 32, M + 168, 272 ) ELSE MINDW = 3*M**2 + 2*NN + MAX( N, 32 ) END IF LQUERY = LDWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LINIQ ) ) THEN INFO = -1 ELSE IF( LINIQ .AND. .NOT.( QR .OR. QRP .OR. SVD ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LINIQ .AND. LDQ.LT.N2 ) ) THEN INFO = -14 ELSE IF( LIWORK.LT.MINIW ) THEN IWORK( 1 ) = MINIW INFO = -20 ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -22 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03LD', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LINIQ ) THEN CALL MB04HD( 'I', 'I', N, DWORK, N, DWORK, N, DWORK, N, $ DWORK, N, BWORK, IWORK, LIWORK, DUM, -1, INFO ) IF( SVD ) THEN CALL DGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, DWORK, LDQ, $ DWORK, 1, DUM( 2 ), -1, INFO ) J = N + INT( DUM( 2 ) ) ELSE IF( QR ) THEN CALL DGEQRF( N, M, Q, LDQ, DWORK, DUM( 2 ), -1, INFO ) J = M ELSE CALL DGEQP3( N, N, Q, LDQ, IWORK, DWORK, DUM( 2 ), -1, $ INFO ) J = N END IF CALL DORGQR( N, J, J, Q, LDQ, DWORK, DUM( 3 ), -1, INFO ) J = J + MAX( INT( DUM( 2 ) ), INT( DUM( 3 ) ) ) END IF OPTDW = MAX( MINDW, 6*NN + INT( DUM( 1 ) ), J ) ELSE OPTDW = MINDW END IF IF( LQUERY ) THEN DWORK( 1 ) = OPTDW RETURN END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 1 DWORK( 1 ) = ONE RETURN END IF C IFO = 1 C C STEP 1: Apply MB04BD to transform the pencil to real C skew-Hamiltonian/Hamiltonian Schur form. C Set the computation option and pointers for the inputs and outputs C of MB04BD. If possible, array Q is used as vectorized workspace. C C Real workspace: need w1 + 2*N**2 + MAX(N,32), where C w1 = 2*N**2, if COMPQ = 'C'; C w1 = 3*M**2, if COMPQ = 'N'. C Integer workspace: need M + 12. C IF( LINIQ ) THEN CMPQ = 'Initialize' IQ1 = 1 IQ2 = IQ1 + NN IWRK = IQ2 + NN IF( MOD( M, 4 ).EQ.0 ) THEN IC2 = M/4 ELSE IC2 = INT( M/4 ) + 1 END IF IB = 2*IC2 + 1 IC2 = IC2 + 1 CALL MB04BD( 'Triangularize', CMPQ, CMPQ, N, A, LDA, DE, LDDE, $ B, LDB, FG, LDFG, DWORK( IQ1 ), N, DWORK( IQ2 ), $ N, Q( 1, IB ), M, Q( 1, IFO ), M, Q( 1, IC2 ), M, $ ALPHAR, ALPHAI, BETA, IWORK, LIWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) ELSE CMPQ = 'No Computation' IB = IFO + MM IC2 = IB + MM IWRK = IC2 + MM CALL MB04BD( 'Triangularize', CMPQ, CMPQ, N, A, LDA, DE, LDDE, $ B, LDB, FG, LDFG, DWORK, N, DWORK, N, DWORK( IB ), $ M, DWORK( IFO ), M, DWORK( IC2 ), M, ALPHAR, $ ALPHAI, BETA, IWORK, LIWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C IF( .NOT.LINIQ ) THEN CALL MA02AD( 'Upper', M, M, DWORK( IC2 ), M, DE, LDDE ) CALL DCOPY( M-1, DWORK( IC2+1 ), M+1, DE( 1, 2 ), LDDE+1 ) RETURN END IF C C STEP 2: Build the needed parts of the extended matrices Se and He, C and compute the transformed matrices and the orthogonal matrices C Q3 and Q4. C Real workspace: need w1 + w2 + 2*N**2 + MAX(M+168,272), with C w2 = 4*N**2 (COMPQ = 'C'); C prefer larger. C Integer workspace: need M + 32. C NM = N*M NMM = NM + M IQ3 = IWRK IQ4 = IQ3 + NN IS11 = IQ4 + NN IH11 = IS11 + NN IWRK = IH11 + NN C CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IS11 ), N ) CALL DLACPY( 'Full', M, M, Q( 1, IB ), M, DWORK( IS11+NMM ), N ) CALL DSCAL( MM, -ONE, Q( 1, IC2 ), 1 ) CALL DLACPY( 'Full', M, M, Q( 1, IC2 ), M, DWORK( IH11+M ), N ) CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IH11+NM ), N ) C CALL MB04HD( CMPQ, CMPQ, N, DWORK( IS11 ), N, DWORK( IH11 ), N, $ DWORK( IQ3 ), N, DWORK( IQ4 ), N, BWORK, IWORK, $ LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.GT.2 ) $ INFO = 2 RETURN END IF C C STEP 3: Update S12 and H12, building the upper triangular parts, C and exploiting the structure. Note that S12 is skew-symmetric and C H12 is symmetric. C Real workspace: need w1 + w2 + w3, where C w3 = N**2 + M**2. C IS12 = IWRK IH12 = IS12 + NN IWRK = IH12 C IF( M.GT.1 ) THEN C C [ Qa Qc ] C Compute Qa'*Do*Qc + Qb'*Fo*Qd, where Q4 =: [ ], C [ Qb Qd ] C with Do := Dout, etc. C Part of the array Q and DWORK(IS12) are used as workspace. C CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM+1 ), N, $ DWORK( IS12 ), M ) CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM ), N, Q( 2, IB ), $ M ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1, $ M, ONE, DE( 1, 3 ), LDDE, DWORK( IS12 ), M ) CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, M, $ -ONE, DE( 1, 3 ), LDDE, Q( 2, IB ), M ) DUM( 1 ) = ZERO CALL DCOPY( M, DUM, 0, DWORK( IS12+M-1 ), M ) CALL DCOPY( M, DUM, 0, Q( 1, IB ), M ) CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IS12 ), 1 ) C CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM+1 ), N, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM ), N, Q( 2, IB ), $ M ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1, $ M, ONE, Q( M+1, IFO ), M, DWORK( IWRK ), M ) CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, $ M, -ONE, Q( M+1, IFO ), M, Q( 2, IB ), M ) CALL DCOPY( M, DUM, 0, DWORK( IWRK+M-1 ), M ) CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IWRK ), 1 ) C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4 ), N, DWORK( IS12 ), M, ZERO, $ DWORK( IS12+NM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4+M ), N, DWORK( IWRK ), M, ONE, $ DWORK( IS12+NM ), N ) C C Compute Qa'*Do*Qa + Qb'*Fo*Qb. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, $ DWORK( IS12 ), N, DWORK( IQ4 ), N, DE( 1, 2 ), $ LDDE, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE, $ DWORK( IS12 ), N, DWORK( IQ4+M ), N, Q( 1, IFO ), $ M, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) C C Compute Qc'*Do*Qc + Qd'*Fo*Qd. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, $ DWORK( IS12+NMM ), N, DWORK( IQ4+NM ), N, $ DE( 1, 2 ), LDDE, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE, $ DWORK( IS12+NMM ), N, DWORK( IQ4+NMM ), N, $ Q( 1, IFO ), M, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) END IF C C Compute Qb'*Vo'*Qc + Qa'*Vo*Qd. C Real workspace: need w1 + w2 + w3, where C w3 = 2*N**2. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ FG( 1, 2 ), LDFG, DWORK( IQ4+NM ), N, ZERO, $ Q( 1, IFO ), M ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4+M ), N, Q( 1, IFO ), M, ZERO, $ DWORK( IH12+NM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4 ), N, FG( 1, 2 ), LDFG, ZERO, $ DWORK( IH12 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IH12 ), M, DWORK( IQ4+NMM ), N, ZERO, $ DWORK( IH12+NMM ), N ) DO 10 J = 1, M CALL DAXPY( M, ONE, DWORK( IH12+(M+J-1)*N+M ), 1, $ DWORK( IH12+(M+J-1)*N ), 1 ) 10 CONTINUE C C Compute the upper triangle of Qa'*Vo*Qb + (Qa'*Vo*Qb)'. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4 ), N, FG( 1, 2 ), LDFG, ZERO, $ Q( 1, IFO ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( 1, IFO ), M, DWORK( IQ4+M ), N, ZERO, $ DWORK( IH12 ), N ) DO 20 J = 1, M CALL DAXPY( J, ONE, DWORK( IH12+J-1 ), N, $ DWORK( IH12+(J-1)*N ), 1 ) 20 CONTINUE C C Compute the upper triangle of Qc'*Vo*Qd + (Qc'*Vo*Qd)'. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4+NM ), N, FG( 1, 2 ), LDFG, ZERO, $ Q( 1, IFO ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( 1, IFO ), M, DWORK( IQ4+NMM ), N, ZERO, $ DWORK( IH12+NMM ), N ) DO 30 J = 1, M CALL DAXPY( J, ONE, DWORK( IH12+NMM+J-1 ), N, $ DWORK( IH12+NMM+(J-1)*N ), 1 ) 30 CONTINUE C C Return C2out. C CALL DSCAL( MM, -ONE, Q( 1, IC2 ), 1 ) CALL MA02AD( 'Upper', M, M, Q( 1, IC2 ), M, DE, LDDE ) CALL DCOPY( M-1, Q( 2, IC2 ), M+1, DE( 1, 2 ), LDDE+1 ) C C STEP 4: Apply MB03JD to reorder the eigenvalues with strictly C negative real part to the top. C C Real workspace: need w1 + w2 + w3 + MAX(8*N+32,108), C w3 = 2*N**2. C Integer workspace: need 2*N + 1. C IWRK = IH12 + NN C CALL MB03JD( CMPQ, N2, DWORK( IS11 ), N, DWORK( IS12 ), N, $ DWORK( IH11 ), N, DWORK( IH12 ), N, Q, LDQ, NEIG, $ IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = INFO + 1 RETURN END IF C C STEP 5: Compute the deflating subspace corresponding to the C eigenvalues with strictly negative real part. C Real workspace: need w2 + 3*N**2, if ORTH = 'QR'. C w2 + 4*N**2, otherwise. C IWRK = IS11 IF( QR ) $ NEIG = NEIG/2 C C Compute [ J*Q1*J' Q2 ]. C CALL DLACPY( 'Full', M, M, DWORK( IQ1+NMM ), N, DWORK( IWRK ), N ) CALL DLACPY( 'Full', M, M, DWORK( IQ1+NM ), N, DWORK( IWRK+M ), $ N ) DO 40 J = 1, M CALL DSCAL( M, -ONE, DWORK( IWRK+M+(J-1)*N ), 1 ) 40 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IQ1+M ), N, DWORK( IWRK+NM ), $ N ) DO 50 J = 1, M CALL DSCAL( M, -ONE, DWORK( IWRK+NM+(J-1)*N ), 1 ) 50 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IQ1 ), N, DWORK( IWRK+NMM ), N ) C CALL DLACPY( 'Full', N, N, DWORK( IQ2 ), N, DWORK( IWRK+NN ), N ) C C Compute the first NEIG columns of P*[ Q3 0; 0 Q4 ]*Q. C IRT = IWRK + N*N2 CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3 ), N, Q, LDQ, ZERO, DWORK( IRT ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4 ), N, Q( N+1, 1 ), LDQ, ZERO, $ DWORK( IRT+M ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3+M ), N, Q, LDQ, ZERO, DWORK( IRT+N ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4+M ), N, Q( N+1, 1 ), LDQ, ZERO, $ DWORK( IRT+N+M ), N2 ) C C Compute the deflating subspace. C CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2, $ SQRT( TWO )/TWO, DWORK( IWRK ), N, DWORK( IRT ), N2, $ ZERO, Q, LDQ ) C C Orthogonalize the basis given in Q(1:n,1:neig). C IWRK = NEIG + 1 IF( SVD ) THEN C C Real workspace: need N + MAX(1,5*M); C prefer larger. C CALL DGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK, $ DWORK, 1, DWORK, 1, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Real workspace: need N; C prefer M+M*NB, where NB is the optimal C blocksize. C CALL DGEQRF( N, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) ELSE C C Real workspace: need 4*N+1; C prefer 3*N+(N+1)*NB. C DO 60 J = 1, NEIG IWORK( J ) = 0 60 CONTINUE CALL DGEQP3( N, NEIG, Q, LDQ, IWORK, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C C Real workspace: need 2*NEIG; C prefer NEIG + NEIG*NB. C CALL DORGQR( N, NEIG, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( QRP ) $ NEIG = NEIG/2 END IF C DWORK( 1 ) = OPTDW RETURN C *** Last line of MB03LD *** END slicot-5.0+20101122/src/MB03MD.f000077500000000000000000000306201201767322700153720ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB03MY.f000077500000000000000000000051221201767322700154160ustar00rootroot00000000000000 DOUBLE PRECISION FUNCTION MB03MY( NX, X, INCX ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03ND.f000077500000000000000000000167071201767322700154050ustar00rootroot00000000000000 INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03NY.f000077500000000000000000000144141201767322700154230ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03OD.f000077500000000000000000000263751201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB03OY.f000077500000000000000000000326321201767322700154260ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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 .. 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, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( A( I, J ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO) TEMP2 = TEMP*( DWORK( J ) / DWORK( N+J ) )**2 IF( TEMP2.LE.TOLZ ) 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 slicot-5.0+20101122/src/MB03PD.f000077500000000000000000000304101201767322700153720ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB03PY.f000077500000000000000000000334121201767322700154240ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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.0D+0, ONE = 1.0D+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, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( A( J, NKI ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), $ ZERO ) TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2 IF( TEMP2.LE.TOLZ ) 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 slicot-5.0+20101122/src/MB03QD.f000077500000000000000000000270741201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03QX.f000077500000000000000000000067171201767322700154340ustar00rootroot00000000000000 SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03QY.f000077500000000000000000000130171201767322700154240ustar00rootroot00000000000000 SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03RD.f000077500000000000000000000537141201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03RX.f000077500000000000000000000202011201767322700154150ustar00rootroot00000000000000 SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI, $ DWORK ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03RY.f000077500000000000000000000212621201767322700154260ustar00rootroot00000000000000 SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03SD.f000077500000000000000000000273761201767322700154160ustar00rootroot00000000000000 SUBROUTINE MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, $ LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03TD.f000077500000000000000000000560011201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03TS.f000077500000000000000000000653211201767322700154260ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03UD.f000077500000000000000000000254011201767322700154030ustar00rootroot00000000000000 SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, $ LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB03VD.f000077500000000000000000000254431201767322700154120ustar00rootroot00000000000000 SUBROUTINE MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, $ DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03VY.f000077500000000000000000000160361201767322700154350ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03WA.f000077500000000000000000000473061201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03WD.f000077500000000000000000001013461201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03WX.f000077500000000000000000000120621201767322700154300ustar00rootroot00000000000000 SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03XD.f000077500000000000000000000762721201767322700154220ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03XP.f000077500000000000000000000553151201767322700154310ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03XU.f000077500000000000000000003357501201767322700154420ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03YA.f000077500000000000000000000247531201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03YD.f000077500000000000000000000443711201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB03YT.f000077500000000000000000000237541201767322700154400ustar00rootroot00000000000000 SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB03ZA.f000077500000000000000000001601321201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should 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 slicot-5.0+20101122/src/MB03ZD.f000077500000000000000000001072101201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MB04AD.f000077500000000000000000001333411201767322700153630ustar00rootroot00000000000000 SUBROUTINE MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ, $ H, LDH, T, LDT, Q1, LDQ1, Q2, LDQ2, U11, LDU11, $ U12, LDU12, U21, LDU21, U22, LDU22, ALPHAR, $ ALPHAI, BETA, IWORK, LIWORK, DWORK, LDWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 real N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH with C C ( 0 I ) C S = T Z = J Z' J' Z, where J = ( ), (1) C ( -I 0 ) C C via generalized symplectic URV decomposition. That is, orthogonal C matrices Q1 and Q2 and orthogonal symplectic matrices U1 and U2 C are computed such that C C ( T11 T12 ) C Q1' T U1 = Q1' J Z' J' U1 = ( ) = Tout, C ( 0 T22 ) C C ( Z11 Z12 ) C U2' Z Q2 = ( ) = Zout, (2) C ( 0 Z22 ) C C ( H11 H12 ) C Q1' H Q2 = ( ) = Hout, C ( 0 H22 ) C C where T11, T22', Z11, Z22', H11 are upper triangular and H22' is C upper quasi-triangular. C Optionally, if COMPQ1 = 'C' the orthogonal transformation matrix C Q1 will be computed. C Optionally, if COMPQ2 = 'C' the orthogonal transformation matrix C Q2 will be computed. C Optionally, if COMPU1 = 'C' the orthogonal symplectic C transformation matrix C C ( U11 U12 ) C U1 = ( ) C ( -U12 U11 ) C C will be computed. C Optionally, if COMPU2 = 'C' the orthogonal symplectic C transformation matrix C C ( U21 U22 ) C U2 = ( ) C ( -U22 U21 ) C C will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; Z, T, and H will not C necessarily be put into the forms in (2); H22' is C upper Hessenberg; C = 'T': put Z, T, and H into the forms in (2), and return C the eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'C': compute the matrix Q1 of the orthogonal C transformations applied on the left to the pencil C aTZ - bH to reduce its matrices to the form (2). C The array Q1 is initialized internally to the C identity matrix. C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'C': compute the matrix Q2 of the orthogonal C transformations applied on the right to the pencil C aTZ - bH to reduce its matrices to the form (2). C The array Q2 is initialized internally to the C identity matrix. C C COMPU1 CHARACTER*1 C Specifies whether to compute the orthogonal symplectic C transformation matrix U1, as follows: C = 'N': U1 is not computed; C = 'C': compute the matrices U11 and U12 of the orthogonal C symplectic transformations applied to the pencil C aTZ - bT to reduce its matrices to the form (2). C The arrays U11 and U12 are initialized internally C to correspond to an identity matrix U1. C C COMPU2 CHARACTER*1 C Specifies whether to compute the orthogonal symplectic C transformation matrix U2, as follows: C = 'N': U2 is not computed; C = 'C': compute the matrices U21 and U22 of the orthogonal C symplectic transformations applied to the pencil C aTZ - bT to reduce its matrices to the form (2). C The arrays U21 and U22 are initialized internally C to correspond to an identity matrix U2. C C Input/output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. 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 matrix Z. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the matrix Zout; otherwise, it contains the C matrix Z obtained just before the application of the C periodic QZ algorithm. C The elements of the (2,1) block, i.e., in the rows N/2+1 C to N and in the columns 1 to N/2 are not set to zero, but C are unchanged on exit. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1, N). C C H (input/output) DOUBLE PRECISION array, dimension (LDH, N) C On entry, the leading N-by-N part of this array must C contain the Hamiltonian matrix H (H22 = -H11', H12 = H12', C H21 = H21'). C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the matrix Hout; otherwise, it contains the C matrix H obtained just before the application of the C periodic QZ algorithm. C C LDH INTEGER C The leading dimension of the array H. LDH >= MAX(1, N). C C T (output) DOUBLE PRECISION array, dimension (LDT, N) C If JOB = 'T', the leading N-by-N part of this array C contains the matrix Tout; otherwise, it contains the C matrix T obtained just before the application of the C periodic QZ algorithm. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1, N). C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N) C On exit, if COMPQ1 = 'C', the leading N-by-N part of this C array contains the orthogonal transformation matrix Q1. C If COMPQ1 = 'N', this array is not referenced. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'C'. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C On exit, if COMPQ2 = 'C', the leading N-by-N part of this C array contains the orthogonal transformation matrix Q2. C If COMPQ2 = 'N', this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'C'. C C U11 (output) DOUBLE PRECISION array, dimension (LDU11, N/2) C On exit, if COMPU1 = 'C', the leading N/2-by-N/2 part of C this array contains the upper left block U11 of the C orthogonal symplectic transformation matrix U1. C If COMPU1 = 'N', this array is not referenced. C C LDU11 INTEGER C The leading dimension of the array U11. C LDU11 >= 1, if COMPU1 = 'N'; C LDU11 >= MAX(1, N/2), if COMPU1 = 'C'. C C U12 (output) DOUBLE PRECISION array, dimension (LDU12, N/2) C On exit, if COMPU1 = 'C', the leading N/2-by-N/2 part of C this array contains the upper right block U12 of the C orthogonal symplectic transformation matrix U1. C If COMPU1 = 'N', this array is not referenced. C C LDU12 INTEGER C The leading dimension of the array U12. C LDU12 >= 1, if COMPU1 = 'N'; C LDU12 >= MAX(1, N/2), if COMPU1 = 'C'. C C U21 (output) DOUBLE PRECISION array, dimension (LDU21, N/2) C On exit, if COMPU2 = 'C', the leading N/2-by-N/2 part of C this array contains the upper left block U21 of the C orthogonal symplectic transformation matrix U2. C If COMPU2 = 'N', this array is not referenced. C C LDU21 INTEGER C The leading dimension of the array U21. C LDU21 >= 1, if COMPU2 = 'N'; C LDU21 >= MAX(1, N/2), if COMPU2 = 'C'. C C U22 (output) DOUBLE PRECISION array, dimension (LDU22, N/2) C On exit, if COMPU2 = 'C', the leading N/2-by-N/2 part of C this array contains the upper right block U22 of the C orthogonal symplectic transformation matrix U2. C If COMPU2 = 'N', this array is not referenced. C C LDU22 INTEGER C The leading dimension of the array U22. C LDU22 >= 1, if COMPU2 = 'N'; C LDU22 >= MAX(1, N/2), if COMPU2 = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta defining the eigenvalues of the pencil C aS - bH. C If INFO = 0, the quantities alpha = (ALPHAR(j),ALPHAI(j)), C and beta = BETA(j) represent together the j-th eigenvalue C of the pencil aS - bH, in the form lambda = alpha/beta. C Since lambda may overflow, the ratios should not, in C general, be computed. Due to the skew-Hamiltonian/ C Hamiltonian structure of the pencil, only half of the C spectrum is saved in ALPHAR, ALPHAI and BETA. C Specifically, the eigenvalues with positive real parts or C with non-negative imaginary parts, when real parts are C zero, are returned. The remaining eigenvalues have C opposite signs. C If INFO = 3, one or more BETA(j) is not representable, and C the eigenvalues are returned as described below. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 3, IWORK(1), ..., IWORK(N/2) return the C scaling parameters for the eigenvalues of the pencil C aS - bH (see INFO = 3). C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N/2+18. 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 machine base, b. C On exit, if INFO = -31, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N' and C COMPU1 = 'N' and COMPU2 = 'N', then C LDWORK >= 3/2*N**2+MAX(N, 48); C else, LDWORK >= 3*N**2+MAX(N, 48). C For good performance LDWORK should generally be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C XERBLA. C C Error Indicator C C INFO INTEGER C = 0: succesful exit. C < 0: if INFO = -i, the i-th argument had an illegal value. C = 1: the periodic QZ algorithm was not able to reveal C information about the eigenvalues from the 2-by-2 C blocks in the SLICOT Library routine MB03BD; C = 2: the periodic QZ algorithm did not converge in the C SLICOT Library routine MB03BD; C = 3: the eigenvalues will under- or overflow if evaluated; C therefore, the j-th eigenvalue is represented by C the quantities alpha = (ALPHAR(j),ALPHAI(j)), C beta = BETA(j), and gamma = IWORK(j) in the form C lambda = (alpha/beta) * b**gamma, where b is the C machine base (often 2.0). This is not an error. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in T, Z, and H such that T11, T22', Z11, Z22' C and H11 are upper triangular and H22' is upper Hessenberg. Finally C the periodic QZ algorithm is applied to transform H22' to upper C quasi-triangular form while T11, T22', Z11, Z22', and H11 stay in C upper triangular form. C See also page 17 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, December 03, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DGEURV). C C REVISIONS C C V. Sima, Feb. 2010, Nov. 2010. C C KEYWORDS C C generalized symplectic URV decomposition, periodic QZ algorithm, C upper (quasi-)triangular matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF= 0.5D+0, ONE = 1.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2, COMPU1, COMPU2, JOB INTEGER INFO, LDH, LDQ1, LDQ2, LDT, LDU11, LDU12, $ LDU21, LDU22, LDWORK, LDZ, LIWORK, N C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), $ DWORK( * ), H( LDH, * ), Q1( LDQ1, * ), $ Q2( LDQ2, * ), T( LDT, * ), U11( LDU11, * ), $ U12( LDU12, * ), U21( LDU21, * ), $ U22( LDU22, * ), Z( LDZ, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LCMPU1, LCMPU2, LINIQ1, LINIQ2, $ LINIU1, LINIU2, LQUERY, LTRI, LUPDQ1, LUPDQ2, $ LUPDU1, LUPDU2 CHARACTER*16 CMPQ, CMPSC INTEGER I, IMAT, IQ, ITAU, IWARN, IWRK, J, K, M, MINDW, $ MM, NB, OPTDW DOUBLE PRECISION BASE, CO, EMAX, EMIN, PREC, SI, SQRB, TMP1, $ TMP2 COMPLEX*16 EIG C C .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2, ILAENV, LSAME C C .. External Subroutines .. EXTERNAL DGEMM, DGEQRF, DGERQF, DLACPY, DLARTG, DLASET, $ DORMQR, DORMRQ, DROT, DSCAL, DSWAP, MA02AD, $ MB03BD, XERBLA C C ... Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, MAX, MIN, MOD, SQRT C C .. Executable Statements .. C C Decode the input arguments. C The code is able to update some given matrices Q1, Q2, U1, and U2, C but this feature is not documented. C M = N/2 MM = M*M C LTRI = LSAME( JOB, 'T' ) LINIQ1 = LSAME( COMPQ1, 'C' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LINIQ2 = LSAME( COMPQ2, 'C' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LINIU1 = LSAME( COMPU1, 'C' ) LUPDU1 = LSAME( COMPU1, 'U' ) LINIU2 = LSAME( COMPU2, 'C' ) LUPDU2 = LSAME( COMPU2, 'U' ) LCMPQ1 = LINIQ1 .OR. LUPDQ1 LCMPQ2 = LINIQ2 .OR. LUPDQ2 LCMPU1 = LINIU1 .OR. LUPDU1 LCMPU2 = LINIU2 .OR. LUPDU2 LQUERY = ( LDWORK.EQ.-1 ) C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -3 ELSE IF( .NOT.( LSAME( COMPU1, 'N' ) .OR. LCMPU1 ) ) THEN INFO = -4 ELSE IF( .NOT.( LSAME( COMPU2, 'N' ) .OR. LCMPU2 ) ) THEN INFO = -5 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -6 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDQ1.LT.1 .OR. ( LCMPQ1 .AND. LDQ1.LT.N ) ) THEN INFO = -14 ELSE IF( LDQ2.LT.1 .OR. ( LCMPQ2 .AND. LDQ2.LT.N ) ) THEN INFO = -16 ELSE IF( LDU11.LT.1 .OR. ( LCMPU1 .AND. LDU11.LT.M ) ) THEN INFO = -18 ELSE IF( LDU12.LT.1 .OR. ( LCMPU1 .AND. LDU12.LT.M ) ) THEN INFO = -20 ELSE IF( LDU21.LT.1 .OR. ( LCMPU2 .AND. LDU21.LT.M ) ) THEN INFO = -22 ELSE IF( LDU22.LT.1 .OR. ( LCMPU2 .AND. LDU22.LT.M ) ) THEN INFO = -24 ELSE IF( LIWORK.LT.M+18 ) THEN INFO = -29 ELSE IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 ) THEN MINDW = 12*MM + MAX( N, 48 ) ELSE MINDW = 6*MM + MAX( N, 48 ) END IF IWRK = M NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', N, N, M, -1 ) ) OPTDW = MAX( MINDW, IWRK + N*NB ) NB = ILAENV( 1, 'DGERQF', ' ', M, M, -1, -1 ) OPTDW = MAX( OPTDW, IWRK + MM + M*NB ) NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'LN', M, N, M, -1 ) ) OPTDW = MAX( OPTDW, IWRK + M*M + N*NB ) IF( LCMPQ1 ) THEN NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', N, M, M, -1 ) ) OPTDW = MAX( OPTDW, IWRK + M*M + N*NB ) END IF NB = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 ) OPTDW = MAX( OPTDW, IWRK + M*N + M*NB ) NB = MIN( 64, ILAENV( 1, 'DORMQR', 'RN', N, N, M, -1 ) ) OPTDW = MAX( OPTDW, IWRK + M*N + N*NB ) IF( LCMPQ2 ) THEN NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LN', N, N, M, -1 ) ) OPTDW = MAX( OPTDW, IWRK + M*N + N*NB ) END IF IF( LDWORK.LT.MINDW .AND. .NOT.LQUERY ) THEN DWORK( 1 ) = MINDW INFO = -31 END IF END IF C IF( INFO.NE.0) THEN CALL XERBLA( 'MB04AD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = OPTDW RETURN END IF C C Determine machine constants. C BASE = DLAMCH( 'Base' ) EMIN = DLAMCH( 'Minimum Exponent' ) EMAX = DLAMCH( 'Largest Exponent' ) PREC = DLAMCH( 'Precision' ) SQRB = SQRT( BASE ) C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = 2 DWORK( 2 ) = BASE RETURN END IF C C Initializations. C C Set T = J Z' J'. C CALL MA02AD( 'Full', M, M, Z( M+1, M+1 ), LDZ, T, LDT ) CALL MA02AD( 'Full', M, M, Z( 1, M+1 ), LDZ, T( 1, M+1 ), LDT ) C DO 10 I = 1, M CALL DSCAL( M, -ONE, T( 1, M+I ), 1 ) 10 CONTINUE C CALL MA02AD( 'Full', M, M, Z( M+1, 1 ), LDZ, T( M+1, 1 ), LDT ) C DO 20 I = 1, M CALL DSCAL( M, -ONE, T( M+1, I ), 1 ) 20 CONTINUE C CALL MA02AD( 'Full', M, M, Z, LDZ, T( M+1, M+1 ), LDT ) C IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) C IF( LINIQ2 ) THEN CALL DLASET( 'Full', M, M, ZERO, ZERO, Q2, LDQ2 ) CALL DLASET( 'Full', M, M, ZERO, ONE, Q2( M+1, 1 ), LDQ2 ) CALL DLASET( 'Full', M, M, ZERO, ONE, Q2( 1, M+1 ), LDQ2 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, Q2( M+1, M+1 ), LDQ2 ) END IF C IF( LINIU1 ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, U11, LDU11 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, U12, LDU12 ) END IF C IF( LINIU2 ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, U21, LDU21 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, U22, LDU22 ) END IF C C STEP 1: Block triangularize T and 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 ITAU = 1 IWRK = ITAU + M C C ( T11 ) C Perform a QR decomposition, ( ) = Q1*R1. C ( T21 ) C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C CALL DGEQRF( N, M, T, LDT, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) C C ( T12 ) C Update ( ). C ( T22 ) C C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C CALL DORMQR( 'Left', 'Transpose', N, M, M, T, LDT, DWORK( ITAU ), $ T( 1, M+1 ), LDT, DWORK( IWRK ), LDWORK-IWRK+1, INFO $ ) C C Update H. C Workspace: need IWRK + N - 1; C prefer IWRK + N*NB - 1. C CALL DORMQR( 'Left', 'Transpose', N, N, M, T, LDT, DWORK( ITAU ), $ H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DORMQR( 'Right', 'No Transpose', N, N, M, T, LDT, $ DWORK( ITAU ), Q1, LDQ1, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C C Set the strictly lower triangular part of [ T11; T21 ] to zero. C CALL DLASET( 'Lower', N-1, M, ZERO, ZERO, T( 2, 1 ), LDT ) C C Perform an RQ decomposition, T22 = R2*Q2. C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C ITAU = MM + 1 IWRK = ITAU + M CALL MA02AD( 'Full', M, M, T( M+1, M+1 ), LDT, DWORK, M ) CALL DGERQF( M, M, DWORK, M, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) CALL MA02AD( 'Upper', M, M, DWORK, M, T( M+1, M+1 ), LDT ) C C Set the strictly upper triangular part of T22 to zero. C IF( M.GT.1 ) $ CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, T( M+1, M+2 ), LDT $ ) C C Update H. C Workspace: need IWRK + N - 1; C prefer IWRK + N*NB - 1. C CALL DORMRQ( 'Left', 'No Transpose', M, N, M, DWORK, M, $ DWORK( ITAU ), H( M+1, 1 ), LDH, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DORMRQ( 'Right', 'Transpose', N, M, M, DWORK, M, $ DWORK( ITAU ), Q1( 1, M+1 ), LDQ1, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C C Perform a QR decomposition, ( Z21 Z22 )' = Q3*R3. C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C ITAU = M*N + 1 IWRK = ITAU + M CALL MA02AD( 'Full', M, N, Z( M+1, 1 ), LDZ, DWORK, N ) CALL DGEQRF( N, M, DWORK, N, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) C C Update ( Z11 Z12 ). C CALL DORMQR( 'Right', 'No Transpose', M, N, M, DWORK, N, $ DWORK( ITAU ), Z, LDZ, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) CALL MA02AD( 'Upper', M, M, DWORK, N, Z( M+1, M+1 ), LDZ ) C C Set the strictly upper triangular part of Z22 to zero. C IF( M.GT.1 ) $ CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, Z( M+1, M+2 ), LDZ $ ) C C Update H. C CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N, $ DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) C DO 30 I = 1, M CALL DSWAP( N, H( 1, I ), 1, H( 1, M+I ), 1 ) 30 CONTINUE C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DORMQR( 'Left', 'No Transpose', N, N, M, DWORK, N, $ DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C C Perform an RQ decomposition Z12 = R4*Q4. C ITAU = 1 IWRK = ITAU + M CALL DGERQF( M, M, Z( 1, M+1 ), LDZ, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) C C Update H. C CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ, $ DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ, $ DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C C Exchange Z11 and Z12 and set the strictly lower triangular part C of Z11 to zero. C DUM( 1 ) = ZERO C DO 40 I = 1, M - 1 CALL DSWAP( M, Z( 1, I ), 1, Z( 1, M+I ), 1 ) CALL DCOPY( M-I, DUM, 0, Z( I+1, I ), 1 ) 40 CONTINUE C CALL DSWAP( M, Z( 1, M ), 1, Z( 1, N ), 1 ) C C STEP 2: Eliminations in H. C DO 90 K = 1, M C C I. Annihilate H(m+k:n-1,k). C DO 50 J = K, M-1 C C Determine a Givens rotation to annihilate H(m+j,k) from the C left. C CALL DLARTG( H( M+J+1, K ), H( M+J, K ), CO, SI, TMP1 ) C C Update H. C H( M+J+1, K ) = TMP1 H( M+J, K ) = ZERO CALL DROT( N-K, H( M+J+1, K+1 ), LDH, H( M+J, K+1 ), LDH, $ CO, SI ) C C Update T. C CALL DROT( J+1, T( M+J+1, M+1 ), LDT, T( M+J, M+1 ), LDT, $ CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate T(m+j,m+j+1) from C the right. C CALL DLARTG( T( M+J, M+J ), T( M+J, M+J+1 ), CO, SI, TMP1 ) C C Update T. C CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J+1 ), 1, CO , SI ) T( M+J, M+J ) = TMP1 T( M+J, M+J+1 ) = ZERO CALL DROT( M-J, T( M+J+1, M+J ), 1, T( M+J+1, M+J+1 ), 1, $ CO, SI ) CALL DROT( J+1, T( 1, J ), 1, T( 1, J+1 ), 1, CO, SI ) C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DROT( M, U11( 1, J ), 1, U11( 1, J+1 ), 1, CO, SI ) CALL DROT( M, U12( 1, J ), 1, U12( 1, J+1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(j+1,j) from the C left. C CALL DLARTG( T( J, J ), T( J+1, J ), CO, SI, TMP1 ) C C Update T. C T( J, J ) = TMP1 T( J+1, J ) = ZERO CALL DROT( N-J, T( J, J+1 ), LDT, T( J+1, J+1 ), LDT, CO, SI $ ) C C Update H. C CALL DROT( N-K+1, H( J, K ), LDH, H( J+1, K ), LDH, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI ) END IF 50 CONTINUE C C II. Annihilate H(n,k). C C Determine a Givens rotation to annihilate H(n,k) form the left. C CALL DLARTG( H( M, K ), H( N, K ), CO, SI, TMP1 ) C C Update H. C H( M, K ) = TMP1 H( N, K ) = ZERO CALL DROT( N-K, H( M, K+1 ), LDH, H( N, K+1 ), LDH, CO, SI ) C C Update T. C CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI ) TMP1 = -SI*T( M, M ) T( M, M ) = CO*T( M, M ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(n,m) from the C right. C CALL DLARTG( T( N, N ), TMP1, CO, SI, TMP2 ) C C Update T. C CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI ) T( N, N ) = TMP2 C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI ) END IF C C III. Annihilate H(k+1:m,k). C DO 60 J = M, K+1, -1 C C Determine a Givens rotation to annihilate H(j,k) from the C left. C CALL DLARTG( H( J-1, K ), H( J, K ), CO, SI, TMP1 ) C C Update H. C H( J-1, K ) = TMP1 H( J, K ) = ZERO CALL DROT( N-K, H( J-1, K+1 ), LDH, H( J, K+1 ), LDH, CO, SI $ ) C C Update T. C CALL DROT( N-J+2, T( J-1, J-1 ), LDT, T( J, J-1 ), LDT, CO, $ SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(j,j-1) from the C right. C CALL DLARTG( T( J, J ), T( J, J-1 ), CO, SI, TMP1 ) C C Update T. C CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J-1 ), 1, CO, SI ) CALL DROT( M-J+2, T( M+J-1, M+J ), 1, T( M+J-1, M+J-1 ), 1, $ CO, SI ) T( J, J ) = TMP1 T( J, J-1 ) = ZERO CALL DROT( J-1, T( 1, J ), 1, T( 1, J-1 ), 1, CO, SI ) C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DROT( M, U11( 1, J ), 1, U11( 1, J-1 ), 1, CO, SI ) CALL DROT( M, U12( 1, J ), 1, U12( 1, J-1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(m+j-1,m-j) from C the left. C CALL DLARTG( T( M+J, M+J ), T( M+J-1, M+J ), CO, SI, TMP1 ) C C Update T. C T( M+J, M+J ) = TMP1 T( M+J-1, M+J ) = ZERO CALL DROT( J-1, T( M+J, M+1 ), LDT, T( M+J-1, M+1 ), LDT, $ CO, SI ) C C Update H. C CALL DROT( N-K+1, H( M+J, K ), LDH, H( M+J-1, K ), LDH, CO, $ SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI $ ) END IF 60 CONTINUE C C IV. Annihilate H(m+k,k+1:m-1). C DO 70 J = K+1, M-1 C C Determine a Givens rotation to annihilate H(m+k,j) from the C right. C CALL DLARTG( H( M+K, J+1 ), H( M+K, J ), CO, SI, TMP1 ) C C Update H. C CALL DROT( M, H( 1, J+1 ), 1, H( 1, J ), 1, CO, SI ) H( M+K, J+1 ) = TMP1 H( M+K, J ) = ZERO CALL DROT( M-K, H( M+K+1, J+1 ), 1, H( M+K+1, J ), 1, CO, SI $ ) C C Update Z. C CALL DROT( J+1, Z( 1, J+1 ), 1, Z( 1, J ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(j+1,j) from the C left. C CALL DLARTG( Z( J, J ), Z( J+1, J ), CO, SI, TMP1 ) C C Update Z. C Z( J, J ) = TMP1 Z( J+1, J ) = ZERO CALL DROT( N-J, Z( J, J+1 ), LDZ, Z( J+1, J+1 ), LDZ, CO, SI $ ) CALL DROT( J+1, Z( M+J, M+1 ), LDZ, Z( M+J+1, M+1 ), LDZ, $ CO, SI ) C IF( LCMPU2 ) THEN C C Update U21 and U22. C CALL DROT( M, U21( 1, J ), 1, U21( 1, J+1 ), 1, CO, SI ) CALL DROT( M, U22( 1, J ), 1, U22( 1, J+1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(m+j,m+j+1) from C the right. C CALL DLARTG( Z( M+J, M+J ), Z( M+J, M+J+1 ), CO, SI, TMP1 ) C C Update Z. C Z( M+J, M+J ) = TMP1 Z( M+J, M+J+1 ) = ZERO CALL DROT( M, Z( 1, M+J ), 1, Z( 1, M+J+1 ), 1, CO, SI ) CALL DROT( M-J, Z( M+J+1, M+J ), 1, Z( M+J+1, M+J+1 ), 1, $ CO, SI ) C C Update H. C CALL DROT( M, H( 1, M+J ), 1, H( 1, M+J+1 ), 1, CO, SI ) CALL DROT( M-K+1, H( M+K, M+J ), 1, H( M+K, M+J+1 ), 1, CO, $ SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI $ ) END IF 70 CONTINUE C C V. Annihilate H(m+k,m). C IF( K.LT.M ) THEN C C Determine a Givens rotation to annihilate H(m+k,m) from the C right. C CALL DLARTG( H( M+K, N ), H( M+K, M ), CO, SI, TMP1 ) C C Update H. C H( M+K, N ) = TMP1 H( M+K, M ) = ZERO CALL DROT( M, H( 1, N ), 1, H( 1, M ), 1, CO, SI ) CALL DROT( M-K, H( M+K+1, N ), 1, H( M+K+1, M ), 1, CO, SI ) C C Update Z. C CALL DROT( M, Z( 1, N ), 1, Z( 1, M ), 1, CO, SI ) TMP1 = -SI*Z( N, N ) Z( N, N ) = CO*Z( N, N ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(n,m) from the C left. C CALL DLARTG( Z( M, M ), TMP1, CO, SI, TMP2 ) C C Update Z. C CALL DROT( M, Z( M, M+1 ), LDZ, Z( N, M+1 ), LDZ, CO, SI ) Z( M, M ) = TMP2 C IF( LCMPU2 ) THEN C C Update U2. C CALL DROT( M, U21( 1, M ), 1, U22( 1, M ), 1, CO, SI ) END IF ELSE C C Determine a Givens rotation to annihilate H(n,m) from the C left. C CALL DLARTG( H( M, M ), H( N, M ), CO, SI, TMP1 ) C C Update H. C H( M, M ) = TMP1 H( N, M ) = ZERO CALL DROT( M, H( M, M+1 ), LDH, H( N, M+1 ), LDH, CO, SI ) C C Update T. C CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI ) T( M, M ) = CO*T( M, M ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T( N, M ) from the C right. C CALL DLARTG( T( N, N ), -SI*T( M, M ), CO, SI, TMP2 ) C C Update T. C CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI ) T( N, N ) = TMP2 C IF( LCMPU1 ) THEN C C Update U1. C CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI ) END IF END IF C C VI. Annihilate H(m+k,m+k+2:n). C DO 80 J = M, K+2, -1 C C Determine a Givens rotation to annihilate H(m+k,m+j) from C the right. C CALL DLARTG( H( M+K, M+J-1 ), H( M+K, M+J ), CO, SI, TMP1 ) C C Update H. C CALL DROT( M, H( 1, M+J-1 ), 1, H( 1, M+J ), 1, CO, SI ) H( M+K, M+J-1 ) = TMP1 H( M+K, M+J ) = ZERO CALL DROT( M-K, H( M+K+1, M+J-1 ), 1, H( M+K+1, M+J ), 1, $ CO, SI ) C C Update Z. C CALL DROT( M, Z( 1, M+J-1 ), 1, Z( 1, M+J ), 1, CO, SI ) CALL DROT( M-J+2, Z( M+J-1, M+J-1 ), 1, Z( M+J-1, M+J ), 1, $ CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate Z(m+j-1,m+j) from C the left. C CALL DLARTG( Z( M+J, M+J ), Z( M+J-1, M+J ), CO, SI, TMP1 ) C C Update Z. C Z( M+J, M+J ) = TMP1 Z( M+J-1, M+J ) = ZERO CALL DROT( J-1, Z( M+J, M+1 ), LDZ, Z( M+J-1, M+1 ), LDZ, $ CO, SI ) CALL DROT( N-J+2, Z( J, J-1 ), LDZ, Z( J-1, J-1 ), LDZ, CO, $ SI ) C IF( LCMPU2 ) THEN C C Update U2. C CALL DROT( M, U21( 1, J ), 1, U21( 1, J-1 ), 1, CO, SI ) CALL DROT( M, U22( 1, J ), 1, U22( 1, J-1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(j,j-1) from the C right. C CALL DLARTG( Z( J, J ), Z( J, J-1 ), CO, SI, TMP1 ) C C Update Z. C Z( J, J ) = TMP1 Z( J, J-1 ) = ZERO CALL DROT( J-1, Z( 1, J ), 1, Z( 1, J-1 ), 1, CO, SI ) C C Update H. C CALL DROT( M, H( 1, J ), 1, H( 1, J-1 ), 1, CO, SI ) CALL DROT( M-K+1, H( M+K, J ), 1, H( M+K, J-1 ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI ) END IF 80 CONTINUE C 90 CONTINUE C C Now T, Z, H are in block forms (1) and H22' is upper Hessenberg. C C STEP 3: Apply periodic QZ algorithm to the generalized matrix C C -1 -1 -1 -1 C product H22 T22 T11 H11 Z11 Z22 to transform H22' C to upper quasi-triangular form while T11, T22', Z11, Z22', C and H11 stay in upper triangular form. C C Determine mode of computations. C IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 ) THEN CMPQ = 'Initialize' IQ = 1 IMAT = 6*MM + 1 IWRK = 12*MM + 1 ELSE CMPQ = 'No Computation' IMAT = 1 IWRK = 6*MM + 1 END IF C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C C Save matrices in structure that is required by MB03BD. C CALL MA02AD( 'Lower', M, M, H( M+1, M+1 ), LDH, DWORK( IMAT ), M ) CALL DCOPY( M-1, H( M+1, M+2 ), LDH+1, DWORK( IMAT+1 ), M+1 ) CALL DLASET( 'Lower', M-2, M-2, ZERO, ZERO, DWORK( IMAT+2 ), M ) CALL MA02AD( 'Lower', M, M, T( M+1, M+1 ), LDT, DWORK( IMAT+MM ), $ M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+MM+1 ), $ M ) CALL DLACPY( 'Upper', M, M, T, LDT, DWORK( IMAT+2*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+2*MM+1 ), $ M ) CALL DLACPY( 'Upper', M, M, H, LDH, DWORK( IMAT+3*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+3*MM+1 ), $ M ) CALL DLACPY( 'Upper', M, M, Z, LDZ, DWORK( IMAT+4*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+4*MM+1 ), $ M ) CALL MA02AD( 'Lower', M, M, Z( M+1, M+1 ), LDZ, $ DWORK( IMAT+5*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+5*MM+1 ), $ M ) C IWORK( M+1 ) = 1 IWORK( M+2 ) = -1 IWORK( M+3 ) = -1 IWORK( M+4 ) = 1 IWORK( M+5 ) = -1 IWORK( M+6 ) = -1 C C Apply periodic QZ algorithm. C Workspace: need IWRK + MAX( 2*M, 48 ) - 1. C Integer workspace: need M + 18. C CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 6, M, 1, 1, M, $ IWORK( M+1 ), DWORK( IMAT ), M, M, DWORK( IQ ), M, M, $ ALPHAR, ALPHAI, BETA, IWORK, IWORK( M+7 ), $ LIWORK-( M+6 ), DWORK( IWRK ), LDWORK-IWRK+1, IWARN, $ INFO ) IF( IWARN.GT.0 ) THEN INFO = 1 RETURN ELSE IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Compute the "non-negative" eigenvalues of the pencil aTZ - bH. C These are the eigenvalues with positive real parts or with C non-negative imaginary parts, when real parts are zero. C DO 100 I = 1, M EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) ) ALPHAR( I ) = DIMAG( EIG ) ALPHAI( I ) = DBLE( EIG ) TMP2 = PREC*DLAPY2( ALPHAR( I ), ALPHAI( I ) ) IF( ABS( ALPHAR( I ) ).LT.TMP2 ) THEN ALPHAR( I ) = ZERO IF( ALPHAI( I ).LT.ZERO ) $ ALPHAI( I ) = -ALPHAI( I ) END IF IF( ABS( ALPHAI( I ) ).LT.TMP2 ) THEN ALPHAI( I ) = ZERO IF( ALPHAR( I ).LT.ZERO ) $ ALPHAR( I ) = -ALPHAR( I ) END IF IF( IWORK( I ).GE.2*EMIN .AND. IWORK( I ).LE.2*EMAX ) THEN C C If B = SQRT(BASE**IWORK(i)) is between underflow and C overflow threshold, BETA(i) is divided by B. C BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I ) ) IWORK( I ) = 0 ELSE C C The eigenvalues are defined by ALPHAR, ALPHAI, BETA, and C IWORK, as for the SLICOT Library routine MB03BD. C INFO = 3 IF( MOD( IWORK( I ), 2 ).NE.0 ) $ BETA( I ) = BETA( I )/SQRB IWORK( I ) = IWORK( I )/2 END IF 100 CONTINUE C IF( LTRI ) THEN C C Update H. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, H, LDH ) CALL MA02AD( 'Full', M, M, DWORK( IMAT ), M, H( M+1, M+1 ), $ LDH ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ+3*MM ), M, H( 1, M+1 ), LDH, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK, M, ZERO, H( 1, M+1 ), $ LDH ) C C Update T. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, T, LDT ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ+3*MM ), M, T( 1, M+1 ), LDT, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK( IQ+2*MM ), M, ZERO, $ T( 1, M+1 ), LDT ) CALL MA02AD( 'Upper', M, M, DWORK( IMAT+MM ), M, T( M+1, M+1 ), $ LDT ) C C Update Z. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+4*MM ), M, Z, LDZ ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ+5*MM ), M, Z( 1, M+1 ), LDZ, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK, M, ZERO, Z( 1, M+1 ), $ LDZ ) CALL MA02AD( 'Upper', M, M, DWORK( IMAT+5*MM ), M, $ Z( M+1, M+1 ), LDZ ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1, LDQ1, DWORK( IQ+3*MM ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1( 1, M+1 ), LDQ1, DWORK( IQ+MM ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ), $ LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2, LDQ2, DWORK( IQ+4*MM ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ), $ LDQ2 ) END IF C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U11, LDU11, DWORK( IQ+2*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U11, LDU11 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U12, LDU12, DWORK( IQ+2*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U12, LDU12 ) END IF C IF( LCMPU2 ) THEN C C Update U21 and U22. C CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U21, LDU21, DWORK( IQ+5*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U21, LDU21 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U22, LDU22, DWORK( IQ+5*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U22, LDU22 ) END IF END IF C DWORK( 1 ) = OPTDW DWORK( 2 ) = BASE RETURN C *** Last line of MB04AD *** END slicot-5.0+20101122/src/MB04BD.f000077500000000000000000001206741201767322700153710ustar00rootroot00000000000000 SUBROUTINE MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1, $ LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F, $ LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK, $ LIWORK, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 real N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH with C C ( A D ) ( C V ) C S = ( ) and H = ( ). (1) C ( E A' ) ( W -C' ) C C Optionally, if JOB = 'T', decompositions of S and H will be C computed via orthogonal transformations Q1 and Q2 as follows: C C ( Aout Dout ) C Q1' S J Q1 J' = ( ), C ( 0 Aout' ) C C ( Bout Fout ) C J' Q2' J S Q2 = ( ) =: T, (2) C ( 0 Bout' ) C C ( C1out Vout ) ( 0 I ) C Q1' H Q2 = ( ), where J = ( ) C ( 0 C2out' ) ( -I 0 ) C C and Aout, Bout, C1out are upper triangular, C2out is upper quasi- C triangular and Dout and Fout are skew-symmetric. The notation M' C denotes the transpose of the matrix M. C Optionally, if COMPQ1 = 'I', the orthogonal transformation matrix C Q1 will be computed. C Optionally, if COMPQ2 = 'I', the orthogonal transformation matrix C Q2 will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; S and H will not C necessarily be transformed as in (2). C = 'T': put S and H into the forms in (2) and return the C eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'I': the array Q1 is initialized internally to the unit C matrix, and the orthogonal matrix Q1 is returned; C = 'U': the array Q1 contains an orthogonal matrix Q on C entry, and the product Q*Q1 is returned, where Q1 C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reduce C S and H to the forms in (2), for COMPQ1 = 'I'. C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'I': on exit, the array Q2 contains the orthogonal C matrix Q2; C = 'U': on exit, the array Q2 contains the matrix product C J*Q*J'*Q2, where Q2 is the product of the C orthogonal transformations that are applied to C the pencil aS - bH to reduce S and H to the forms C in (2), for COMPQ2 = 'I'. C Setting COMPQ2 <> 'N' assumes COMPQ2 = COMPQ1. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N has to be even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Aout; otherwise, it contains the C upper triangular matrix A obtained just before the C application of the periodic QZ algorithm. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix E, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix D. C The entries on the diagonal and the first superdiagonal of C this array need not be set, but are assumed to be zero. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns C 2 to N/2+1 of this array contains the strictly upper C triangular part of the skew-symmetric matrix Dout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix D just before the application C of the periodic QZ algorithm. The remaining entries are C meaningless. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C C1 (input/output) DOUBLE PRECISION array, dimension C (LDC1, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix C1 = C. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix C1out; otherwise, it contains the C upper triangular matrix C1 obtained just before the C application of the periodic QZ algorithm. C C LDC1 INTEGER C The leading dimension of the array C1. C LDC1 >= MAX(1, N/2). C C VW (input/output) DOUBLE PRECISION array, dimension C (LDVW, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix W, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C symmetric matrix V. C On exit, if JOB = 'T', the N/2-by-N/2 part in the columns C 2 to N/2+1 of this array contains the matrix Vout. C If JOB = 'E', the N/2-by-N/2 part in the columns 2 to C N/2+1 of this array contains the matrix V just before the C application of the periodic QZ algorithm. C C LDVW INTEGER C The leading dimension of the array VW. C LDVW >= MAX(1, N/2). C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1, N) C On entry, if COMPQ1 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q and the transformation matrix Q1 C used to transform the matrices S and H. C On exit, if COMPQ1 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q1. C If COMPQ1 = 'N', this array is not referenced. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C On exit, if COMPQ2 = 'U', then the leading N-by-N part of C this array contains the product of the matrix J*Q*J' and C the transformation matrix Q2 used to transform the C matrices S and H. C On exit, if COMPQ2 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q2. C If COMPQ2 = 'N', this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'. C C B (output) DOUBLE PRECISION array, dimension (LDB, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Bout; otherwise, it contains the C upper triangular matrix B obtained just before the C application of the periodic QZ algorithm. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (output) DOUBLE PRECISION array, dimension (LDF, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of this array contains the strictly C upper triangular part of the skew-symmetric matrix Fout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of this array contains the strictly upper C triangular part of the skew-symmetric matrix F just before C the application of the periodic QZ algorithm. C The entries on the leading N/2-by-N/2 lower triangular C part of this array are not referenced. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C C2 (output) DOUBLE PRECISION array, dimension (LDC2, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix C2out; otherwise, it contains C the upper Hessenberg matrix C2 obtained just before the C application of the periodic QZ algorithm. C C LDC2 INTEGER C The leading dimension of the array C2. C LDC2 >= MAX(1, N/2). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N/2+12. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -27, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N', C LDWORK >= N**2 + MAX(N,32); C if JOB = 'T' or COMPQ1 <> 'N' or COMPQ2 <> 'N', C LDWORK >= 2*N**2 + MAX(N,32). C For good performance LDWORK should generally 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 value; C = 1: problem during computation of the eigenvalues; C = 2: periodic QZ algorithm did not converge in the SLICOT C Library subroutine MB03BD. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in S, T, and H such that A, B, and C1 are C upper triangular and C2 is upper Hessenberg. Finally, the periodic C QZ algorithm is applied to transform C2 to upper quasi-triangular C form while A, B, and C1 stay in upper triangular form. C See also page 27 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C C REVISIONS C C V. Sima, Oct. 2009 (SLICOT version of the routine DHAUTR). C V. Sima, Nov. 2010. C C KEYWORDS C C periodic QZ algorithm, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2, JOB INTEGER INFO, LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1, $ LDQ2, LDVW, LDWORK, LIWORK, N C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), C1( LDC1, * ), $ C2( LDC2, * ), DE( LDDE, * ), DWORK( * ), $ F( LDF, * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ VW( LDVW, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LINIQ1, LINIQ2, LTRI, LUPDQ1, $ LUPDQ2 CHARACTER*16 CMPQ, CMPSC INTEGER I, IMAT, IWARN, IWRK, J, K, M, MJ1, MJ2, MJ3, $ MK1, MK2, MK3, MM, OPTDW DOUBLE PRECISION BASE, CO, EMAX, EMIN, MU, NU, PREC, SI, TMP1, $ TMP2 COMPLEX*16 EIG C C .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLAPY2 EXTERNAL DDOT, DLAMCH, DLAPY2, LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLARF, DLARFG, $ DLARTG, DLASET, DROT, DSYMV, DSYR2, MA02AD, $ MB01LD, MB01MD, MB01ND, MB03BD, XERBLA C C ... Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M LTRI = LSAME( JOB, 'T' ) LINIQ1 = LSAME( COMPQ1, 'I' ) LINIQ2 = LSAME( COMPQ2, 'I' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LCMPQ1 = LUPDQ1 .OR. LINIQ1 LCMPQ2 = LUPDQ2 .OR. LINIQ2 IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN OPTDW = 8*MM + MAX( N, 32 ) ELSE OPTDW = 4*MM + MAX( N, 32 ) END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -3 ELSE IF( ( LINIQ2 .AND. .NOT.LINIQ1 ) .OR. $ ( LUPDQ2 .AND. .NOT.LUPDQ1 ) ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDC1.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDVW.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDQ1.LT.1 .OR. ( LCMPQ1 .AND. LDQ1.LT.N ) ) THEN INFO = -14 ELSE IF( LDQ2.LT.1 .OR. ( LCMPQ2 .AND. LDQ2.LT.N ) ) THEN INFO = -16 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -18 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -20 ELSE IF( LDC2.LT.MAX( 1, M ) ) THEN INFO = -22 ELSE IF( LIWORK.LT.M+12 ) THEN INFO = -27 ELSE IF( LDWORK.LT.OPTDW ) THEN INFO = -29 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB04BD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C C Determine machine constants. C BASE = DLAMCH( 'Base' ) EMIN = DLAMCH( 'Minimum Exponent' ) EMAX = DLAMCH( 'Largest Exponent' ) PREC = DLAMCH( 'Precision' ) C C STEP 1: Reduce S to skew-Hamiltonian triangular form. C IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) C DUM( 1 ) = ZERO C DO 10 K = 1, M - 1 C C Generate elementary reflector H(k) = I - nu * v * v' to C annihilate E(k+2:m,k). C MK2 = MIN( K+2, M ) MK3 = MK2 + 1 TMP1 = DE( K+1, K ) CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU ) IF( NU.NE.ZERO ) THEN DE( K+1, K ) = ONE C C Apply H(k) from both sides to E(k+1:m,k+1:m). C Compute x := nu * E(k+1:m,k+1:m) * v. C CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C E := E + v * w' - w * v'. C CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1, $ DE( K+1, K+1 ), LDDE ) C C Apply H(k) to W(k+1:m,1:k) from the left (and implicitly to C W(1:k,k+1:m) from the right). C CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU, $ VW( K+1, 1 ), LDVW, DWORK ) C C Apply H(k) from both sides to W(k+1:m,k+1:m). C Compute x := nu * W(k+1:m,k+1:m) * v. C CALL DSYMV( 'Lower', M-K, NU, VW( K+1, K+1 ), LDVW, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C W := W - v * w' - w * v'. C CALL DSYR2( 'Lower', M-K, -ONE, DE( K+1, K ), 1, DWORK, 1, $ VW( K+1, K+1 ), LDVW ) C C Apply H(k) from the right hand side to A(1:m,k+1:m) and C C1(1:m,k+1:m). C CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ A( 1, K+1 ), LDA, DWORK ) CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ C1( 1, K+1 ), LDC1, DWORK ) C IF( LCMPQ1 ) THEN C C Apply H(k) from the right hand side to Q1(1:n,m+k+1:n). C CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU, $ Q1( 1, M+K+1 ), LDQ1, DWORK ) END IF DE( K+1, K ) = TMP1 END IF C C Determine a Givens rotation to annihilate E(k+1,k) from the C left. C TMP2 = A( K+1, K ) CALL DLARTG( TMP2, DE( K+1, K ), CO, SI, A( K+1, K ) ) C C Update A, E and D. C CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO, $ SI ) CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO, $ SI ) C C Update C1, W and V. C CALL DROT( K, VW( K+1, 1 ), LDVW, C1( K+1, 1 ), LDC1, CO, -SI ) CALL DROT( M-K-1, VW( MK2, K+1 ), 1, C1( K+1, MK2 ), LDC1, CO, $ -SI ) CALL DROT( K, C1( 1, K+1 ), 1, VW( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, VW( K+1, MK3 ), LDVW, C1( MK2, K+1 ), 1, CO, $ -SI ) C C Fix the diagonal part. C TMP1 = C1( K+1, K+1 ) TMP2 = VW( K+1, K+2 ) C1( K+1, K+1 ) = ( CO - SI )*( CO + SI )*TMP1 + $ CO*SI*( VW( K+1, K+1 ) + TMP2 ) TMP1 = TWO*CO*SI*TMP1 VW( K+1, K+2 ) = CO**2*TMP2 - SI**2*VW( K+1, K+1 ) - TMP1 VW( K+1, K+1 ) = CO**2*VW( K+1, K+1 ) - SI**2*TMP2 - TMP1 C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, K+1 ), 1, Q1( 1, M+K+1 ), 1, CO, SI ) END IF C C Generate elementary reflector P(k) to annihilate A(k+1:m,k). C TMP1 = A( K, K ) CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU ) IF( NU.NE.ZERO ) THEN A( K, K ) = ONE C C Apply P(k) from the left hand side to A(k:m,k+1:m). C CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU, $ A( K, K+1 ), LDA, DWORK ) C C Apply P(k) to D(1:k-1,k:m) from the right (and implicitly C to D(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ DE( 1, K+1 ), LDDE, DWORK ) C C Apply P(k) from both sides to D(k:m,k:m). C Compute x := nu * D(k:m,k:m) * v. C CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C D := D + v * w' - w * v'. C CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1, $ DE( K, K+1 ), LDDE ) C C Apply P(k) from the left hand side to C1(k:m,k+1:m). C CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, C1( K, 1 ), $ LDC1, DWORK ) C C Apply P(k) to V(1:k-1,k:m) from the right (and implicitly C to V(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ VW( 1, K+1 ), LDVW, DWORK ) C C Apply P(k) from both sides to V(k:m,k:m). C Compute x := nu * V(k:m,k:m) * v. C CALL DSYMV( 'Upper', M-K+1, NU, VW( K, K+1 ), LDVW, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C V := V - v * w' - w * v'. C CALL DSYR2( 'Upper', M-K+1, -ONE, A( K, K ), 1, DWORK, 1, $ VW( K, K+1 ), LDVW ) C IF( LCMPQ1 ) THEN C C Apply P(k) from the right hand side to Q1(1:n,k:m). C CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU, $ Q1( 1, K ), LDQ1, DWORK ) END IF A( K, K ) = TMP1 END IF C C Set A(k+1:m,k) to zero in order to be able to apply MB03BD. C CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 ) 10 CONTINUE C C The following operations do not preserve the Hamiltonian structure C of H. -C1 is copied to C2. The lower triangular part of W(1:m,1:m) C and its transpose are stored in DWORK. Then, the transpose of the C upper triangular part of V(1:m,1:m) is saved in the lower C triangular part of VW(1:m,2:m+1). C CALL DLACPY( 'Full', M, M, A, LDA, B, LDB ) CALL DLACPY( 'Upper', M, M, DE( 1, 2 ), LDDE, F, LDF ) C DO 30 J = 1, M DO 20 I = 1, M C2( I, J ) = -C1( I, J ) 20 CONTINUE 30 CONTINUE C CALL DLACPY( 'Lower', M, M, VW, LDVW, DWORK, M ) CALL MA02AD( 'Lower', M, M, VW, LDVW, DWORK, M ) C CALL MA02AD( 'Upper', M, M, VW( 1, 2 ), LDVW, VW( 1, 2 ), LDVW ) C IF ( LCMPQ2 ) THEN CALL DLACPY( 'Full', M, M, Q1( M+1, M+1 ), LDQ1, Q2, LDQ2 ) C DO 50 J = 1, M DO 40 I = M + 1, N Q2( I, J ) = -Q1( I-M, J+M ) 40 CONTINUE 50 CONTINUE C DO 70 J = M + 1, N DO 60 I = 1, M Q2( I, J ) = -Q1( I+M, J-M ) 60 CONTINUE 70 CONTINUE C CALL DLACPY( 'Full', M, M, Q1, LDQ1, Q2( M+1, M+1 ), LDQ2 ) END IF C C STEP 2: Eliminations in H. C DO 120 K = 1, M MK1 = MIN( K+1, M ) C C I. Annihilate W(k:m-1,k). C DO 80 J = K, M - 1 MJ3 = MIN( J+3, M+1 ) C C Determine a Givens rotation to annihilate W(j,k) from the C left. C CALL DLARTG( DWORK( ( K-1 )*M+J+1 ), DWORK( ( K-1 )*M+J ), $ CO, SI, TMP1 ) C C Update C2 and W. C CALL DROT( M, C2( 1, J+1 ), 1, C2( 1, J ), 1, CO, SI ) DWORK( ( K-1 )*M+J+1 ) = TMP1 DWORK( ( K-1 )*M+J ) = ZERO CALL DROT( M-K, DWORK( K*M+J+1 ), M, DWORK( K*M+J ), M, CO, $ SI ) C C Update A. C CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI ) TMP1 = -SI*A( J+1, J+1 ) A( J+1, J+1 ) = CO*A( J+1, J+1 ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate A(j+1,j) from the C left. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) C C Update A and D. C A( J, J ) = TMP2 CALL DROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI $ ) CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI ) CALL DROT( M-J-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE, $ CO, SI ) C C Update C1 and V. C CALL DROT( M-K+1, C1( J, K ), LDC1, C1( J+1, K ), LDC1, CO, $ SI ) CALL DROT( M, VW( J, 2 ), LDVW, VW( J+1, 2 ), LDVW, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI ) END IF 80 CONTINUE C C II. Annihilate W(m,k). C C Determine a Givens rotation to annihilate W(m,k) from the left. C CALL DLARTG( C1( M, K ), DWORK( M*K ), CO, SI, TMP1 ) C C Update C1 and W. C C1( M, K ) = TMP1 DWORK( M*K ) = ZERO CALL DROT( M-K, C1( M, MK1 ), LDC1, DWORK( M*MK1 ), M, CO, SI ) CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI ) C C Update A and D. C CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF C C III. Annihilate C1(k+1:m,k). C DO 90 J = M, K + 1, -1 MJ2 = MIN( J+2, M+1 ) C C Determine a Givens rotation to annihilate C1(j,k) from the C left. C CALL DLARTG( C1( J-1, K ), C1( J, K ), CO, SI, TMP1 ) C C Update C1 and V. C C1( J-1, K ) = TMP1 C1( J, K ) = ZERO CALL DROT( M-K, C1( J-1, MK1 ), LDC1, C1( J, MK1 ), LDC1, $ CO, SI ) CALL DROT( M, VW( J-1, 2 ), LDVW, VW( J, 2 ), LDVW , CO, SI $ ) C C Update A and D. C TMP1 = -SI*A( J-1, J-1 ) A( J-1, J-1 ) = CO*A( J-1, J-1 ) CALL DROT( M-J+1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI ) CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI ) CALL DROT( M-J, DE( J-1, MJ2 ), LDDE, DE( J, MJ2 ), LDDE, $ CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate A(j,j-1) from the C right. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) C C Update A. C A( J, J ) = TMP2 CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI ) C C Update C2 and W. C CALL DROT( M, C2( 1, J ), 1, C2( 1, J-1 ), 1, CO, SI ) CALL DROT( M-K+1, DWORK( ( K-1 )*M+J ), M, $ DWORK( ( K-1)*M+J-1 ), M, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI $ ) END IF 90 CONTINUE C C IV. Annihilate W(k,k+1:m-1). C DO 100 J = K + 1, M - 1 MJ2 = MIN( J+2, M ) C C Determine a Givens rotation to annihilate W(k,j) from the C right. C CALL DLARTG( DWORK( J*M+K ), DWORK( ( J-1 )*M+K ), CO, $ SI, TMP1 ) C C Update C1 and W. C CALL DROT( M, C1( 1, J+1 ), 1, C1( 1, J ), 1, CO, SI ) DWORK( ( J-1 )*M+K ) = ZERO DWORK( J*M+K ) = TMP1 CALL DROT( M-K, DWORK( J*M+MK1 ), 1, DWORK( ( J-1 )*M+K+1 ), $ 1, CO, SI ) C C Update B. C CALL DROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI ) TMP1 = -SI*B( J+1, J+1 ) B( J+1, J+1 ) = CO*B( J+1, J+1 ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate B(j+1,j) from the C left. C CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 ) C C Update B and F. C B( J, J ) = TMP2 CALL DROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO, SI $ ) CALL DROT( J-1, F( 1, J ), 1, F( 1, J+1 ), 1, CO, SI ) CALL DROT( M-J-1, F( J, MJ2 ), LDF, F( J+1, MJ2 ), LDF, CO, $ SI ) C C Update C2 and V. C CALL DROT( M-K+1, C2( J, K ), LDC2, C2( J+1, K ), LDC2, CO, $ SI ) CALL DROT( M, VW( 1, J+1 ), 1, VW( 1, J+2 ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI $ ) END IF 100 CONTINUE C C V. Annihilate W(k,m). C IF( K.LT.M ) THEN C C Determine a Givens rotation to annihilate W(k,m) from the C right. C CALL DLARTG( C2( M, K ), DWORK( ( M-1 )*M+K ), CO, SI, TMP1 $ ) C C Update C1, C2, W and V. C CALL DROT( M, VW( 1, M+1 ), 1, C1( 1, M ), 1, CO, SI ) C2( M, K ) = TMP1 DWORK( ( M-1 )*M+K ) = ZERO CALL DROT( M-K, C2( M, K+1 ), LDC2, DWORK( ( M-1 )*M+K+1 ), $ 1, CO, SI ) C C Update B and F. C CALL DROT( M-1, F( 1, M ), 1, B( 1, M ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI ) END IF ELSE C C Determine a Givens rotation to annihilate W(m,m) from the C left. C CALL DLARTG( C1( M, M ), DWORK( MM ), CO, SI, TMP1 ) C C Update C1, C2, W and V. C C1( M, M ) = TMP1 DWORK( MM ) = ZERO CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI ) C C Update A and D. C CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF END IF C C VI. Annihilate C2(k+2:m,k). C DO 110 J = M, K + 2, -1 MJ1 = MIN( J+1, M ) C C Determine a Givens rotation to annihilate C2(j,k) from the C left. C CALL DLARTG( C2( J-1, K ), C2( J, K ), CO, SI, TMP1 ) C C Update C2 and V. C C2( J-1, K ) = TMP1 C2( J, K ) = ZERO CALL DROT( M-K, C2( J-1, MK1 ), LDC2, C2( J, MK1 ), LDC2, $ CO, SI ) CALL DROT( M, VW( 1, J ), 1, VW( 1, J+1 ), 1, CO, SI ) C C Update B and F. C CALL DROT( M-J+1, B( J-1, J ), LDB, B( J, J ), LDB, CO, SI ) TMP1 = -SI*B( J-1, J-1 ) B( J-1, J-1 ) = CO*B( J-1, J-1 ) CALL DROT( J-2, F( 1, J-1 ), 1, F( 1, J ), 1, CO, SI ) CALL DROT( M-J, F( J-1, MJ1 ), LDF, F( J, MJ1 ), LDF, CO, SI $ ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate B(j,j-1) from the C right. C CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 ) B( J, J ) = TMP2 C C Update B. C CALL DROT( J-1, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI ) C C Update C1 and W. C CALL DROT( M, C1( 1, J ), 1, C1( 1, J-1 ), 1, CO, SI ) CALL DROT( M-K+1, DWORK( ( J-1 )*M+K ), 1, $ DWORK( ( J-2 )*M+K ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI ) END IF 110 CONTINUE 120 CONTINUE C C ( A1 D1 ) ( B1 F1 ) ( C11 V1 ) C Now we have S = ( ), T = ( ), H = ( ), C ( 0 A1' ) ( 0 B1' ) ( 0 C21' ) C C where A1, B1, and C11 are upper triangular, C21 is upper C Hessenberg, and D1 and F1 are skew-symmetric. C C STEP 3: Apply the periodic QZ algorithm to the generalized matrix C C -1 -1 C product C21 A1 C11 B1 in order to make C21 upper C quasi-triangular. C C Determine the mode of computations. C IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN CMPQ = 'Initialize' IMAT = 4*MM + 1 IWRK = 8*MM + 1 ELSE CMPQ = 'No Computation' IMAT = 1 IWRK = 4*MM + 1 END IF C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C C Save matrices in the form that is required by MB03BD. C CALL DLACPY( 'Full', M, M, C2, LDC2, DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IMAT+MM ), M ) CALL DLACPY( 'Full', M, M, C1, LDC1, DWORK( IMAT+2*MM ), M ) CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IMAT+3*MM ), M ) IWORK( 1 ) = 1 IWORK( 2 ) = -1 IWORK( 3 ) = 1 IWORK( 4 ) = -1 C C Apply periodic QZ algorithm. C Workspace: need OPTDW; C prefer larger. C CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 4, M, 1, 1, M, IWORK, $ DWORK( IMAT ), M, M, DWORK, M, M, ALPHAR, ALPHAI, $ BETA, IWORK( 5 ), IWORK( M+5 ), LIWORK-( M+4 ), $ DWORK( IWRK ), LDWORK-IWRK+1, IWARN, INFO ) IF( IWARN.GT.0 ) THEN INFO = 1 RETURN ELSE IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Compute the eigenvalues with nonnegative imaginary parts of the C pencil aS - bH. C DO 130 I = 1, M IF( IWORK( I+4 ).GE.2*EMIN .AND. IWORK( I+4 ).LE.2*EMAX ) THEN C C B = SQRT(BASE**IWORK(i+4)) is between underflow and overflow C threshold, BETA(i) is divided by B. C Set to zero negligible real and imaginary parts. C BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I+4 ) ) EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) ) ALPHAR( I ) = DIMAG( EIG ) ALPHAI( I ) = DBLE( EIG ) TMP2 = PREC*DLAPY2( ALPHAR( I ), ALPHAI( I ) ) IF( ABS( ALPHAR( I ) ).LT.TMP2 ) THEN ALPHAR( I ) = ZERO IF( ALPHAI( I ).LT.ZERO ) $ ALPHAI( I ) = -ALPHAI( I ) END IF IF( ABS( ALPHAI( I ) ).LT.TMP2 ) THEN ALPHAI( I ) = ZERO IF( ALPHAR( I ).LT.ZERO ) $ ALPHAR( I ) = -ALPHAR( I ) END IF ELSE C C Error. C INFO = 1 RETURN END IF 130 CONTINUE C IF( LTRI ) THEN C C Update C1 and C2. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, C1, LDC1 ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, C2, LDC2 ) C C Update V. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( 2*MM+1 ), M, VW( 1, 2 ), LDVW, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK, M, ZERO, VW( 1, 2 ), $ LDVW ) C C Update A. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+MM ), M, A, LDA ) C C Skew-symmetric update of D. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ), $ LDDE, DWORK( 2*MM+1 ), M, DE( 1, 2 ), LDDE, $ DWORK( IMAT ), LDWORK-IMAT+1, INFO ) C C Update B. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, B, LDB ) C C Skew-symmetric update of F. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, F, LDF, $ DWORK, M, F, LDF, DWORK( IMAT ), LDWORK-IMAT+1, $ INFO ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1, LDQ1, DWORK( 2*MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1( 1, M+1 ), LDQ1, DWORK( MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ), $ LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2, LDQ2, DWORK( 3*MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ), $ LDQ2 ) END IF END IF C DWORK( 1 ) = OPTDW RETURN C *** Last line of MB04BD *** END slicot-5.0+20101122/src/MB04DD.f000077500000000000000000000363211201767322700153660ustar00rootroot00000000000000 SUBROUTINE MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04DI.f000077500000000000000000000147641201767322700154020ustar00rootroot00000000000000 SUBROUTINE MB04DI( JOB, SGN, N, ILO, SCALE, M, V1, LDV1, V2, LDV2, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04DS.f000077500000000000000000000365531201767322700154140ustar00rootroot00000000000000 SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04DY.f000077500000000000000000000272121201767322700154120ustar00rootroot00000000000000 SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04GD.f000077500000000000000000000177441201767322700154010ustar00rootroot00000000000000 SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C C KEYWORDS C C Factorization, matrix algebra, matrix operations, orthogonal C 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 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, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( A( J, NKI ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO ) TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2 IF( TEMP2.LE.TOLZ ) 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 slicot-5.0+20101122/src/MB04HD.f000077500000000000000000003061401201767322700153710ustar00rootroot00000000000000 SUBROUTINE MB04HD( COMPQ1, COMPQ2, N, A, LDA, B, LDB, Q1, LDQ1, $ Q2, LDQ2, BWORK, IWORK, LIWORK, DWORK, LDWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To compute the transformed matrices A and B, using orthogonal C matrices Q1 and Q2 for a real N-by-N regular pencil C C ( A11 0 ) ( 0 B12 ) C aA - bB = a ( ) - b ( ), (1) C ( 0 A22 ) ( B21 0 ) C C where A11, A22 and B12 are upper triangular and the generalized C -1 -1 C matrix product A11 B12 A22 B21 is upper quasi-triangular, C such that the matrix Q2' A Q1 is upper triangular and Q2' B Q1 is C upper quasi-triangular. C C ARGUMENTS C C Mode Parameters C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'I': the array Q1 is initialized internally to the unit C matrix, and the orthogonal matrix Q1 is returned; C = 'U': the array Q1 contains an orthogonal matrix Q01 on C entry, and the matrix Q01*Q1 is returned, where Q1 C is the product of the orthogonal transformations C that are applied on the right to the pencil C aA - bB in (1). C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'I': the array Q2 is initialized internally to the unit C matrix, and the orthogonal matrix Q2 is returned; C = 'U': the array Q2 contains an orthogonal matrix Q02 on C entry, and the matrix Q02*Q2 is returned, where Q2 C is the product of the orthogonal transformations C that are applied on the left to the pencil aA - bB C in (1). C C Input/Output Parameters C C N (input) INTEGER C Order of the pencil aA - bB, N has to be even. C C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) C On entry, the leading N-by-N block diagonal part of this C array must contain the matrix A in (1). The off-diagonal C blocks need not be set to zero. C On exit, the leading N-by-N part of this array contains C the transformed upper triangular matrix. 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 block anti-diagonal part of C this array must contain the matrix B in (1). The diagonal C blocks need not be set to zero. C On exit, the leading N-by-N part of this array contains C the transformed upper quasi-triangular matrix. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1, N) C On entry, if COMPQ1 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q01, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q01 and the transformation matrix Q1 C used to transform the matrices A and B. C On exit, if COMPQ1 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q1. C If COMPQ1 = 'N' this array is not referenced. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'. C C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2, N) C On entry, if COMPQ2 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q02, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q02 and the transformation matrix Q2 C used to transform the matrices A and B. C On exit, if COMPQ2 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q2. C If COMPQ2 = 'N' this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'. C C Workspace C C BWORK LOGICAL array, dimension (N/2) C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N/2 + 32. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -16, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 2*N*N + MAX( N/2 + 168, 272 ). C For good performance LDWORK should be generally larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the periodic QZ algorithm failed to reorder the C eigenvalues (the problem is very ill-conditioned) in C the SLICOT Library routine MB03KD; C = 2: the standard QZ algorithm failed in the LAPACK C routine DGGEV, called by the SLICOT routine MB03DD; C = 3: the standard QZ algorithm failed in the LAPACK C routines DGGES or DHGEQZ, called by the SLICOT C routines MB03DD or MB03FD; C = 4: the standard QZ algorithm failed to reorder the C eigenvalues in the LAPACK routine DTGSEN, called by C the SLICOT routine MB03DD. C C METHOD C C First, the periodic QZ algorithm (see also [2] and [3]) is applied C -1 -1 C to the formal matrix product A11 B12 A22 B21 to reorder the C eigenvalues, i.e., orthogonal matrices V1, V2, V3 and V4 are C computed such that V2' A11 V1, V2' B12 V3, V4' A22 V3 and C V4' B21 V1 keep the triangular form, but they can be partitioned C into 2-by-2 block forms and the last diagonal blocks correspond to C all nonpositive real eigenvalues of the formal product, and the C first diagonal blocks correspond to the remaining eigenvalues. C C Second, Q1 = diag(V1, V3), Q2 = diag(V2, V4) and C C ( AA11 AA12 0 0 ) C ( ) C ( 0 AA22 0 0 ) C A := Q2' A Q1 =: ( ), C ( 0 0 AA33 AA34 ) C ( ) C ( 0 0 0 AA44 ) C C ( 0 0 BB13 BB14 ) C ( ) C ( 0 0 0 BB24 ) C B := Q2' B Q1 =: ( ), C ( BB31 BB32 0 0 ) C ( ) C ( 0 BB42 0 0 ) C C -1 -1 C are set, such that AA22 BB24 AA44 BB42 has only nonpositive C real eigenvalues. C C Third, the permutation matrix C C ( I 0 0 0 ) C ( ) C ( 0 0 I 0 ) C P = ( ), C ( 0 I 0 0 ) C ( ) C ( 0 0 0 I ) C C where I denotes the identity matrix of appropriate size, is used C to transform aA - bB to block upper triangular form C C ( AA11 0 | AA12 0 ) C ( | ) C ( 0 AA33 | 0 AA34 ) ( AA1 * ) C A := P' A P = (-----------+-----------) = ( ), C ( 0 0 | AA22 0 ) ( 0 AA2 ) C ( | ) C ( 0 0 | 0 AA44 ) C C ( 0 BB13 | 0 BB14 ) C ( | ) C ( BB31 0 | BB32 0 ) ( BB1 * ) C B := P' B P = (-----------+-----------) = ( ). C ( 0 0 | 0 BB24 ) ( 0 BB2 ) C ( | ) C ( 0 0 | BB42 0 ) C C Then, further orthogonal transformations that are provided by C MB03FD and MB03DD are used to triangularize the subpencil C aAA1 - bBB1. C C Finally, the subpencil aAA2 - bBB2 is triangularized by applying a C special permutation matrix. C C See also page 31 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C [2] Bojanczyk, A., Golub, G. H. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C In F.T. Luk (editor), Advanced Signal Processing Algorithms, C Architectures, and Implementations III, Proc. SPIE Conference, C vol. 1770, pp. 31-42, 1992. C C [3] Hench, J. J. and Laub, A. J. C Numerical Solution of the discrete-time periodic Riccati C equation. IEEE Trans. Automat. Control, 39, 1197-1210, 1994. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, December 08, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DBTUMT). C C REVISIONS C C V. Sima, Aug. 2009, Feb. 2010, Jul. 2010, Sep.-Nov. 2010. C C KEYWORDS C C Eigenvalue reordering, matrix pencil, periodic QZ algorithm, C upper (quasi-)triangular matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HUND2 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HUND2 = 2.0D+2 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2 INTEGER INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, LIWORK, N C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ Q1( LDQ1, * ), Q2( LDQ2, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LINIQ1, LINIQ2, LQUERY, LUPDQ1, $ LUPDQ2 INTEGER DIM1, DIM2, I, I1, I1LOLE, I1LORI, I1UPLE, $ I1UPRI, I2, I2LOLE, I2LORI, I2UPLE, I2UPRI, I3, $ IA, IA11, IA22, IALOLE, IALORI, IAUPLE, IAUPRI, $ IB, IB1, IB12, IB2, IB21, IBLOLE, IBLORI, $ IBUPLE, IBUPRI, IJ1, IJ2, ITMP, ITMP2, ITMP3, $ IV1, IV2, IV3, IV4, IWRK, J, K, KSCHUR, M, M1, $ M2, M4, MINWRK, MM, MP1, NR, NROW, OPTWRK, R, $ SDIM DOUBLE PRECISION BASE, LGBAS, TMP2, TMP3, ULP C C .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL LSAME, SB02OW DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME, SB02OW C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGGES, DGGEV, $ DLACPY, DLASET, DSCAL, DTGSEN, MA01BD, MB03BA, $ MB03DD, MB03FD, MB03KD, XERBLA C C .. Intrinsic Functions .. INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M LINIQ1 = LSAME( COMPQ1, 'I' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LINIQ2 = LSAME( COMPQ2, 'I' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LCMPQ1 = LINIQ1 .OR. LUPDQ1 LCMPQ2 = LINIQ2 .OR. LUPDQ2 LQUERY = LDWORK.EQ.-1 MINWRK = 2*N*N + MAX( M + 168, 272 ) C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.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( LDQ1.LT.1 .OR. LCMPQ1 .AND. LDQ1.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ2.LT.1 .OR. LCMPQ2 .AND. LDQ2.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LIWORK.LT.M + 32 ) THEN INFO = -14 ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINWRK ) THEN DWORK( 1 ) = MINWRK INFO = -16 END IF C IF( INFO.NE.0) THEN CALL XERBLA( 'MB04HD', -INFO ) RETURN ELSE C C Compute optimal workspace. C I = MAX( 1, MIN( 4, N ) ) CALL DGGES( 'Vectors', 'Vectors', 'Sorted', SB02OW, I, A, LDA, $ B, LDB, IDUM, DWORK, DWORK, DWORK, Q1, I, Q2, I, $ DWORK, -1, BWORK, INFO ) CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', SB02OW, I, A, $ LDA, B, LDB, IDUM, DWORK, DWORK, DWORK, Q1, I, Q2, $ I, DWORK( 2 ), -1, BWORK, INFO ) CALL DGGEV( 'No Vector', 'No Vector', 2, A, LDA, B, LDB, $ DWORK, DWORK, DWORK, DUM, 1, DUM, 1, DWORK( 3 ), $ -1, INFO ) CALL DTGSEN( 0, .TRUE., .TRUE., BWORK, I, A, LDA, B, LDB, $ DWORK, DWORK, DWORK, Q1, I, Q2, I, IDUM, TMP2, $ TMP2, DUM, DWORK( 4 ), -1, IDUM, 1, INFO ) C OPTWRK = MAX( 64 + MAX( 12 + INT( DWORK( 1 ) ), 4*M + 8, $ 24 + INT( DWORK( 2 ) ), $ 6 + INT( DWORK( 3 ) ), $ 12 + INT( DWORK( 4 ) ), 4*N ), MINWRK ) IF( LQUERY ) THEN DWORK( 1 ) = OPTWRK RETURN END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C C Computations. Note that MB03KD needs reverse ordering of the C factors in the formal matrix product, compared to MA01BD, MB03BA. C IA11 = 1 IB12 = IA11 + MM IA22 = IB12 + MM IB21 = IA22 + MM IV1 = IB21 + MM IV2 = IV1 + MM IV3 = IV2 + MM IV4 = IV3 + MM MP1 = M + 1 C C Get the machine parameters. C ULP = DLAMCH( 'Precision' ) BASE = DLAMCH( 'Base' ) LGBAS = LOG( BASE ) C C Compute maps to access the factors of the formal matrix product. C K = 4 KSCHUR = 4 IWORK( 2*K+1 ) = -1 IWORK( 2*K+2 ) = 1 IWORK( 2*K+3 ) = -1 IWORK( 2*K+4 ) = 1 CALL MB03BA( K, KSCHUR, IWORK( 2*K+1 ), I, IWORK, IWORK( K+1 ) ) C C Store the factors of the formal matrix product. C DUM( 1 ) = ZERO CALL DCOPY( 4*MM, DUM, 0, DWORK, 1 ) CALL DLACPY( 'Upper', M, M, A, LDA, DWORK, M ) CALL DLACPY( 'Upper', M, M, A( MP1, MP1 ), LDA, DWORK( IA22 ), M ) CALL DLACPY( 'Upper', M, M, B( 1, MP1 ), LDB, DWORK( IB12 ), M ) CALL DLACPY( 'Upper', M, M, B( MP1, 1 ), LDB, DWORK( IB21 ), M ) IF( M.GT.1 ) $ CALL DCOPY( M-1, B( M+2, 1 ), LDB+1, DWORK( IB21+1 ), MP1 ) C C Set BWORK according to the eigenvalues of the formal matrix C product in Schur-triangular form. C Workspace: need 4*M*M + 2. C J = 1 IA = IV1 IB = IA + 1 C C WHILE( J.LE.M ) DO 10 CONTINUE IF( J.LT.M ) THEN IF( DWORK( IB21+J+(J-1)*M ).EQ.ZERO ) THEN CALL MA01BD( BASE, LGBAS, K, IWORK( 2*K+1 ), $ DWORK( (J-1)*M+J ), MM, DWORK( IA ), $ DWORK( IB ), IWORK( 3*K+1 ) ) BWORK( J ) = DWORK( IA ).GT.ZERO J = J + 1 GO TO 10 ELSE BWORK( J ) = .TRUE. BWORK( J+1 ) = .TRUE. J = J + 2 GO TO 10 END IF ELSE IF ( J.EQ.M ) THEN CALL MA01BD( BASE, LGBAS, K, IWORK( 2*K+1 ), DWORK( MM ), MM, $ DWORK( IA ), DWORK( IB ), IWORK( 3*K+1 ) ) BWORK( J ) = DWORK( IA ).GT.ZERO END IF C END WHILE 10 C C Check if BWORK(J) = .TRUE. for all J. C J = 1 C WHILE( J.LE.M and BWORK(J) ) DO 20 CONTINUE IF( J.LE.M .AND. BWORK(J) ) THEN J = J + 1 GO TO 20 END IF C END WHILE 20 C IF( J.NE.MP1 ) THEN C C Apply periodic QZ algorithm for reordering the eigenvalues. C Workspace: need 8*M*M + MAX(42*K + M, 80*K - 48), K = 4, C if there is at least a pair of adjacent blocks C of order 2 involved in reordering, and M > 10. C Otherwise, the MAX term is slightly smaller. C IWRK = 2*IV1 - 1 IB21 = 1 IA22 = IB21 + MM IB12 = IA22 + MM IA11 = IB12 + MM C KSCHUR = 1 IWORK( 2*K+1 ) = 1 IWORK( 2*K+2 ) = -1 IWORK( 2*K+3 ) = 1 IWORK( 2*K+4 ) = -1 C DO 30 I = 1, K IWORK( I ) = M IWORK( K+I ) = 0 IWORK( 3*K+I ) = 1 + ( I - 1 )*MM 30 CONTINUE C CALL DCOPY( MM*K, DUM, 0, DWORK( IB21 ), 1 ) CALL DLACPY( 'Upper', M, M, B( MP1, 1 ), LDB, DWORK( IB21 ), $ M ) CALL DLACPY( 'Upper', M, M, B( 1, MP1 ), LDB, DWORK( IB12 ), $ M ) CALL DLACPY( 'Upper', M, M, A, LDA, DWORK( IA11 ), M ) CALL DLACPY( 'Upper', M, M, A( MP1, MP1 ), LDA, DWORK( IA22 ), $ M ) IF( M.GT.1 ) $ CALL DCOPY( M-1, B( M+2, 1 ), LDB+1, DWORK( IB21+1 ), MP1 ) C CALL MB03KD( 'Initialize', IDUM, 'NotStrong', K, M, KSCHUR, $ IWORK, IWORK( K+1 ), IWORK( 2*K+1 ), BWORK, $ DWORK, IWORK, IWORK( 3*K+1 ), DWORK( IV1 ), $ IWORK, IWORK( 3*K+1 ), M1, HUND2, IWORK( 4*K+1 ), $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) $ RETURN C M2 = M - M1 I1 = M1 + 1 I2 = I1 + M1 I3 = I2 + M2 M4 = 2*M2 C C If Q1 and/or Q2 are user-initialized, update them. C The (2,1) block of A is used as workspace. C IF( LUPDQ1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1, LDQ1, DWORK( IV1 ), M, ZERO, A( MP1, 1 ), $ LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( MP1, 1 ), LDQ1, DWORK( IV1 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( MP1, 1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( 1, MP1 ), LDQ1, DWORK( IV3 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( 1, MP1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( MP1, MP1 ), LDQ1, DWORK( IV3 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( MP1, MP1 ), $ LDQ1 ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M, Q1( 1, I1 ), LDQ1, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q1( 1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q1( 1, I2 ), LDQ1 ) CALL DLACPY( 'Full', M, M, Q1( MP1, I1 ), LDQ1, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q1( MP1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q1( MP1, I2 ), LDQ1 ) END IF END IF C IF( LUPDQ2 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2, LDQ2, DWORK( IV4 ), M, ZERO, A( MP1, 1 ), $ LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( MP1, 1 ), LDQ2, DWORK( IV4 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( MP1, 1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( 1, MP1 ), LDQ2, DWORK( IV2 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( 1, MP1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( MP1, MP1 ), LDQ2, DWORK( IV2 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( MP1, MP1 ), $ LDQ2 ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M, Q2( 1, I1 ), LDQ2, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q2( 1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q2( 1, I2 ), LDQ2 ) CALL DLACPY( 'Full', M, M, Q2( MP1, I1 ), LDQ2, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q2( MP1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q2( MP1, I2 ), LDQ2 ) END IF END IF C C Make permutations of the corresponding matrices. C IF( M2.GT.0 ) THEN CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLACPY( 'Upper', M1, M1, DWORK( IA11 ), M, A, LDA ) CALL DLASET( 'Full', M1, M1, ZERO, ZERO, A( 1, I1 ), LDA ) CALL DLACPY( 'Upper', M1, M1, DWORK( IA22 ), M, A( I1, I1 ), $ LDA ) CALL DLACPY( 'Full', M1, M2, DWORK( IA11+M*M1 ), M, $ A( 1, I2 ), LDA ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, A( I1, I2 ), LDA ) CALL DLACPY( 'Upper', M2, M2, DWORK( IA11+M*M1+M1 ), M, $ A( I2, I2 ), LDA ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, A( 1, I3 ), LDA ) CALL DLACPY( 'Full', M1, M2, DWORK( IA22+M*M1 ), M, $ A( I1, I3 ), LDA ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, A( I2, I3 ), LDA ) CALL DLACPY( 'Upper', M2, M2, DWORK( IA22+M*M1+M1 ), M, $ A( I3, I3 ), LDA ) C CALL DLASET( 'Full', M1, M1, ZERO, ZERO, B, LDB ) CALL DLACPY( 'Upper', M1, M1, DWORK( IB21 ), M, B( I1, 1 ), $ LDB ) CALL DCOPY( M1-1, DWORK( IB21+1 ), MP1, B( I1+1, 1 ), $ LDB+1 ) IF( M1.GT.2 ) $ CALL DLASET( 'Lower', M1-2, M1-2, ZERO, ZERO, $ B( I1+2, 1 ), LDB ) CALL DLASET( 'Full', M4, M1, ZERO, ZERO, B( I2, 1 ), LDB ) CALL DLACPY( 'Upper', M1, M1, DWORK( IB12 ), M, B( 1, I1 ), $ LDB ) IF( M1.GT.1 ) $ CALL DLASET( 'Lower', M1-1, M1-1, ZERO, ZERO, B( 2, I1 ), $ LDB ) CALL DLASET( 'Full', N-M1, M1, ZERO, ZERO, B( I1, I1 ), $ LDB ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, B( 1, I2 ), LDB ) CALL DLACPY( 'Full', M1, M2, DWORK( IB21+M*M1 ), M, $ B( I1, I2 ), LDB ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, B( I2, I2 ), LDB ) CALL DLACPY( 'Upper', M2, M2, DWORK( IB21+M*M1+M1 ), M, $ B( I3, I2 ), LDB ) CALL DCOPY( M2-1, DWORK( IB21+M*M1+I1 ), MP1, B( I3+1, I2 ), $ LDB+1 ) IF( M2.GT.2 ) $ CALL DLASET( 'Lower', M2-2, M2-2, ZERO, ZERO, $ B( I3+2, I2 ), LDB ) CALL DLACPY( 'Full', M1, M2, DWORK( IB12+M*M1 ), M, $ B( 1, I3 ), LDB ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, B( I1, I3 ), LDB ) CALL DLACPY( 'Full', M2, M2, DWORK( IB12+M*M1+M1 ), M, $ B( I2, I3 ), LDB ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, B( I3, I3 ), LDB ) ELSE CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, A( 1, MP1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B, LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( MP1, MP1 ), LDB ) END IF C IF( LINIQ1 ) THEN CALL DLACPY( 'Full', M, M1, DWORK( IV1 ), M, Q1, LDQ1 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q1( MP1, 1 ), LDQ1 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q1( 1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M1, DWORK( IV3 ), M, Q1( MP1, I1 ), $ LDQ1 ) IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M2, DWORK( IV1+M*M1 ), M, $ Q1( 1, I2 ), LDQ1 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q1( MP1, I2 ), $ LDQ1 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q1( 1, I3 ), $ LDQ1 ) CALL DLACPY( 'Full', M, M2, DWORK( IV3+M*M1 ), M, $ Q1( MP1, I3 ), LDQ1 ) END IF END IF C IF( LINIQ2 ) THEN CALL DLACPY( 'Full', M, M1, DWORK( IV4 ), M, Q2, LDQ2 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q2( MP1, 1 ), LDQ2 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q2( 1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M1, DWORK( IV2 ), M, Q2( MP1, I1 ), $ LDQ2 ) IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M2, DWORK( IV4+M*M1 ), M, $ Q2( 1, I2 ), LDQ2 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q2( MP1, I2 ), $ LDQ2 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q2( 1, I3 ), $ LDQ2 ) CALL DLACPY( 'Full', M, M2, DWORK( IV2+M*M1 ), M, $ Q2( MP1, I3 ), LDQ2 ) END IF END IF ELSE M1 = M M2 = 0 I1 = M1 + 1 I2 = I1 + M1 I3 = I2 M4 = 2*M2 CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, A( 1, MP1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B, LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( MP1, MP1 ), LDB ) IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) IF( LINIQ2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q2, LDQ2 ) END IF C C Count the number of blocks in BB31. C R = 0 J = 1 C WHILE( J.LE.M1 ) DO 40 CONTINUE IF( J.LT.M1 ) THEN R = R + 1 IWORK( R ) = J IF( B( M1+J+1, J ).EQ.ZERO ) THEN J = J + 1 ELSE J = J + 2 END IF GO TO 40 ELSE IF ( J.EQ.M1 ) THEN R = R + 1 IWORK( R ) = J J = J + 1 END IF C END WHILE 40 IWORK( R+1 ) = J C C Triangularize the upper left subpencil aAA1 - bBB1. C DO 60 I = 1, R C C Calculate position of submatrices in DWORK. C IB1 and IB2 are pointers to 2 consecutive blocks. C IB1 = IWORK( I ) IB2 = IWORK( I+1 ) DIM1 = IB2 - IB1 SDIM = 2*DIM1 C IAUPLE = 1 IALOLE = IAUPLE + DIM1 IAUPRI = DIM1*SDIM + 1 IALORI = IAUPRI + DIM1 IBUPLE = SDIM*SDIM + 1 IBLOLE = IBUPLE + DIM1 IBUPRI = 3*DIM1*SDIM + 1 IBLORI = IBUPRI + DIM1 I1UPLE = 2*SDIM*SDIM + 1 I1LOLE = I1UPLE + DIM1 I1UPRI = 5*DIM1*SDIM + 1 I1LORI = I1UPRI + DIM1 I2UPLE = 3*SDIM*SDIM + 1 I2LOLE = I2UPLE + DIM1 I2UPRI = 7*DIM1*SDIM + 1 I2LORI = I2UPRI + DIM1 C C Generate input matrices for MB03FD, built of submatrices of A C and B. C Workspace: need 32. C IF( DIM1.EQ.1 ) THEN CALL DCOPY( SDIM, A( IB1, IB1 ), ( LDA+1 )*M1, $ DWORK( IAUPLE ), SDIM+1 ) CALL DCOPY( SDIM, B( M1+IB1, IB1 ), ( LDB-1 )*M1, $ DWORK( IBLOLE ), 1 ) ELSE CALL DLACPY( 'Upper', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IAUPLE+1 ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Upper', DIM1, DIM1, A( M1+IB1, M1+IB1 ), LDA, $ DWORK( IALORI ), SDIM ) DWORK( IALORI+1 ) = ZERO C CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IBUPLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, B( M1+IB1, IB1 ), LDB, $ DWORK( IBLOLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, M1+IB1 ), LDB, $ DWORK( IBUPRI ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IBLORI ), SDIM ) END IF C C Perform eigenvalue exchange. C Workspace: need 64 + max( 63, 4*M + 8 ). C IWRK = 4*SDIM*SDIM + 1 ITMP = IWRK + M*DIM1 ITMP2 = ITMP + M*DIM1 ITMP3 = ITMP2 + DIM1*DIM1 CALL MB03FD( SDIM, ULP, DWORK( IAUPLE ), SDIM, DWORK( IBUPLE ), $ SDIM, DWORK( I1UPLE ), SDIM, DWORK( I2UPLE ), $ SDIM, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF C NR = IB2 - 1 C IF( DIM1.EQ.2 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, A( 1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( 1, M1+IB1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( 1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( 1, M1+IB1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ A( 1, M1+IB1 ), LDA ) C CALL DLACPY( 'Full', NR, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, A( I1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( I1, M1+IB1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( I1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( I1, M1+IB1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ A( I1, M1+IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, DIM1, A( M1+IB1, IB1 ), LDA, $ DWORK( ITMP2 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, M1+IB1 ), LDA, $ DWORK( ITMP3 ), DIM1 ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ A( M1+IB1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB2+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ A( IB1, IB2 ), LDA, ZERO, A( M1+IB1, IB2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, DWORK( ITMP2 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ A( IB1, IB1 ), LDA ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IB1, M1+IB1 ), LDA, ZERO, $ A( IB1, M1+IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, A( IB1, M1+IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IB1, M1+IB1 ), LDA, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ A( M1+IB1, M1+IB1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, A( IB1, I2 ), $ LDA, ZERO, A( M1+IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, A( IB1, I2 ), $ LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ A( IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, A( M1+IB1, I3 ), $ LDA, ZERO, A( IB1, I3 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LORI ), SDIM, A( M1+IB1, I3 ), $ LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ A( M1+IB1, I3 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, B( 1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( 1, M1+IB1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( 1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( 1, M1+IB1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ B( 1, M1+IB1 ), LDB ) C CALL DLACPY( 'Full', NR, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, B( I1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( I1, M1+IB1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( I1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( I1, M1+IB1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ B( I1, M1+IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( ITMP2 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, B( M1+IB1, M1+IB1 ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IB1, IB1 ), LDB, ZERO, B( IB1, IB1 ), LDB $ ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, DWORK( ITMP2 ), $ DIM1, ONE, B( IB1, IB1 ), LDB ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ B( M1+IB1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IB1, IB1+1 ), LDB, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ B( M1+IB1, IB1+1 ), LDB ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ B( IB1, M1+IB1 ), LDB, ZERO, $ B( M1+IB1, M1+IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2LORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( M1+IB1, M1+IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ B( IB1, M1+IB1 ), LDB, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ B( IB1, M1+IB1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, B( M1+IB1, I2 ), $ LDB, ZERO, B( IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LORI ), SDIM, B( M1+IB1, I2 ), $ LDB, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ B( M1+IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, B( IB1, I3 ), $ LDB, ZERO, B( M1+IB1, I3 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, B( IB1, I3 ), $ LDB, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ B( IB1, I3 ), LDB ) END IF C ITMP = IWRK + N*DIM1 C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q1( 1, M1+IB1 ), LDQ1, $ DWORK( I1LOLE ), SDIM, ONE, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q1( 1, M1+IB1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( ITMP ), N, $ Q1( 1, M1+IB1 ), LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q2( 1, M1+IB1 ), LDQ2, $ DWORK( I2LOLE ), SDIM, ONE, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPRI ), SDIM, ZERO, DWORK( ITMP ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q2( 1, M1+IB1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ONE, DWORK( ITMP ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( ITMP ), N, $ Q2( 1, M1+IB1 ), LDQ2 ) END IF C ELSE C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), A( 1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), A( 1, M1+IB1 ), 1, $ A( 1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), A( 1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( 1, M1+IB1 ), 1 ) C CALL DCOPY( NR, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), A( I1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), A( I1, M1+IB1 ), 1, $ A( I1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), A( I1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( I1, M1+IB1 ), 1 ) C TMP2 = A( M1+IB1, IB1 ) TMP3 = A( IB1, M1+IB1 ) IF( M1.GT.IB1 ) THEN CALL DCOPY( M1-IB1, A( IB1, IB1+1 ), LDA, $ A( M1+IB1, IB1+1 ), LDA ) CALL DSCAL( M1-IB1, DWORK( I2UPRI ), A( M1+IB1, IB1+1 ), $ LDA ) END IF A( M1+IB1, IB1 ) = ZERO CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), A( IB1, IB1 ), LDA ) A( IB1, IB1 ) = A( IB1, IB1 ) + DWORK( I2LOLE )*TMP2 C CALL DCOPY( M1-IB1+1, A( M1+IB1, M1+IB1 ), LDA, $ A( IB1, M1+IB1 ), LDA ) CALL DSCAL( M1-IB1+1, DWORK( I2LOLE ), A( IB1, M1+IB1 ), $ LDA ) A( IB1, M1+IB1 ) = A( IB1, M1+IB1 ) + DWORK( I2UPLE )*TMP3 CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), A( M1+IB1, M1+IB1 ), $ LDA ) A( M1+IB1, M1+IB1 ) = A( M1+IB1, M1+IB1 ) + $ DWORK( I2UPRI )*TMP3 C IF( M2.GT.0 ) THEN CALL DCOPY( M2, A( IB1, I2 ), LDA, A( M1+IB1, I2 ), LDA ) CALL DSCAL( M2, DWORK( I2UPRI ), A( M1+IB1, I2 ), LDA ) CALL DSCAL( M2, DWORK( I2UPLE ), A( IB1, I2 ), LDA ) CALL DCOPY( M2, A( M1+IB1, I3 ), LDA, A( IB1, I3 ), LDA ) CALL DSCAL( M2, DWORK( I2LOLE ), A( IB1, I3 ), LDA ) CALL DSCAL( M2, DWORK( I2LORI ), A( M1+IB1, I3 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( 1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), B( 1, M1+IB1 ), 1, $ B( 1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), B( 1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( 1, M1+IB1 ), 1 ) C CALL DCOPY( NR, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), B( I1, M1+IB1 ), 1, $ B( I1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), B( I1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( I1, M1+IB1 ), 1 ) C TMP2 = B( IB1, IB1 ) TMP3 = B( M1+IB1, M1+IB1 ) CALL DCOPY( M1-IB1+1, B( M1+IB1, IB1 ), LDB, B( IB1, IB1 ), $ LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2LOLE ), B( IB1, IB1 ), LDB ) B( IB1, IB1 ) = B( IB1, IB1 ) + DWORK( I2UPLE )*TMP2 B( M1+IB1, IB1 ) = ZERO CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), B( M1+IB1, IB1+1 ), $ LDB ) C CALL DCOPY( M1-IB1+1, B( IB1, M1+IB1 ), LDB, $ B( M1+IB1, M1+IB1 ), LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2UPRI ), B( M1+IB1, M1+IB1 ), $ LDB ) B( M1+IB1, M1+IB1 ) = B( M1+IB1, M1+IB1 ) + $ DWORK( I2LORI )*TMP3 CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), B( IB1, M1+IB1 ), $ LDB ) B( IB1, M1+IB1 ) = B( IB1, M1+IB1 ) + DWORK( I2LOLE )*TMP3 C IF( M2.GT.0 ) THEN CALL DCOPY( M2, B( M1+IB1, I2 ), LDB, B( IB1, I2 ), LDB ) CALL DSCAL( M2, DWORK( I2LOLE ), B( IB1, I2 ), LDB ) CALL DSCAL( M2, DWORK( I2LORI ), B( M1+IB1, I2 ), LDB ) CALL DCOPY( M2, B( IB1, I3 ), LDB, B( M1+IB1, I3 ), LDB ) CALL DSCAL( M2, DWORK( I2UPRI ), B( M1+IB1, I3 ), LDB ) CALL DSCAL( M2, DWORK( I2UPLE ), B( IB1, I3 ), LDB ) END IF C ITMP = IWRK + N C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IB1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I1LORI ), Q1( 1, M1+IB1 ), 1 ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ Q1( 1, M1+IB1 ), 1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IB1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I2LORI ), Q2( 1, M1+IB1 ), 1 ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ Q2( 1, M1+IB1 ), 1 ) END IF C END IF C DO 50 J = I - 1, 1, -1 C C Calculate position of submatrices in DWORK. C IJ1 = IWORK( J ) IJ2 = IWORK( J+1 ) DIM1 = IWORK( I+1 ) - IWORK( I ) DIM2 = IJ2 - IJ1 SDIM = DIM1 + DIM2 C IALOLE = IAUPLE + DIM1 IAUPRI = DIM1*SDIM + 1 IALORI = IAUPRI + DIM1 IBUPLE = SDIM*SDIM + 1 IBLOLE = IBUPLE + DIM1 IBUPRI = SDIM*SDIM + DIM1*SDIM + 1 IBLORI = IBUPRI + DIM1 I1UPLE = 2*SDIM*SDIM + 1 I1LOLE = I1UPLE + DIM1 I1UPRI = 2*SDIM*SDIM + DIM1*SDIM + 1 I1LORI = I1UPRI + DIM1 I2UPLE = 3*SDIM*SDIM + 1 I2LOLE = I2UPLE + DIM1 I2UPRI = 3*SDIM*SDIM + DIM1*SDIM + 1 I2LORI = I2UPRI + DIM1 C C Generate input matrices for MB03DD built of submatrices of A C and B. C Workspace: need 32. C IF( DIM1.EQ.2 .AND. DIM2.EQ.2 ) THEN CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM1, A( M1+IJ1, IB1 ), LDA, $ DWORK( IALOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM2, ZERO, ZERO, $ DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, A( M1+IJ1, M1+IJ1 ), $ LDA, DWORK( IALORI ), SDIM ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( IBUPLE ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM1, B( M1+IJ1, IB1 ), LDB, $ DWORK( IBLOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM2, ZERO, ZERO, $ DWORK( IBUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, B( M1+IJ1, M1+IJ1 ), $ LDB, DWORK( IBLORI ), SDIM ) C ELSE IF( DIM1.EQ.1 .AND. DIM2.EQ.2 ) THEN DWORK( IAUPLE ) = A( IB1, IB1 ) CALL DCOPY( DIM2, A( M1+IJ1, IB1 ), 1, DWORK( IALOLE ), $ 1 ) CALL DCOPY( DIM2, DUM, 0, DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, A( M1+IJ1, M1+IJ1 ), $ LDA, DWORK( IALORI ), SDIM ) C DWORK( IBUPLE ) = B( IB1, IB1 ) CALL DCOPY( DIM2, B( M1+IJ1, IB1 ), 1, DWORK( IBLOLE ), $ 1 ) CALL DCOPY( DIM2, DUM, 0, DWORK( IBUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, B( M1+IJ1, M1+IJ1 ), $ LDB, DWORK( IBLORI ), SDIM ) C ELSE IF( DIM1.EQ.2 .AND. DIM2.EQ.1 ) THEN CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DCOPY( DIM1, A( M1+IJ1, IB1 ), LDA, DWORK( IALOLE ), $ SDIM ) CALL DCOPY( DIM1, DUM, 0, DWORK( IAUPRI ), 1 ) DWORK( IALORI ) = A( M1+IJ1, M1+IJ1 ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( IBUPLE ), SDIM ) CALL DCOPY( DIM1, B( M1+IJ1, IB1 ), LDB, DWORK( IBLOLE ), $ SDIM ) CALL DCOPY( DIM1, DUM, 0, DWORK( IBUPRI ), 1 ) DWORK( IBLORI ) = B( M1+IJ1, M1+IJ1 ) C ELSE DWORK( IAUPLE ) = A( IB1, IB1 ) DWORK( IALOLE ) = A( M1+IJ1, IB1 ) DWORK( IAUPRI ) = ZERO DWORK( IALORI ) = A( M1+IJ1, M1+IJ1 ) C DWORK( IBUPLE ) = B( IB1, IB1 ) DWORK( IBLOLE ) = B( M1+IJ1, IB1 ) DWORK( IBUPRI ) = ZERO DWORK( IBLORI ) = B( M1+IJ1, M1+IJ1 ) C END IF C C Perform upper triangularization. C Workspace: need 64 + max( 75, 4*N ). C IWRK = 4*SDIM*SDIM + 1 ITMP = IWRK + 2*N CALL MB03DD( 'Lower', DIM1, DIM2, ULP, DWORK( IBUPLE ), $ SDIM, DWORK( IAUPLE ), SDIM, DWORK( I1UPLE ), $ SDIM, DWORK( I2UPLE ), SDIM, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.LE.2 ) THEN INFO = 2 ELSE IF( INFO.LE.4 ) THEN INFO = 3 ELSE INFO = 4 END IF RETURN END IF C NROW = IJ2 - 1 C IF( DIM1.EQ.2 .AND. DIM2.EQ.2 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, A( 1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM1, DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( 1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM2, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM2, DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NR ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ A( 1, M1+IJ1 ), LDA ) C CALL DLACPY( 'Full', NROW, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, A( I1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( I1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NROW ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ A( I1, M1+IJ1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, A( IB1, IB1 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ONE, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, A( IB1, M1+IJ1 ), $ LDA, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, M1+IJ1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ONE, $ A( IB1, M1+IJ1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ONE, $ DWORK( ITMP ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, A( IB1, I2 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, I2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IJ1, I2 ), LDA, ONE, A( IB1, I2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, I2 ), LDA, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, B( 1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM1, DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( 1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM2, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM2, DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NR ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ B( 1, M1+IJ1 ), LDB ) C CALL DLACPY( 'Full', NROW, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, B( I1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( I1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NROW ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ B( I1, M1+IJ1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, B( IB1, IB1 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, IB1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ONE, B( IB1, IB1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, B( IB1, M1+IJ1 ), $ LDB, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, M1+IJ1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ONE, $ B( IB1, M1+IJ1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ONE, $ DWORK( ITMP ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, B( IB1, I2 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, I2 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, I2 ), LDB, ONE, B( IB1, I2 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, I2 ), LDB, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, $ Q1( 1, IB1 ), LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LOLE ), SDIM, ONE, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPRI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ONE, $ DWORK( ITMP ), N ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q1( 1, M1+IJ1 ), LDQ1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, $ Q2( 1, IB1 ), LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LOLE ), SDIM, ONE, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPRI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ONE, $ DWORK( ITMP ), N ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q2( 1, M1+IJ1 ), LDQ2 ) END IF C ELSE IF( DIM1.EQ.1 .AND. DIM2.EQ.2 ) THEN C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NR-1, DIM2, ONE, $ A( 1, M1+IJ1 ), LDA, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), A( 1, IB1 ), 1 ) A( NR, IB1 ) = DWORK( I1UPLE )*A( NR, IB1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-1, DIM2, $ DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) DWORK( ITMP+ NR-1 ) = ZERO DWORK( ITMP+2*NR-1 ) = ZERO CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), 1, $ DWORK( ITMP+NR ), 1 ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ A( 1, M1+IJ1 ), LDA ) C CALL DCOPY( NROW, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM2, ONE, $ A( I1, M1+IJ1 ), LDA, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), A( I1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+NROW ), 1 ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ A( I1, M1+IJ1 ), LDA ) C CALL DCOPY( M1-IB1+1, A( IB1, IB1 ), LDA, DWORK( IWRK ), $ 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IB1+1, ONE, $ A( M1+IJ1, IB1 ), LDA, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), A( IB1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, IB1 ), LDA ) C CALL DCOPY( M1-IJ1+1, A( IB1, M1+IJ1 ), LDA, $ DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IJ1+1, ONE, $ A( M1+IJ1, M1+IJ1 ), LDA, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), A( IB1, M1+IJ1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, A( IB1, I2 ), LDA, DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M4, ONE, $ A( M1+IJ1, I2 ), LDA, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), A( IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, I2 ), LDA, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NR-1, DIM2, ONE, $ B( 1, M1+IJ1 ), LDB, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), B( 1, IB1 ), 1 ) B( NR, IB1 ) = DWORK( I1UPLE )*B( NR, IB1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-1, DIM2, $ DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) DWORK( ITMP+ NR-1 ) = ZERO DWORK( ITMP+2*NR-1 ) = ZERO CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), 1, $ DWORK( ITMP+NR ), 1 ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ B( 1, M1+IJ1 ), LDB ) C CALL DCOPY( NROW, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM2, ONE, $ B( I1, M1+IJ1 ), LDB, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+NROW ), 1 ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ B( I1, M1+IJ1 ), LDB ) C CALL DCOPY( M1-IB1+1, B( IB1, IB1 ), LDB, DWORK( IWRK ), $ 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IB1+1, ONE, $ B( M1+IJ1, IB1 ), LDB, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), B( IB1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, IB1 ), LDB ) C CALL DCOPY( M1-IJ1+1, B( IB1, M1+IJ1 ), LDB, $ DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IJ1+1, ONE, $ B( M1+IJ1, M1+IJ1 ), LDB, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), B( IB1, M1+IJ1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, B( IB1, I2 ), LDB, DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M4, ONE, $ B( M1+IJ1, I2 ), LDB, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), B( IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, I2 ), LDB, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', N, DIM2, ONE, $ Q1( 1, M1+IJ1 ), LDQ1, DWORK( I1LOLE ), $ 1, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( N, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+N ), 1 ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q1( 1, M1+IJ1 ), LDQ1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', N, DIM2, ONE, $ Q2( 1, M1+IJ1 ), LDQ2, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( N, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+N ), 1 ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q2( 1, M1+IJ1 ), LDQ2 ) END IF C ELSE IF( DIM1.EQ.2 .AND. DIM2.EQ.1 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, A( 1, IB1 ), $ LDA ) CALL DAXPY( NR-1, DWORK( I1LOLE ), A( 1, M1+IJ1 ), 1, $ A( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE+SDIM ), A( 1, M1+IJ1 ), $ 1, A( 1, IB1+1 ), 1 ) A( NR, M1+IJ1 ) = ZERO CALL DGEMV( 'No Transpose', NR, DIM1, ONE, $ DWORK( IWRK ), NR, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), A( 1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', NROW, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, A( I1, IB1 ), $ LDA ) CALL DAXPY( NROW, DWORK( I1LOLE ), A( I1, M1+IJ1 ), 1, $ A( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE+SDIM ), A( I1, M1+IJ1 ), $ 1, A( I1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM1, ONE, $ DWORK( IWRK ), NROW, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), A( I1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, A( IB1, IB1 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), A( M1+IJ1, IB1 ), $ LDA, A( IB1, IB1 ), LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE+SDIM ), $ A( M1+IJ1, IB1 ), LDA, A( IB1+1, IB1 ), $ LDA ) CALL DGEMV( 'Transpose', DIM1, M1-IB1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( M1+IJ1, IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, A( IB1, M1+IJ1 ), $ LDA, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ A( M1+IJ1, M1+IJ1 ), LDA, A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE+SDIM ), $ A( M1+IJ1, M1+IJ1 ), LDA, $ A( IB1+1, M1+IJ1 ), LDA ) CALL DGEMV( 'Transpose', DIM1, M1-IJ1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, A( IB1, I2 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, I2 ), $ LDA ) CALL DAXPY( M4, DWORK( I2LOLE ), A( M1+IJ1, I2 ), $ LDA, A( IB1, I2 ), LDA ) CALL DAXPY( M4, DWORK( I2LOLE+SDIM ), $ A( M1+IJ1, I2 ), LDA, A( IB1+1, I2 ), $ LDA ) CALL DGEMV( 'Transpose', DIM1, M4, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, B( 1, IB1 ), $ LDB ) CALL DAXPY( NR-1, DWORK( I1LOLE ), B( 1, M1+IJ1 ), 1, $ B( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE+SDIM ), B( 1, M1+IJ1 ), $ 1, B( 1, IB1+1 ), 1 ) B( NR, M1+IJ1 ) = ZERO CALL DGEMV( 'No Transpose', NR, DIM1, ONE, $ DWORK( IWRK ), NR, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), B( 1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', NROW, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, B( I1, IB1 ), $ LDB ) CALL DAXPY( NROW, DWORK( I1LOLE ), B( I1, M1+IJ1 ), 1, $ B( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE+SDIM ), B( I1, M1+IJ1 ), $ 1, B( I1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM1, ONE, $ DWORK( IWRK ), NROW, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), B( I1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, B( IB1, IB1 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), B( M1+IJ1, IB1 ), $ LDB, B( IB1, IB1 ), LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, IB1 ), LDB, B( IB1+1, IB1 ), $ LDB ) CALL DGEMV( 'Transpose', DIM1, M1-IB1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, B( IB1, M1+IJ1 ), $ LDB, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ B( M1+IJ1, M1+IJ1 ), LDB, B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, M1+IJ1 ), LDB, $ B( IB1+1, M1+IJ1 ), LDB ) CALL DGEMV( 'Transpose', DIM1, M1-IJ1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, B( IB1, I2 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, I2 ), $ LDB ) CALL DAXPY( M4, DWORK( I2LOLE ), B( M1+IJ1, I2 ), $ LDB, B( IB1, I2 ), LDB ) CALL DAXPY( M4, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, I2 ), LDB, B( IB1+1, I2 ), $ LDB ) CALL DGEMV( 'Transpose', DIM1, M4, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, $ Q1( 1, IB1 ), LDQ1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IJ1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE+SDIM ), Q1( 1, M1+IJ1 ), $ 1, Q1( 1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', N, DIM1, ONE, $ DWORK( IWRK ), N, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), Q1( 1, M1+IJ1 ), 1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, $ Q2( 1, IB1 ), LDQ2 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IJ1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE+SDIM ), Q2( 1, M1+IJ1 ), $ 1, Q2( 1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', N, DIM1, ONE, $ DWORK( IWRK ), N, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), Q2( 1, M1+IJ1 ), 1 ) END IF C ELSE C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), A( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE ), A( 1, M1+IJ1 ), 1, $ A( 1, IB1 ), 1 ) CALL DSCAL( NR-1, DWORK( I1LORI ), A( 1, M1+IJ1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( 1, M1+IJ1 ), 1 ) A( NR, M1+IJ1 ) = DWORK( I1UPRI )*DWORK( IWRK+NR-1 ) C CALL DCOPY( NROW, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NROW, DWORK( I1UPLE ), A( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE ), A( I1, M1+IJ1 ), 1, $ A( I1, IB1 ), 1 ) CALL DSCAL( NROW, DWORK( I1LORI ), A( I1, M1+IJ1 ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( I1, M1+IJ1 ), 1 ) C CALL DCOPY( M1-IB1+1, A( IB1, IB1 ), LDA, DWORK( IWRK ), $ 1 ) CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), A( IB1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), A( M1+IJ1, IB1 ), $ LDA, A( IB1, IB1 ), LDA ) CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), A( M1+IJ1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, IB1 ), LDA ) C CALL DCOPY( M1-IJ1+1, A( IB1, M1+IJ1 ), LDA, $ DWORK( IWRK ), 1 ) CALL DSCAL( M1-IJ1+1, DWORK( I2UPLE ), A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ A( M1+IJ1, M1+IJ1 ), LDA, A( IB1, M1+IJ1 ), $ LDA ) CALL DSCAL( M1-IJ1+1, DWORK( I2LORI ), $ A( M1+IJ1, M1+IJ1 ), LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, A( IB1, I2 ), LDA, DWORK( IWRK ), 1 ) CALL DSCAL( M4, DWORK( I2UPLE ), A( IB1, I2 ), LDA ) CALL DAXPY( M4, DWORK( I2LOLE ), A( M1+IJ1, I2 ), LDA, $ A( IB1, I2 ), LDA ) CALL DSCAL( M4, DWORK( I2LORI ), A( M1+IJ1, I2 ), $ LDA ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE ), B( 1, M1+IJ1 ), 1, $ B( 1, IB1 ), 1 ) CALL DSCAL( NR-1, DWORK( I1LORI ), B( 1, M1+IJ1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( 1, M1+IJ1 ), 1 ) B( NR, M1+IJ1 ) = DWORK( I1UPRI )*DWORK( IWRK+NR-1 ) C CALL DCOPY( NROW, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NROW, DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE ), B( I1, M1+IJ1 ), 1, $ B( I1, IB1 ), 1 ) CALL DSCAL( NROW, DWORK( I1LORI ), B( I1, M1+IJ1 ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( I1, M1+IJ1 ), 1 ) C CALL DCOPY( M1-IB1+1, B( IB1, IB1 ), LDB, DWORK( IWRK ), $ 1 ) CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), B( IB1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), B( M1+IJ1, IB1 ), $ LDB, B( IB1, IB1 ), LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), B( M1+IJ1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, IB1 ), LDB ) C CALL DCOPY( M1-IJ1+1, B( IB1, M1+IJ1 ), LDB, $ DWORK( IWRK ), 1 ) CALL DSCAL( M1-IJ1+1, DWORK( I2UPLE ), B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ B( M1+IJ1, M1+IJ1 ), LDB, B( IB1, M1+IJ1 ), $ LDB ) CALL DSCAL( M1-IJ1+1, DWORK( I2LORI ), $ B( M1+IJ1, M1+IJ1 ), LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, B( IB1, I2 ), LDB, DWORK( IWRK ), 1 ) CALL DSCAL( M4, DWORK( I2UPLE ), B( IB1, I2 ), LDB ) CALL DAXPY( M4, DWORK( I2LOLE ), B( M1+IJ1, I2 ), LDB, $ B( IB1, I2 ), LDB ) CALL DSCAL( M4, DWORK( I2LORI ), B( M1+IJ1, I2 ), $ LDB ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IJ1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I1LORI ), Q1( 1, M1+IJ1 ), 1 ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ Q1( 1, M1+IJ1 ), 1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IJ1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I2LORI ), Q2( 1, M1+IJ1 ), 1 ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ Q2( 1, M1+IJ1 ), 1 ) END IF END IF 50 CONTINUE 60 CONTINUE C C Triangularize the lower right subpencil aAA2 - bBB2. C IF( M2.GT.1 ) THEN CALL DLACPY( 'Full', N, M4-2, A( 1, I2+1 ), LDA, DWORK, N ) DO 70 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ A( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ A( 1, 2*( M1+I ) ), 1 ) 70 CONTINUE C CALL DLACPY( 'Full', M4-2, M4, A( I2+1, I2 ), LDA, DWORK, $ M4-2 ) DO 80 I = 1, M2 - 1 CALL DCOPY( M4, DWORK( I ), M4-2, A( 2*( M1+I )+1, I2 ), $ LDA ) CALL DCOPY( M4, DWORK( M2+I-1 ), M4-2, A( 2*( M1+I ), I2 ), $ LDA ) 80 CONTINUE C CALL DLACPY( 'Full', N, M4-2, B( 1, I2+1 ), LDB, DWORK, N ) DO 90 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ B( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ B( 1, 2*( M1+I ) ), 1 ) 90 CONTINUE C CALL DLACPY( 'Full', M4-2, M4, B( I2+1, I2 ), LDB, DWORK, $ M4-2 ) DO 100 I = 1, M2 - 1 CALL DCOPY( M4, DWORK( I ), M4-2, B( 2*( M1+I )+1, I2 ), $ LDB ) CALL DCOPY( M4, DWORK( M2+I-1 ), M4-2, B( 2*( M1+I ), I2 ), $ LDB ) 100 CONTINUE C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, M4-2, Q1( 1, I2+1 ), LDQ1, DWORK, $ N ) DO 110 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ Q1( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ Q1( 1, 2*( M1+I ) ), 1 ) 110 CONTINUE END IF C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, M4-2, Q2( 1, I2+1 ), LDQ2, DWORK, $ N ) DO 120 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ Q2( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ Q2( 1, 2*( M1+I ) ), 1 ) 120 CONTINUE END IF END IF C DWORK( 1 ) = OPTWRK RETURN C *** Last line of MB04HD *** END slicot-5.0+20101122/src/MB04ID.f000077500000000000000000000221101201767322700153620ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04IY.f000077500000000000000000000246611201767322700154240ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04IZ.f000077500000000000000000000224341201767322700154210ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04JD.f000077500000000000000000000177651201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04KD.f000077500000000000000000000170631201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04LD.f000077500000000000000000000170471201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04MD.f000077500000000000000000000206771201767322700154060ustar00rootroot00000000000000 SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04ND.f000077500000000000000000000217421201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04NY.f000077500000000000000000000274471201767322700154360ustar00rootroot00000000000000 SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04OD.f000077500000000000000000000214111201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04OW.f000077500000000000000000000211651201767322700154240ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04OX.f000077500000000000000000000065531201767322700154310ustar00rootroot00000000000000 SUBROUTINE MB04OX( N, A, LDA, X, INCX ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04OY.f000077500000000000000000000244401201767322700154250ustar00rootroot00000000000000 SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04PA.f000077500000000000000000001373661201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04PB.f000077500000000000000000000265501201767322700154030ustar00rootroot00000000000000 SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, $ LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04PU.f000077500000000000000000000304131201767322700154170ustar00rootroot00000000000000 SUBROUTINE MB04PU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, $ LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04PY.f000077500000000000000000000446141201767322700154330ustar00rootroot00000000000000 SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04QB.f000077500000000000000000000364451201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04QC.f000077500000000000000000001176251201767322700154110ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04QF.f000077500000000000000000000501711201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04QU.f000077500000000000000000000417431201767322700154300ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04SU.f000077500000000000000000000204421201767322700154230ustar00rootroot00000000000000 SUBROUTINE MB04SU( M, N, A, LDA, B, LDB, CS, TAU, DWORK, LDWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 QR decomposition of a real 2M-by-N matrix C [A; B], C C [ A ] [ R11 R12 ] C [ ] = Q * R = Q [ ], C [ B ] [ R21 R22 ] C C where Q is a symplectic orthogonal matrix, R11 is upper triangular C and R21 is strictly upper triangular. C If [A; B] is symplectic then, theoretically, R21 = 0 and C R22 = inv(R11)^T. Unblocked version. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The number of rows of A and B. M >= 0. C C N (input) INTEGER C The number of columns of A and B. 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 matrix A. C On exit, the leading M-by-N part of this array contains C the matrix [ R11 R12 ] and, in the zero parts of R, C information about the elementary reflectors used to C compute the symplectic QR decomposition. 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 (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 matrix [ R21 R22 ] and, in the zero parts of B, C information about the elementary reflectors used to C compute the symplectic QR decomposition. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,M). C C CS (output) DOUBLE PRECISION array, dimension (2 * min(M,N)) C On exit, the first 2*min(M,N) elements of this array C contain the cosines and sines of the symplectic Givens C rotations used to compute the symplectic QR decomposition. C C TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) C On exit, the first min(M,N) elements of this array C contain the scalar factors of some of the elementary C 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). C C Error Indicator C C INFO INTEGER 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 symplectic reflectors C 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 where k = min(m,n). C C Each H(i) has the form C C H(i) = I - tau * w * w' C C where tau is a real scalar, and w is a real vector with C w(1:i-1) = 0 and w(i) = 1; w(i+1:m) is stored on exit in C B(i+1:m,i), and tau in B(i,i). C C Each F(i) has the form C C F(i) = I - nu * v * v' C C where nu 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 nu in TAU(i). C C Each G(i) is a Givens rotator acting on rows i of A and B, C where the cosine is stored in CS(2*i-1) and the sine in C CS(2*i). 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 [2] Byers, R. C Hamiltonian and Symplectic Algorithms for the Algebraic C Riccati Equation. C Ph.D. Dissertation, Center for Applied Mathematics, C Cornell University, Ithaca, NY, 1983. C C NUMERICAL ASPECTS C C The algorithm requires C 8*M*N*N - 8/3*N*N*N + 2*M*N + 6*N*N + 8/3*N, if M >= N, C 8*M*M*N - 8/3*M*M*M + 14*M*N - 6*M*M + 8/3*N, if M <= N, C floating point operations and is numerically 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 DGESQR). C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), CS(*), DWORK(*), TAU(*) C .. Local Scalars .. INTEGER I, K DOUBLE PRECISION ALPHA, NU, TEMP C .. External Subroutines .. EXTERNAL DLARF, DLARFG, DLARTG, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. 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 ( LDB.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN DWORK(1) = DBLE( MAX( 1, N ) ) INFO = -10 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04SU', -INFO ) RETURN END IF C C Quick return if possible. C K = MIN( M,N ) IF ( K.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C DO 10 I = 1, K C C Generate elementary reflector H(i) to annihilate B(i+1:m,i). C ALPHA = B(I,I) CALL DLARFG( M-I+1, ALPHA, B(MIN( I+1,M ),I), 1, NU ) C C Apply H(i) to A(i:m,i:n) and B(i:m,i+1:n) from the left. C B(I,I) = ONE CALL DLARF( 'Left', M-I+1, N-I+1, B(I,I), 1, NU, A(I,I), LDA, $ DWORK ) IF ( I.LT.N ) $ CALL DLARF( 'Left', M-I+1, N-I, B(I,I), 1, NU, B(I,I+1), $ LDB, DWORK ) B(I,I) = NU C C Generate symplectic Givens rotator G(i) to annihilate C B(i,i). C TEMP = A(I,I) CALL DLARTG( TEMP, ALPHA, CS(2*I-1), CS(2*I), A(I,I) ) IF ( I.LT.N ) THEN C C Apply G(i) to [ A(i,i+1:n); B(i,i+1:n) ] from the left. C CALL DROT( N-I, A(I,I+1), LDA, B(I,I+1), LDB, CS(2*I-1), $ CS(2*I) ) END IF C C Generate elementary reflector F(i) to annihilate A(i+1:m,i). C CALL DLARFG( M-I+1, A(I,I), A(MIN( I+1,M ),I), 1, TAU(I) ) IF ( I.LT.N ) THEN C C Apply F(i) to A(i:m,i+1:n) and B(i:m,i+1:n) from the C left. C TEMP = 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 ) CALL DLARF( 'Left', M-I+1, N-I, A(I,I), 1, TAU(I), B(I,I+1), $ LDB, DWORK ) A(I,I) = TEMP END IF 10 CONTINUE DWORK(1) = DBLE(MAX( 1, N )) RETURN C *** Last line of MB04SU *** END slicot-5.0+20101122/src/MB04TB.f000077500000000000000000000675261201767322700154170ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04TS.f000077500000000000000000000442471201767322700154330ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04TT.f000077500000000000000000000344041201767322700154260ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should 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 slicot-5.0+20101122/src/MB04TU.f000077500000000000000000000053031201767322700154230ustar00rootroot00000000000000 SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04TV.f000077500000000000000000000141511201767322700154250ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04TW.f000077500000000000000000000147231201767322700154330ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04TX.f000077500000000000000000000351101201767322700154250ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04TY.f000077500000000000000000000210001201767322700154170ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04UD.f000077500000000000000000000331151201767322700154050ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04VD.f000077500000000000000000000475111201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04VX.f000077500000000000000000000342721201767322700154370ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04WD.f000077500000000000000000000362331201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04WP.f000077500000000000000000000156441201767322700154320ustar00rootroot00000000000000 SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK, $ LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04WR.f000077500000000000000000000305751201767322700154340ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04WU.f000077500000000000000000000335261201767322700154360ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04XD.f000077500000000000000000000577251201767322700154250ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB04XY.f000077500000000000000000000213541201767322700154370ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04YD.f000077500000000000000000000560631201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04YW.f000077500000000000000000000433101201767322700154320ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB04ZD.f000077500000000000000000000431471201767322700154200ustar00rootroot00000000000000 SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO $ ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB05MD.f000077500000000000000000000314501201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB05MY.f000077500000000000000000000261411201767322700154240ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB05ND.f000077500000000000000000000274171201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB05OD.f000077500000000000000000000435411201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MB05OY.f000077500000000000000000000124101201767322700154200ustar00rootroot00000000000000 SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MB3OYZ.f000077500000000000000000000332011201767322700154710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+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, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL DLAMCH, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( A( I, J ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO) TEMP2 = TEMP*( DWORK( J ) / DWORK( N+J ) )**2 IF( TEMP2.LE.TOLZ ) 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 slicot-5.0+20101122/src/MB3PYZ.f000077500000000000000000000340751201767322700155040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+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, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL DLAMCH, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( A( J, NKI ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), $ ZERO ) TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2 IF( TEMP2.LE.TOLZ ) 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 slicot-5.0+20101122/src/MC01MD.f000077500000000000000000000113671201767322700154000ustar00rootroot00000000000000 SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MC01ND.f000077500000000000000000000073741201767322700154040ustar00rootroot00000000000000 SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC01OD.f000077500000000000000000000102041201767322700153670ustar00rootroot00000000000000 SUBROUTINE MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC01PD.f000077500000000000000000000106761201767322700154050ustar00rootroot00000000000000 SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC01PY.f000077500000000000000000000104711201767322700154230ustar00rootroot00000000000000 SUBROUTINE MC01PY( K, REZ, IMZ, P, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC01QD.f000077500000000000000000000143511201767322700154000ustar00rootroot00000000000000 SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MC01RD.f000077500000000000000000000207051201767322700154010ustar00rootroot00000000000000 SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC01SD.f000077500000000000000000000173161201767322700154060ustar00rootroot00000000000000 SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MC01SW.f000077500000000000000000000051761201767322700154320ustar00rootroot00000000000000 SUBROUTINE MC01SW( A, B, M, E ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MC01SX.f000077500000000000000000000041151201767322700154230ustar00rootroot00000000000000 INTEGER FUNCTION MC01SX( LB, UB, E, MANT ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC01SY.f000077500000000000000000000076571201767322700154420ustar00rootroot00000000000000 SUBROUTINE MC01SY( M, E, B, A, OVFLOW ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MC01TD.f000077500000000000000000000233511201767322700154030ustar00rootroot00000000000000 SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MC01VD.f000077500000000000000000000214271201767322700154070ustar00rootroot00000000000000 SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC01WD.f000077500000000000000000000106071201767322700154060ustar00rootroot00000000000000 SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/MC03MD.f000077500000000000000000000264201201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC03ND.f000077500000000000000000000435611201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MC03NX.f000077500000000000000000000114211201767322700154160ustar00rootroot00000000000000 SUBROUTINE MC03NX( MP, NP, DP, P, LDP1, LDP2, A, LDA, E, LDE ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should 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 slicot-5.0+20101122/src/MC03NY.f000077500000000000000000000344611201767322700154300ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MD03AD.f000077500000000000000000001131571201767322700153670ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MD03BA.f000077500000000000000000000126151201767322700153620ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MD03BB.f000077500000000000000000000170701201767322700153630ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MD03BD.f000077500000000000000000001407461201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/MD03BF.f000077500000000000000000000074741201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/MD03BX.f000077500000000000000000000177031201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/MD03BY.f000077500000000000000000000407171201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/NF01AD.f000077500000000000000000000171671201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/NF01AY.f000077500000000000000000000260271201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/NF01BA.f000077500000000000000000000074751201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/NF01BB.f000077500000000000000000000122641201767322700153640ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/NF01BD.f000077500000000000000000000327121201767322700153660ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/NF01BE.f000077500000000000000000000075231201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/NF01BF.f000077500000000000000000000135031201767322700153650ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/NF01BP.f000077500000000000000000000563751201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/NF01BQ.f000077500000000000000000000416351201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/NF01BR.f000077500000000000000000000577711201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/NF01BS.f000077500000000000000000000476631201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/NF01BU.f000077500000000000000000000312501201767322700154030ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/NF01BV.f000077500000000000000000000167041201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/NF01BW.f000077500000000000000000000170311201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/NF01BX.f000077500000000000000000000121671201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/NF01BY.f000077500000000000000000000225511201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB01BD.f000077500000000000000000000673651201767322700154030ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB01BX.f000077500000000000000000000115511201767322700154110ustar00rootroot00000000000000 SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB01BY.f000077500000000000000000000246011201767322700154120ustar00rootroot00000000000000 SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB01DD.f000077500000000000000000000543171201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SB01FY.f000077500000000000000000000233231201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB01MD.f000077500000000000000000000272511201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02CX.f000077500000000000000000000045701201767322700154160ustar00rootroot00000000000000 LOGICAL FUNCTION SB02CX( REIG, IEIG ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02MD.f000077500000000000000000000507051201767322700154050ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02MR.f000077500000000000000000000037051201767322700154210ustar00rootroot00000000000000 LOGICAL FUNCTION SB02MR( REIG, IEIG ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02MS.f000077500000000000000000000041451201767322700154210ustar00rootroot00000000000000 LOGICAL FUNCTION SB02MS( REIG, IEIG ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02MT.f000077500000000000000000000505471201767322700154310ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB02MU.f000077500000000000000000000367331201767322700154330ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02MV.f000077500000000000000000000037001201767322700154200ustar00rootroot00000000000000 LOGICAL FUNCTION SB02MV( REIG, IEIG ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02MW.f000077500000000000000000000041211201767322700154170ustar00rootroot00000000000000 LOGICAL FUNCTION SB02MW( REIG, IEIG ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02ND.f000077500000000000000000000647041201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB02OD.f000077500000000000000000001003461201767322700154040ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02OU.f000077500000000000000000000046221201767322700154250ustar00rootroot00000000000000 LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02OV.f000077500000000000000000000047751201767322700154370ustar00rootroot00000000000000 LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02OW.f000077500000000000000000000046151201767322700154310ustar00rootroot00000000000000 LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02OX.f000077500000000000000000000047431201767322700154340ustar00rootroot00000000000000 LOGICAL FUNCTION SB02OX( ALPHAR, ALPHAI, BETA ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02OY.f000077500000000000000000000635611201767322700154400ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02PD.f000077500000000000000000000573411201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02QD.f000077500000000000000000000702021201767322700154030ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02RD.f000077500000000000000000001313061201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02RU.f000077500000000000000000000415721201767322700154350ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB02SD.f000077500000000000000000000763451201767322700154230ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03MD.f000077500000000000000000000505161201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03MU.f000077500000000000000000000355011201767322700154240ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03MV.f000077500000000000000000000226361201767322700154320ustar00rootroot00000000000000 SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, $ XNORM, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03MW.f000077500000000000000000000221201201767322700154170ustar00rootroot00000000000000 SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, $ XNORM, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03MX.f000077500000000000000000000623061201767322700154320ustar00rootroot00000000000000 SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03MY.f000077500000000000000000000512311201767322700154260ustar00rootroot00000000000000 SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03OD.f000077500000000000000000000620421201767322700154050ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03OR.f000077500000000000000000000335301201767322700154230ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB03OT.f000077500000000000000000001075641201767322700154360ustar00rootroot00000000000000 SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03OU.f000077500000000000000000000355721201767322700154360ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03OV.f000077500000000000000000000064651201767322700154360ustar00rootroot00000000000000 SUBROUTINE SB03OV( A, B, C, S ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03OY.f000077500000000000000000000572031201767322700154350ustar00rootroot00000000000000 SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA, $ SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03PD.f000077500000000000000000000335301201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03QD.f000077500000000000000000000570311201767322700154110ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03QX.f000077500000000000000000000307641201767322700154410ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03QY.f000077500000000000000000000337261201767322700154430ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03RD.f000077500000000000000000000331731201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03SD.f000077500000000000000000000576011201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03SX.f000077500000000000000000000312321201767322700154320ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03SY.f000077500000000000000000000344141201767322700154400ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03TD.f000077500000000000000000000505141201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB03UD.f000077500000000000000000000510161201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04MD.f000077500000000000000000000272141201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04MR.f000077500000000000000000000136451201767322700154270ustar00rootroot00000000000000 SUBROUTINE SB04MR( M, D, IPR, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04MU.f000077500000000000000000000130001201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04MW.f000077500000000000000000000123071201767322700154260ustar00rootroot00000000000000 SUBROUTINE SB04MW( M, D, IPR, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04MY.f000077500000000000000000000115061201767322700154300ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04ND.f000077500000000000000000000330331201767322700154030ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04NV.f000077500000000000000000000132431201767322700154260ustar00rootroot00000000000000 SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04NW.f000077500000000000000000000117721201767322700154340ustar00rootroot00000000000000 SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04NX.f000077500000000000000000000260751201767322700154370ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04NY.f000077500000000000000000000204321201767322700154270ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04OD.f000077500000000000000000001137341201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04OW.f000077500000000000000000000441001201767322700154240ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04PD.f000077500000000000000000000613741201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04PX.f000077500000000000000000000352141201767322700154340ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04PY.f000077500000000000000000001200161201767322700154300ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04QD.f000077500000000000000000000306671201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04QR.f000077500000000000000000000136641201767322700154340ustar00rootroot00000000000000 SUBROUTINE SB04QR( M, D, IPR, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04QU.f000077500000000000000000000145031201767322700154300ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04QY.f000077500000000000000000000124541201767322700154370ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04RD.f000077500000000000000000000327521201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04RV.f000077500000000000000000000162301201767322700154310ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04RW.f000077500000000000000000000137561201767322700154440ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04RX.f000077500000000000000000000331761201767322700154430ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB04RY.f000077500000000000000000000204531201767322700154360ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB06ND.f000077500000000000000000000261511201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB08CD.f000077500000000000000000000322711201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB08DD.f000077500000000000000000000516411201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB08ED.f000077500000000000000000000324221201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB08FD.f000077500000000000000000000552121201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB08GD.f000077500000000000000000000210511201767322700153750ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB08HD.f000077500000000000000000000221321201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB08MD.f000077500000000000000000000353371201767322700154170ustar00rootroot00000000000000 SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SB08MY.f000077500000000000000000000061321201767322700154330ustar00rootroot00000000000000 SUBROUTINE SB08MY( DA, A, B, EPSB ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB08ND.f000077500000000000000000000312111201767322700154030ustar00rootroot00000000000000 SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SB08NY.f000077500000000000000000000047601201767322700154410ustar00rootroot00000000000000 SUBROUTINE SB08NY( DA, A, B, EPSB ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB09MD.f000077500000000000000000000200731201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB10AD.f000077500000000000000000000745111201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10DD.f000077500000000000000000001052431201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10ED.f000077500000000000000000000413131201767322700153670ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10FD.f000077500000000000000000000423751201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10HD.f000077500000000000000000000322371201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10ID.f000077500000000000000000000451751201767322700154050ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10JD.f000077500000000000000000000262151201767322700154000ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB10KD.f000077500000000000000000000522671201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10LD.f000077500000000000000000000343541201767322700154050ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10MD.f000077500000000000000000000574131201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB10PD.f000077500000000000000000000431121201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB10QD.f000077500000000000000000000476371201767322700154220ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10RD.f000077500000000000000000000575541201767322700154220ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10SD.f000077500000000000000000000515261201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10TD.f000077500000000000000000000265531201767322700154170ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10UD.f000077500000000000000000000336521201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB10VD.f000077500000000000000000000312751201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10WD.f000077500000000000000000000233521201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10YD.f000077500000000000000000000531411201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB10ZD.f000077500000000000000000000740231201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SB10ZP.f000077500000000000000000000261071201767322700154340ustar00rootroot00000000000000 SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, $ LDWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SB16AD.f000077500000000000000000000707031201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SB16AY.f000077500000000000000000000763271201767322700154330ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SB16BD.f000077500000000000000000000613151201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SB16CD.f000077500000000000000000000503311201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SB16CY.f000077500000000000000000000324621201767322700154250ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/SG02AD.f000077500000000000000000001052111201767322700153670ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SG03AD.f000077500000000000000000000565271201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SG03AX.f000077500000000000000000000527151201767322700154260ustar00rootroot00000000000000 SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SG03AY.f000077500000000000000000000526721201767322700154310ustar00rootroot00000000000000 SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SG03BD.f000077500000000000000000000711311201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SG03BU.f000077500000000000000000000613111201767322700154140ustar00rootroot00000000000000 SUBROUTINE SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, $ DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SG03BV.f000077500000000000000000000544501201767322700154230ustar00rootroot00000000000000 SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, $ DWORK, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/SG03BW.f000077500000000000000000000355171201767322700154270ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SG03BX.f000077500000000000000000000624141201767322700154240ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/SG03BY.f000077500000000000000000000053441201767322700154240ustar00rootroot00000000000000 SUBROUTINE SG03BY( XR, XI, YR, YI, CR, CI, SR, SI, Z ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TB01ID.f000077500000000000000000000277611201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01IZ.f000077500000000000000000000302401201767322700154170ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01KD.f000077500000000000000000000304331201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TB01LD.f000077500000000000000000000303121201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01MD.f000077500000000000000000000255331201767322700154060ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01ND.f000077500000000000000000000257631201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01PD.f000077500000000000000000000312311201767322700154010ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01TD.f000077500000000000000000000245051201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01TY.f000077500000000000000000000114441201767322700154360ustar00rootroot00000000000000 SUBROUTINE TB01TY( MODE, IOFF, JOFF, NROW, NCOL, SIZE, X, LDX, $ BVECT ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/TB01UD.f000077500000000000000000000432041201767322700154110ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01VD.f000077500000000000000000000424401201767322700154130ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01VY.f000077500000000000000000000240721201767322700154410ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01WD.f000077500000000000000000000212131201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01XD.f000077500000000000000000000210711201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01XZ.f000077500000000000000000000206711201767322700154450ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01YD.f000077500000000000000000000123131201767322700154120ustar00rootroot00000000000000 SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB01ZD.f000077500000000000000000000363011201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB03AD.f000077500000000000000000000643221201767322700153730ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB03AY.f000077500000000000000000000126341201767322700154170ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB04AD.f000077500000000000000000000345411201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB04AY.f000077500000000000000000000213011201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/TB04BD.f000077500000000000000000000532371201767322700154000ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TB04BV.f000077500000000000000000000262311201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TB04BW.f000077500000000000000000000221351201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TB04BX.f000077500000000000000000000170501201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TB04CD.f000077500000000000000000000514051201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TB05AD.f000077500000000000000000000443171201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TC01OD.f000077500000000000000000000166651201767322700154170ustar00rootroot00000000000000 SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TC04AD.f000077500000000000000000000410261201767322700153710ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TC05AD.f000077500000000000000000000327411201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TD03AD.f000077500000000000000000000524451201767322700154000ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TD03AY.f000077500000000000000000000140371201767322700154200ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/TD04AD.f000077500000000000000000000353611201767322700153770ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TD05AD.f000077500000000000000000000223041201767322700153710ustar00rootroot00000000000000 SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should 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 slicot-5.0+20101122/src/TF01MD.f000077500000000000000000000165601201767322700154120ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TF01MX.f000077500000000000000000000332011201767322700154250ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TF01MY.f000077500000000000000000000265631201767322700154430ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TF01ND.f000077500000000000000000000213461201767322700154110ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a 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 slicot-5.0+20101122/src/TF01OD.f000077500000000000000000000127151201767322700154120ustar00rootroot00000000000000 SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TF01PD.f000077500000000000000000000130661201767322700154130ustar00rootroot00000000000000 SUBROUTINE TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TF01QD.f000077500000000000000000000176471201767322700154250ustar00rootroot00000000000000 SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TF01RD.f000077500000000000000000000160261201767322700154140ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TG01AD.f000077500000000000000000000375511201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TG01AZ.f000077500000000000000000000402411201767322700154160ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TG01BD.f000077500000000000000000000400661201767322700153760ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TG01CD.f000077500000000000000000000226031201767322700153740ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TG01DD.f000077500000000000000000000230561201767322700154000ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TG01ED.f000077500000000000000000000705641201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TG01FD.f000077500000000000000000000627661201767322700154150ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TG01FZ.f000077500000000000000000000636051201767322700154340ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TG01HD.f000077500000000000000000000500541201767322700154020ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TG01HX.f000077500000000000000000000577011201767322700154340ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. 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, ZERO PARAMETER ( ONE = 1.0D0, 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, TOLZ, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 = ABS( B(IROW,I) )/DWORK(I) T = MAX( ( ONE + T )*( ONE - T ), ZERO) TT = T*( DWORK(I)/DWORK(M+I) )**2 IF( TT.GT.TOLZ ) 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 slicot-5.0+20101122/src/TG01ID.f000077500000000000000000000533251201767322700154070ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received 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 slicot-5.0+20101122/src/TG01JD.f000077500000000000000000000552151201767322700154100ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/TG01WD.f000077500000000000000000000257171201767322700154310ustar00rootroot00000000000000 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-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/UD01BD.f000077500000000000000000000101771201767322700153740ustar00rootroot00000000000000 SUBROUTINE UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/UD01CD.f000077500000000000000000000126661201767322700154020ustar00rootroot00000000000000 SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/UD01DD.f000077500000000000000000000073551201767322700154020ustar00rootroot00000000000000 SUBROUTINE UD01DD( M, N, NIN, A, LDA, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/UD01MD.f000077500000000000000000000115511201767322700154040ustar00rootroot00000000000000 SUBROUTINE UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/UD01MZ.f000077500000000000000000000114561201767322700154360ustar00rootroot00000000000000 SUBROUTINE UD01MZ( M, N, L, NOUT, A, LDA, TEXT, INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/UD01ND.f000077500000000000000000000137151201767322700154110ustar00rootroot00000000000000 SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/UE01MD.f000077500000000000000000000224361201767322700154110ustar00rootroot00000000000000 INTEGER FUNCTION UE01MD( ISPEC, NAME, OPTS, N1, N2, N3 ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have 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 slicot-5.0+20101122/src/delctg.f000077500000000000000000000016511201767322700157540ustar00rootroot00000000000000 LOGICAL FUNCTION DELCTG( PAR1, PAR2, PAR3 ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src/makefile000077500000000000000000000145041201767322700160440ustar00rootroot00000000000000#################################################################### # SLICOT routines makefile # # Makefile for creating/updating the SLICOT Library object file # # on Unix machines. # # SLICOT, Release 5.0 ./slicot/src/makefile # # Vasile Sima, KU Leuven # # October 31, 1996. # # Revised June 25, 1998. # # Revised December 7, 1999, September 5, 2003, Jan. 9, 2009, # # Nov. 17, 2010 # #################################################################### # # This is the makefile to create/update the library for SLICOT. # The SLICOT Library routines are written for double precision only. # # The command # make # without any arguments creates or updates a library called # slicot.a # in the next higher directory level. # # To remove the object files after the library is created, enter # make clean # # On some systems, you can force the source files to be recompiled by # entering (for example) # make double FRC=FRC # ####################################################################### include ../make.inc DSLSRC = \ AB01MD.o AB01ND.o AB01OD.o AB04MD.o AB05MD.o AB05ND.o AB05OD.o \ AB05PD.o AB05QD.o AB05RD.o AB05SD.o AB07MD.o AB07ND.o AB08MD.o \ AB08ND.o AB08NX.o AB09AD.o AB09AX.o AB09BD.o AB09BX.o AB09CD.o \ AB09CX.o AB09DD.o AB09ED.o AB09FD.o AB09GD.o AB09HD.o AB09HX.o \ AB09HY.o AB09ID.o AB09IX.o AB09IY.o AB09JD.o AB09JV.o AB09JW.o \ AB09JX.o AB09KD.o AB09KX.o AB09MD.o AB09ND.o AB13AD.o AB13AX.o \ AB13BD.o AB13CD.o AB13DD.o AB13DX.o AB13ED.o AB13FD.o AB13MD.o \ AG07BD.o AG08BD.o AG08BY.o \ BB01AD.o BB02AD.o BB03AD.o BB04AD.o BD01AD.o BD02AD.o \ DE01OD.o DE01PD.o DF01MD.o DG01MD.o DG01ND.o DG01NY.o DG01OD.o \ DK01MD.o \ FB01QD.o FB01RD.o FB01SD.o FB01TD.o FB01VD.o FD01AD.o \ IB01AD.o IB01BD.o IB01CD.o IB01MD.o IB01MY.o IB01ND.o IB01OD.o \ IB01OY.o IB01PD.o IB01PX.o IB01PY.o IB01QD.o IB01RD.o \ IB03AD.o IB03BD.o \ MA01AD.o MA02AD.o MA02BD.o MA02CD.o MA02DD.o MA02ED.o MA02FD.o \ MA02GD.o MA02HD.o MB01PD.o MB01QD.o MB01RD.o MB01RU.o MB01RW.o \ MB01RX.o MB01RY.o MB01SD.o MB01TD.o MB01UD.o MB01UW.o MB01VD.o \ MB01WD.o MB01XD.o MB01XY.o MB01YD.o MB01ZD.o MB02CD.o MB02CU.o \ MB02CV.o MB02CX.o MB02CY.o MB02DD.o MB02ED.o MB02FD.o MB02GD.o \ MB02HD.o MB02ID.o MB02JD.o MB02JX.o MB02KD.o MB02MD.o MB02ND.o \ MB02NY.o MB02OD.o MB02PD.o MB02QD.o MB02QY.o MB02RD.o MB02RZ.o \ MB02SD.o MB02SZ.o MB02TD.o MB02TZ.o MB02UD.o MB02UU.o MB02UV.o \ MB02VD.o MB02WD.o MB02XD.o MB02YD.o \ MB03MD.o MB03MY.o MB03ND.o MB03NY.o MB03OD.o MB03OY.o \ MB03PD.o MB03PY.o MB03QD.o MB03QX.o MB03QY.o MB03RD.o MB03RX.o \ MB03RY.o MB03SD.o MB03UD.o MB03VD.o MB03VY.o MB03WD.o MB03WX.o \ MB04DY.o MB04GD.o MB04ID.o MB04IY.o MB04JD.o MB04KD.o MB04LD.o \ MB04MD.o MB04ND.o MB04NY.o MB04OD.o MB04OW.o MB04OX.o MB04OY.o \ MB04PY.o MB04TT.o MB04TU.o MB04TV.o MB04TW.o MB04TX.o MB04TY.o \ MB04UD.o MB04VD.o MB04VX.o MB04XD.o MB04XY.o MB04YD.o MB04YW.o \ MB04ZD.o MB05MD.o MB05MY.o MB05ND.o MB05OD.o MB05OY.o MC01MD.o \ MC01ND.o MC01OD.o MC01PD.o MC01PY.o MC01QD.o MC01RD.o MC01SD.o \ MC01SW.o MC01SX.o MC01SY.o MC01TD.o MC01VD.o MC01WD.o MC03MD.o \ MC03ND.o MC03NX.o MC03NY.o \ MD03AD.o MD03BA.o MD03BB.o MD03BD.o MD03BF.o MD03BX.o MD03BY.o \ NF01AD.o NF01AY.o NF01BA.o NF01BB.o NF01BD.o NF01BE.o NF01BF.o \ NF01BP.o NF01BQ.o NF01BR.o NF01BS.o NF01BU.o NF01BV.o NF01BW.o \ NF01BX.o NF01BY.o \ SB01BD.o SB01BX.o SB01BY.o SB01DD.o SB01FY.o SB01MD.o SB02CX.o \ SB02MD.o SB02MR.o SB02MS.o SB02MT.o SB02MU.o SB02MV.o SB02MW.o \ SB02ND.o SB02OD.o SB02OU.o SB02OV.o SB02OW.o SB02OX.o SB02OY.o \ SB02PD.o SB02QD.o SB02RD.o SB02RU.o SB02SD.o SB03MD.o SB03MU.o \ SB03MV.o SB03MW.o SB03MX.o SB03MY.o SB03OD.o SB03OR.o SB03OT.o \ SB03OU.o SB03OV.o SB03OY.o SB03PD.o SB03QD.o SB03QX.o SB03QY.o \ SB03RD.o SB03SD.o SB03SX.o SB03SY.o SB03TD.o SB03UD.o SB04MD.o \ SB04MR.o SB04MU.o SB04MW.o SB04MY.o SB04ND.o SB04NV.o SB04NW.o \ SB04NX.o SB04NY.o SB04OD.o SB04PD.o SB04PX.o SB04PY.o SB04QD.o \ SB04QR.o SB04QU.o SB04QY.o SB04RD.o SB04RV.o SB04RW.o SB04RX.o \ SB04RY.o SB06ND.o SB08CD.o SB08DD.o SB08ED.o SB08FD.o SB08GD.o \ SB08HD.o SB08MD.o SB08MY.o SB08ND.o SB08NY.o SB09MD.o SB10AD.o \ SB10DD.o SB10ED.o SB10FD.o SB10HD.o SB10ID.o SB10JD.o SB10KD.o \ SB10MD.o SB10LD.o SB10PD.o SB10QD.o SB10RD.o SB10SD.o SB10TD.o \ SB10UD.o SB10VD.o SB10WD.o SB10YD.o SB10ZD.o SB10ZP.o SB16AD.o \ SB16AY.o SB16BD.o SB16CD.o SB16CY.o SG02AD.o SG03AD.o SG03AX.o \ SG03AY.o SG03BD.o SG03BU.o SG03BV.o SG03BW.o SG03BX.o SG03BY.o \ TB01ID.o TB01KD.o TB01LD.o TB01MD.o TB01ND.o TB01PD.o TB01TD.o \ TB01TY.o TB01UD.o TB01VD.o TB01VY.o TB01WD.o TB01XD.o TB01YD.o \ TB01ZD.o TB03AD.o TB03AY.o TB04AD.o TB04AY.o TB04BD.o TB04BV.o \ TB04BW.o TB04BX.o TB04CD.o TB05AD.o TC01OD.o TC04AD.o TC05AD.o \ TD03AD.o TD03AY.o TD04AD.o TD05AD.o TF01MD.o TF01MX.o TF01MY.o \ TF01ND.o TF01OD.o TF01PD.o TF01QD.o TF01RD.o TG01AD.o TG01BD.o \ TG01CD.o TG01DD.o TG01ED.o TG01FD.o TG01HD.o TG01HX.o TG01ID.o \ TG01JD.o TG01WD.o \ UD01BD.o UD01CD.o UD01DD.o UD01MD.o UD01ND.o select.o delctg.o \ MA02ID.o MA02JD.o MB01MD.o MB01ND.o MB01UX.o MB03TD.o MB03TS.o \ MB03WA.o MB03XD.o MB03XP.o MB03XU.o MB03YA.o MB03YD.o MB03YT.o \ MB03ZA.o MB03ZD.o MB04DD.o MB04DI.o MB04DS.o MB04PA.o MB04PB.o \ MB04PU.o MB04QB.o MB04QC.o MB04QF.o MB04QU.o MB04TB.o MB04TS.o \ MB04WD.o MB04WP.o MB04WR.o MB04WU.o SB04OW.o UE01MD.o UD01MZ.o \ AB08MZ.o AB08NZ.o AB8NXZ.o AG08BZ.o AG8BYZ.o MA02BZ.o MA02CZ.o \ MB04IZ.o MB3OYZ.o MB3PYZ.o TB01IZ.o TB01XZ.o TG01AZ.o TG01FZ.o \ MA01BD.o MA01CD.o MB01KD.o MB01LD.o MB02UW.o MB03AD.o MB03BA.o \ MB03BB.o MB03BC.o MB03BD.o MB03BE.o MB03CD.o MB03DD.o MB03ED.o \ MB03FD.o MB03GD.o MB03HD.o MB03ID.o MB03JD.o MB03KA.o MB03KB.o \ MB03KC.o MB03KD.o MB03KE.o MB03LD.o MB04AD.o MB04BD.o MB04HD.o \ MB04SU.o all: double double: $(DSLSRC) $(ARCH) $(ARCHFLAGS) $(SLICOTLIB) $(DSLSRC) $(DSLSRC): $(FRC) FRC: @FRC=$(FRC) clean: rm -f *.o .f.o: $(FORTRAN) $(OPTS) -c $< slicot-5.0+20101122/src/readme000077500000000000000000000005341201767322700155220ustar00rootroot00000000000000SLICOT 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). slicot-5.0+20101122/src/select.f000077500000000000000000000016351201767322700157730ustar00rootroot00000000000000 LOGICAL FUNCTION SELECT( PAR1, PAR2 ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2010 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C 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 slicot-5.0+20101122/src_aux/000077500000000000000000000000001201767322700152125ustar00rootroot00000000000000slicot-5.0+20101122/src_aux/dcabs1.f000077500000000000000000000005141201767322700165210ustar00rootroot00000000000000 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 slicot-5.0+20101122/src_aux/dhgeqz.f000077500000000000000000001235011201767322700166500ustar00rootroot00000000000000 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 slicot-5.0+20101122/src_aux/dlagv2.f000077500000000000000000000216561201767322700165550ustar00rootroot00000000000000 SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * * -- LAPACK auxiliary routine (version 3.2) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2006 * V. Sima, February 2009: additional WI initialization; * better efficiency in some DROT calls. * * .. Scalar Arguments .. INTEGER LDA, LDB DOUBLE PRECISION CSL, CSR, SNL, SNR * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), $ B( LDB, * ), BETA( 2 ) * .. * * Purpose * ======= * * DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 * matrix pencil (A,B) where B is upper triangular. This routine * computes orthogonal (rotation) matrices given by CSL, SNL and CSR, * SNR such that * * 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 * types), then * * [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] * [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] * * [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] * [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], * * 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, * then * * [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] * [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] * * [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] * [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] * * where b11 >= b22 > 0. * * * Arguments * ========= * * A (input/output) DOUBLE PRECISION array, dimension (LDA, 2) * On entry, the 2 x 2 matrix A. * On exit, A is overwritten by the ``A-part'' of the * generalized Schur form. * * LDA (input) INTEGER * THe leading dimension of the array A. LDA >= 2. * * B (input/output) DOUBLE PRECISION array, dimension (LDB, 2) * On entry, the upper triangular 2 x 2 matrix B. * On exit, B is overwritten by the ``B-part'' of the * generalized Schur form. * * LDB (input) INTEGER * THe leading dimension of the array B. LDB >= 2. * * ALPHAR (output) DOUBLE PRECISION array, dimension (2) * ALPHAI (output) DOUBLE PRECISION array, dimension (2) * BETA (output) DOUBLE PRECISION array, dimension (2) * (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the * pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may * be zero. * * CSL (output) DOUBLE PRECISION * The cosine of the left rotation matrix. * * SNL (output) DOUBLE PRECISION * The sine of the left rotation matrix. * * CSR (output) DOUBLE PRECISION * The cosine of the right rotation matrix. * * SNR (output) DOUBLE PRECISION * The sine of the right rotation matrix. * * Further Details * =============== * * Based on contributions by * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ, $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1, $ WR2 * .. * .. External Subroutines .. EXTERNAL DLAG2, DLARTG, DLASV2, DROT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'P' ) * * Scale A * ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) ASCALE = ONE / ANORM A( 1, 1 ) = ASCALE*A( 1, 1 ) A( 1, 2 ) = ASCALE*A( 1, 2 ) A( 2, 1 ) = ASCALE*A( 2, 1 ) A( 2, 2 ) = ASCALE*A( 2, 2 ) * * Scale B * BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ), $ SAFMIN ) BSCALE = ONE / BNORM B( 1, 1 ) = BSCALE*B( 1, 1 ) B( 1, 2 ) = BSCALE*B( 1, 2 ) B( 2, 2 ) = BSCALE*B( 2, 2 ) * * Check if A can be deflated * IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN CSL = ONE SNL = ZERO CSR = ONE SNR = ZERO A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * * Check if B is singular * ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) CSR = ONE SNR = ZERO CALL DROT( 1, A( 1, 2 ), LDA, A( 2, 2 ), LDA, CSL, SNL ) CALL DROT( 1, B( 1, 2 ), LDB, B( 2, 2 ), LDB, CSL, SNL ) A( 1, 1 ) = R A( 2, 1 ) = ZERO B( 1, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T ) SNR = -SNR CALL DROT( 1, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL DROT( 1, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) CSL = ONE SNL = ZERO A( 2, 1 ) = ZERO A( 2, 2 ) = T B( 2, 1 ) = ZERO B( 2, 2 ) = ZERO WI = ZERO * ELSE * * B is nonsingular, first compute the eigenvalues of (A,B) * CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, $ WI ) * IF( WI.EQ.ZERO ) THEN * * two real eigenvalues, compute s*A-w*B * 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 ) * RR = DLAPY2( H1, H2 ) QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 ) * IF( RR.GT.QQ ) THEN * * find right rotation matrix to zero 1,1 element of * (sA - wB) * CALL DLARTG( H2, H1, CSR, SNR, T ) * ELSE * * find right rotation matrix to zero 2,1 element of * (sA - wB) * CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T ) * END IF * 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 ) * * compute inf norms of A and B * 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 ) ) ) * IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN * * find left rotation matrix Q to zero out B(2,1) * CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R ) B( 1, 1 ) = R CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL DROT( 1, B( 1, 2 ), LDB, B( 2, 2 ), LDB, CSL, SNL ) * ELSE * * find left rotation matrix Q to zero out A(2,1) * CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) A( 1, 1 ) = R CALL DROT( 1, A( 1, 2 ), LDA, A( 2, 2 ), LDA, CSL, SNL ) CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) * END IF * A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO * ELSE * * a pair of complex conjugate eigenvalues * first compute the SVD of the matrix B * CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR, $ CSR, SNL, CSL ) * * Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and * Z is right rotation matrix computed from DLASV2 * 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 ) 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 ) * B( 2, 1 ) = ZERO B( 1, 2 ) = ZERO * END IF * END IF * * Unscaling * 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 ) * 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 ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM ALPHAR( 2 ) = ALPHAR( 1 ) ALPHAI( 2 ) = -ALPHAI( 1 ) BETA( 1 ) = ONE BETA( 2 ) = ONE END IF * RETURN * * End of DLAGV2 * END slicot-5.0+20101122/src_aux/dtgsy2.f000077500000000000000000001024441201767322700166050ustar00rootroot00000000000000 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 slicot-5.0+20101122/src_aux/makefile000077500000000000000000000037101201767322700167160ustar00rootroot00000000000000#################################################################### # Auxiliary routines makefile # # Makefile for creating/updating the auxiliary Library object file# # for SLICOT on Unix platforms. # # SLICOT, Release 5.0 ./slicot/src_aux/makefile # # Vasile Sima, ICI Bucharest # # Jan. 24, 2005. # # Revised Jan. 9, 2009, Sep. 26, 2009, Jan. 25, 2010. # #################################################################### # # This is the makefile to create/update an auxiliary library # for SLICOT. It contains a modified LAPACK routine dhgeqz # (modification made by Dai), which converged also on some special # examples for which the distributed LAPACK routine didn't converge. # Moreover, three errors have been removed in dlagv2, dhgeqz and dtgsy2. # On some platforms, the old BLAS routine dcabs1 might also be needed. # Examples are some Linux platforms, but also Sun platforms. # To compile it, comment the statement defining DSLSRC and uncomment # the statements below referring dcabs1. # The SLICOT Library routines are written for double precision only. # # The command # make # without any arguments creates or updates a library called # lpkaux.a # in the next higher directory level. # # To remove the object files after the library is created, enter # make clean # # On some systems, you can force the source files to be recompiled by # entering (for example) # make double FRC=FRC # # ####################################################################### include ../make.inc DSLSRC = \ dlagv2.o dhgeqz.o dtgsy2.o #DSLSRC = \ # dcabs1.o dhgeqz.o dtgsy2.o all: double double: $(DSLSRC) $(ARCH) $(ARCHFLAGS) $(LPKAUXLIB) $(DSLSRC) $(DSLSRC): $(FRC) FRC: @FRC=$(FRC) clean: rm -f *.o .f.o: $(FORTRAN) $(OPTS) -c $< slicot-5.0+20101122/src_aux/readme000077500000000000000000000023671201767322700164050ustar00rootroot00000000000000SLICOT Library Subdirectory src_aux ----------------------------------- SLICOT Library Subdirectory src_aux contains few auxiliary LAPACK and BLAS source files which either slightly differ from the standard distribution, or are explicitly needed for generating the SLICOT-based MATLAB executable files (MEX-files) for a specific platform. The currently included files are dcabs1, dhgeqz, dlagv2, and dtgsy2. Other files might be included, as specified in the Release.Notes or Release.History files. The file dcabs1 is a copy of the BLAS routine which might be missing in some distributions. To generate the object code for dcabs1, the file makefile in the subdirectory src_aux should be modified accordingly (see the included comments). The file dhgeqz is the David Day's slightly modified version of the corresponding LAPACK routine. Without that modification, trivial examples have been encountered on which the convergence of the QZ algorithm was not achieved. In addition, an error in the LAPACK distribution has been removed. A variable used but not always initialized in the file dlagv2 has been set. Another error in the LAPACK distribution file dtgsy2 has been removed. More details are given in the file Installation.txt from the SLICOT root directory.